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