Hdoc/DTC/Write/Plain.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE ExistentialQuantification #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE ScopedTypeVariables #-}
   8 {-# OPTIONS_GHC -fno-warn-orphans #-}
   9 module Hdoc.DTC.Write.Plain where
  10
  11 import Control.Applicative (Applicative(..), liftA2)
  12 import Control.Category
  13 import Control.Monad
  14 import Data.Bool
  15 import Data.Default.Class (Default(..))
  16 import Data.Eq (Eq(..))
  17 import Data.Foldable (Foldable(..), concat)
  18 import Data.Function (($))
  19 import Data.Int (Int)
  20 import Data.Maybe (Maybe(..), maybe)
  21 import Data.Monoid (Monoid(..))
  22 import Data.Semigroup (Semigroup(..))
  23 import Data.Text (Text)
  24 import Data.TreeSeq.Strict (Tree(..))
  25 import Data.Tuple (fst, snd)
  26 import Data.String (String, IsString(..))
  27 import Prelude (mod)
  28 import Text.Show (Show(..))
  29 import qualified Control.Monad.Trans.State as S
  30 import qualified Data.List as List
  31 import qualified Data.Text.Lazy as TL
  32 import qualified Data.Text.Lazy.Builder as TLB
  33
  34 import Data.Locale hiding (Index)
  35
  36 import Hdoc.DTC.Write.XML ()
  37 import Hdoc.DTC.Document as DTC hiding (Plain)
  38 import qualified Hdoc.DTC.Document as DTC
  39 import qualified Hdoc.XML as XML
  40
  41 -- * Type 'Plain'
  42 type Plain = S.State State TLB.Builder
  43
  44 runPlain :: Plain -> State -> (TL.Text, State)
  45 runPlain p s =
  46         let (b,s') = S.runState p s in
  47         (TLB.toLazyText b, s')
  48
  49 text :: Plainify a => State -> a -> TL.Text
  50 text st a = fst $ runPlain (plainify a) st
  51
  52 instance IsString Plain where
  53         fromString = return . fromString
  54 instance Semigroup Plain where
  55         (<>) = liftA2 (<>)
  56 instance Monoid Plain where
  57         mempty  = return ""
  58         mappend = (<>)
  59
  60 -- ** Type 'State'
  61 data State = State -- TODO: could be a Reader
  62  { state_l10n   :: Loqualization (L10n Plain)
  63  , state_italic :: Bool
  64  , state_quote  :: Nat
  65  }
  66 instance Default State where
  67         def = State
  68          { state_l10n   = Loqualization EN_US
  69          , state_italic = False
  70          , state_quote  = Nat 0
  71          }
  72
  73 -- * Class 'Plainify'
  74 class Plainify a where
  75         plainify :: a -> Plain
  76 instance Plainify String where
  77         plainify = return . TLB.fromString
  78 instance Plainify Text where
  79         plainify = return . TLB.fromText
  80 instance Plainify TL.Text where
  81         plainify = return . TLB.fromLazyText
  82 {-
  83 instance Plainify Para where
  84         plainify = \case
  85          ParaItem{..}  -> plainify item
  86          ParaItems{..} -> plainify items
  87 -}
  88 instance Plainify DTC.Plain where
  89         plainify = foldMap plainify
  90 instance Plainify (Tree PlainNode) where
  91         plainify (Tree n ls) =
  92                 case n of
  93                  PlainBreak    -> "\n"
  94                  PlainText txt -> plainify txt
  95                  PlainGroup    -> plainify ls
  96                  PlainB        -> "*"<>plainify ls<>"*"
  97                  PlainCode     -> "`"<>plainify ls<>"`"
  98                  PlainDel      -> "-"<>plainify ls<>"-"
  99                  PlainI        -> "/"<>plainify ls<>"/"
 100                  PlainNote{..} -> "" -- TODO: to be coded, with a switch on/off in State
 101                  PlainQ        -> do
 102                         State{state_l10n=Loqualization loc} <- S.get
 103                         l10n_Quote (plainify ls) loc
 104                  PlainSC       -> plainify ls
 105                  PlainSpan{..} -> plainify ls
 106                  PlainSub      -> plainify ls
 107                  PlainSup      -> plainify ls
 108                  PlainU        -> "_"<>plainify ls<>"_"
 109                  PlainEref{..} -> plainify ls
 110                  PlainIref{..} -> plainify ls
 111                  PlainTag{..}  -> "#"<>plainify ls<>"#"
 112                  PlainRref{..} -> plainify ls
 113 instance Plainify Title where
 114         plainify (Title t) = plainify t
 115 instance Plainify XML.Ancestors where
 116         plainify =
 117                 plainify .
 118                 snd . foldl' (\(nParent,acc) (n,c) ->
 119                         (n,
 120                                 (if TL.null acc then acc else acc <> ".") <>
 121                                 (if n == nParent
 122                                         then TL.pack (show c)
 123                                         else TL.pack (show n)<>TL.pack (show c))
 124                         )
 125                  )
 126                  ("","")
 127 instance Plainify XML.Name where
 128         plainify = plainify . show
 129 instance Plainify Int where
 130         plainify = plainify . show
 131 instance Plainify Nat where
 132         plainify (Nat n) = plainify n
 133 instance Plainify Nat1 where
 134         plainify (Nat1 n) = plainify n
 135
 136 -- * Type 'L10n'
 137 class L10n msg lang where
 138         l10n_Colon             ::         FullLocale lang -> msg
 139         l10n_Table_of_Contents ::         FullLocale lang -> msg
 140         l10n_Quote             :: msg  -> FullLocale lang -> msg
 141         l10n_Date              :: Date -> FullLocale lang -> msg
 142
 143 instance L10n TL.Text FR where
 144         l10n_Colon _loc = " : "
 145         l10n_Table_of_Contents _loc = "Sommaire"
 146         l10n_Quote msg _loc = "« "<>msg<>" »"
 147         l10n_Date Date{..} _loc =
 148                 TL.pack $
 149                 mconcat $
 150                 List.intersperse " " $
 151                 concat
 152                  [ maybe [] (pure . show) day
 153                  , case month of
 154                          Nothing -> []
 155                          Just (Nat1 m) ->
 156                                 case m of
 157                                  1  -> pure "janvier"
 158                                  2  -> pure "février"
 159                                  3  -> pure "mars"
 160                                  4  -> pure "avril"
 161                                  5  -> pure "mai"
 162                                  6  -> pure "juin"
 163                                  7  -> pure "juillet"
 164                                  8  -> pure "août"
 165                                  9  -> pure "septembre"
 166                                  10 -> pure "octobre"
 167                                  11 -> pure "novembre"
 168                                  12 -> pure "décembre"
 169                                  _  -> []
 170                  , [show year]
 171                  ]
 172 instance L10n TL.Text EN where
 173         l10n_Colon _loc = ": "
 174         l10n_Table_of_Contents _loc = "Table of Contents"
 175         l10n_Quote msg _loc = "“"<>msg<>"”"
 176         l10n_Date Date{..} _loc =
 177                 TL.pack $
 178                 mconcat $
 179                 List.intersperse " " $
 180                 concat
 181                  [ maybe [] (pure . show) day
 182                  , case month of
 183                          Nothing -> []
 184                          Just (Nat1 m) ->
 185                                 case m of
 186                                  1  -> pure "January"
 187                                  2  -> pure "February"
 188                                  3  -> pure "March"
 189                                  4  -> pure "April"
 190                                  5  -> pure "May"
 191                                  6  -> pure "June"
 192                                  7  -> pure "July"
 193                                  8  -> pure "August"
 194                                  9  -> pure "September"
 195                                  10 -> pure "October"
 196                                  11 -> pure "November"
 197                                  12 -> pure "December"
 198                                  _  -> []
 199                  , [show year]
 200                  ]
 201
 202 instance L10n Plain FR where
 203         l10n_Colon loc = plainify (l10n_Colon loc::TL.Text)
 204         l10n_Table_of_Contents loc = plainify (l10n_Table_of_Contents loc::TL.Text)
 205         l10n_Quote msg _loc = do
 206                 depth <- S.gets state_quote
 207                 let (o,c) =
 208                         case unNat depth `mod` 3 of
 209                          0 -> ("« "," »")
 210                          1 -> ("“","”")
 211                          _ -> ("‟","„")
 212                 S.modify' $ \s -> s{state_quote=succNat depth}
 213                 m <- msg
 214                 S.modify' $ \s -> s{state_quote=depth}
 215                 return $ o <> m <> c
 216         l10n_Date date loc = plainify (l10n_Date date loc::TL.Text)
 217 instance L10n Plain EN where
 218         l10n_Colon loc = plainify (l10n_Colon loc::TL.Text)
 219         l10n_Table_of_Contents loc = plainify (l10n_Table_of_Contents loc::TL.Text)
 220         l10n_Quote msg _loc = do
 221                 depth <- S.gets state_quote
 222                 let (o,c) =
 223                         case unNat depth `mod` 3 of
 224                          0 -> ("“","”")
 225                          1 -> ("« "," »")
 226                          _ -> ("‟","„")
 227                 S.modify' $ \s -> s{state_quote=succNat depth}
 228                 m <- msg
 229                 S.modify' $ \s -> s{state_quote=depth}
 230                 return $ o <> m <> c
 231         l10n_Date date loc = plainify (l10n_Date date loc::TL.Text)
 232
 233 {-
 234 -- ** Type 'L10nPlain'
 235 -- | Useful newtype to just use 'plainify', instead of 'state_l10n'.
 236 newtype L10nPlain = L10nPlain (forall l. L10n l Plain => FullLocale l -> Plain)
 237 instance Plainify L10nPlain where
 238         plainify (L10nPlain l10n) = do
 239                 State{state_l10n} <- S.get
 240                 l10n state_l10n
 241 -}