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