Language/DTC/Write/Plain.hs

   1 {-# LANGUAGE DuplicateRecordFields #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE MultiParamTypeClasses #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7 {-# OPTIONS_GHC -fno-warn-orphans #-}
   8 module Language.DTC.Write.Plain where
   9
  10 import Control.Applicative (Applicative(..), liftA2)
  11 import Control.Category
  12 import Control.Monad
  13 import Data.Bool
  14 import Data.Default.Class (Default(..))
  15 import Data.Eq (Eq(..))
  16 import Data.Foldable (Foldable(..), concat)
  17 import Data.Function (($))
  18 import Data.Int (Int)
  19 import Data.Maybe (Maybe(..), maybe)
  20 import Data.Monoid (Monoid(..))
  21 import Data.Semigroup (Semigroup(..))
  22 import Data.Text (Text)
  23 import Data.TreeSeq.Strict (Tree(..))
  24 import Data.Tuple (fst, snd)
  25 import Data.String (String, IsString(..))
  26 import Prelude (mod)
  27 import Text.Show (Show(..))
  28 import qualified Control.Monad.Trans.State as S
  29 import qualified Data.List as List
  30 import qualified Data.Text.Lazy as TL
  31 import qualified Data.Text.Lazy.Builder as TLB
  32
  33 import Data.Locale hiding (Index)
  34
  35 import Language.DTC.Write.XML ()
  36 import qualified Language.DTC.Document as DTC
  37
  38 -- * Type 'Plain'
  39 type Plain = S.State State TLB.Builder
  40
  41 runPlain :: Plain -> State -> (TL.Text, State)
  42 runPlain p s =
  43         let (b,s') = S.runState p s in
  44         (TLB.toLazyText b, s')
  45
  46 text :: Plainify a => State -> a -> TL.Text
  47 text st a = fst $ runPlain (plainify a) st
  48
  49 instance IsString Plain where
  50         fromString = return . fromString
  51 instance Semigroup Plain where
  52         (<>) = liftA2 (<>)
  53 instance Monoid Plain where
  54         mempty  = return ""
  55         mappend = (<>)
  56
  57 -- ** Type 'State'
  58 data State
  59  =   State
  60  {   state_localize :: L10n -> Plain
  61  ,   state_italic   :: Bool
  62  ,   state_quote    :: DTC.Nat
  63  }
  64 instance Default State where
  65         def = State
  66          { state_localize = plainify . show
  67          , state_italic   = False
  68          , state_quote    = DTC.Nat 0
  69          }
  70
  71
  72 -- * Class 'Plainify'
  73 class Plainify a where
  74         plainify :: a -> Plain
  75 instance Plainify String where
  76         plainify = return . TLB.fromString
  77 instance Plainify Text where
  78         plainify = return . TLB.fromText
  79 instance Plainify TL.Text where
  80         plainify = return . TLB.fromLazyText
  81 instance Plainify DTC.Para where
  82         plainify = foldMap plainify
  83 instance Plainify DTC.Lines where
  84         plainify (Tree n ls) =
  85                 case n of
  86                  DTC.BR       -> "\n"
  87                  DTC.Plain p  -> plainify p
  88                  DTC.B        -> "*"<>plainify ls<>"*"
  89                  DTC.Code     -> "`"<>plainify ls<>"`"
  90                  DTC.Del      -> "-"<>plainify ls<>"-"
  91                  DTC.I        -> "/"<>plainify ls<>"/"
  92                  DTC.Note{..} -> ""
  93                  DTC.Q        ->
  94                         let depth = DTC.Nat 0 in
  95                         plainify L10n_QuoteOpen{..} <>
  96                         plainify ls <>
  97                         plainify L10n_QuoteClose{..}
  98                  DTC.SC       -> plainify ls
  99                  DTC.Sub      -> plainify ls
 100                  DTC.Sup      -> plainify ls
 101                  DTC.U        -> "_"<>plainify ls<>"_"
 102                  DTC.Eref{..} -> plainify ls
 103                  DTC.Iref{..} -> plainify ls
 104                  DTC.Ref{..}  -> plainify ls
 105                  DTC.Rref{..} -> plainify ls
 106 instance Plainify DTC.Title where
 107         plainify (DTC.Title t) = plainify t
 108 instance Plainify DTC.PosPath where
 109         plainify =
 110                 plainify .
 111                 snd . foldl' (\(nParent,acc) (n,c) ->
 112                         (n,
 113                                 (if TL.null acc then acc else acc <> ".") <>
 114                                 (if n == nParent
 115                                         then TL.pack (show c)
 116                                         else TL.pack (show n)<>TL.pack (show c))
 117                         )
 118                  )
 119                  ("","")
 120 instance Plainify DTC.XmlName where
 121         plainify = plainify . show
 122 instance Plainify Int where
 123         plainify = plainify . show
 124 instance Plainify DTC.Nat where
 125         plainify (DTC.Nat n) = plainify n
 126 instance Plainify DTC.Nat1 where
 127         plainify (DTC.Nat1 n) = plainify n
 128
 129 -- * Type 'L10n'
 130 data L10n
 131  =   L10n_Table_of_Contents
 132  |   L10n_Colon
 133  |   L10n_QuoteOpen  {depth :: DTC.Nat}
 134  |   L10n_QuoteClose {depth :: DTC.Nat}
 135  |   L10n_Date DTC.Date
 136  deriving (Show)
 137 instance Plainify L10n where
 138         plainify msg = do
 139                 loc <- S.gets state_localize
 140                 loc msg
 141 instance LocalizeIn FR Plain L10n where
 142         localizeIn _ = \case
 143          L10n_Table_of_Contents -> "Sommaire"
 144          L10n_Colon -> " : "
 145          L10n_QuoteOpen{..} ->
 146                 case DTC.unNat depth `mod` 3 of
 147                  0 -> "« "
 148                  1 -> "“"
 149                  _ -> "‟"
 150          L10n_QuoteClose{..} ->
 151                 case DTC.unNat depth `mod` 3 of
 152                  0 -> " »"
 153                  1 -> "”"
 154                  _ -> "„"
 155          L10n_Date DTC.Date{..} ->
 156                 mconcat $
 157                 List.intersperse " " $
 158                 concat
 159                  [ maybe [] (pure . plainify) day
 160                  , case month of
 161                          Nothing -> []
 162                          Just (DTC.Nat1 m) ->
 163                                 case m of
 164                                  1  -> pure "janvier"
 165                                  2  -> pure "février"
 166                                  3  -> pure "mars"
 167                                  4  -> pure "avril"
 168                                  5  -> pure "mai"
 169                                  6  -> pure "juin"
 170                                  7  -> pure "juillet"
 171                                  8  -> pure "août"
 172                                  9  -> pure "septembre"
 173                                  10 -> pure "octobre"
 174                                  11 -> pure "novembre"
 175                                  12 -> pure "décembre"
 176                                  _  -> []
 177                  , [plainify year]
 178                  ]
 179 instance LocalizeIn EN Plain L10n where
 180         localizeIn _ = \case
 181          L10n_Table_of_Contents -> "Summary"
 182          L10n_Colon -> ": "
 183          L10n_QuoteOpen{..} ->
 184                 case DTC.unNat depth `mod` 3 of
 185                  0 -> "“"
 186                  1 -> "« "
 187                  _ -> "‟"
 188          L10n_QuoteClose{..} ->
 189                 case DTC.unNat depth `mod` 3 of
 190                  0 -> "”"
 191                  1 -> " »"
 192                  _ -> "„"
 193          L10n_Date DTC.Date{..} ->
 194                 mconcat $
 195                 List.intersperse " " $
 196                 concat
 197                  [ maybe [] (pure . plainify) day
 198                  , case month of
 199                          Nothing -> []
 200                          Just (DTC.Nat1 m) ->
 201                                 case m of
 202                                  1  -> pure "January"
 203                                  2  -> pure "February"
 204                                  3  -> pure "March"
 205                                  4  -> pure "April"
 206                                  5  -> pure "May"
 207                                  6  -> pure "June"
 208                                  7  -> pure "July"
 209                                  8  -> pure "August"
 210                                  9  -> pure "September"
 211                                  10 -> pure "October"
 212                                  11 -> pure "November"
 213                                  12 -> pure "December"
 214                                  _  -> []
 215                  , [plainify year]
 216                  ]