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                  PlainAt{..}   -> (if at_back  then "^" else mempty)<>"@"<>plainify ls<>"@"
 107                  PlainTag{..}  -> (if tag_back then "^" else mempty)<>"#"<>plainify ls<>"#"
 108                  PlainRef{..} ->
 109                         (if null ls then mempty else "("<>plainify ls<> ")") <>
 110                         "["<>plainify (unIdent ref_ident)<>"]"
 111 instance Plainify Title where
 112         plainify (Title t) = plainify t
 113 instance Plainify XML.Ancestors where
 114         plainify =
 115                 plainify .
 116                 snd . foldl' (\(nParent,acc) (n,c) ->
 117                         (n,
 118                                 (if TL.null acc then acc else acc <> ".") <>
 119                                 (if n == nParent
 120                                         then TL.pack (show c)
 121                                         else TL.pack (show n)<>TL.pack (show c))
 122                         )
 123                  )
 124                  ("","")
 125 instance Plainify XML.Name where
 126         plainify = plainify . show
 127 instance Plainify Int where
 128         plainify = plainify . show
 129 instance Plainify Nat where
 130         plainify (Nat n) = plainify n
 131 instance Plainify Nat1 where
 132         plainify (Nat1 n) = plainify n
 133
 134 -- * Type 'L10n'
 135 class L10n msg lang where
 136         l10n_Colon             ::         FullLocale lang -> msg
 137         l10n_Table_of_Contents ::         FullLocale lang -> msg
 138         l10n_Quote             :: msg  -> FullLocale lang -> msg
 139         l10n_Date              :: Date -> FullLocale lang -> msg
 140
 141 instance L10n TL.Text FR where
 142         l10n_Colon _loc = " : "
 143         l10n_Table_of_Contents _loc = "Sommaire"
 144         l10n_Quote msg _loc = "« "<>msg<>" »"
 145         l10n_Date Date{..} _loc =
 146                 TL.pack $
 147                 mconcat $
 148                 List.intersperse " " $
 149                 concat
 150                  [ maybe [] (pure . show) day
 151                  , case month of
 152                          Nothing -> []
 153                          Just (Nat1 m) ->
 154                                 case m of
 155                                  1  -> pure "janvier"
 156                                  2  -> pure "février"
 157                                  3  -> pure "mars"
 158                                  4  -> pure "avril"
 159                                  5  -> pure "mai"
 160                                  6  -> pure "juin"
 161                                  7  -> pure "juillet"
 162                                  8  -> pure "août"
 163                                  9  -> pure "septembre"
 164                                  10 -> pure "octobre"
 165                                  11 -> pure "novembre"
 166                                  12 -> pure "décembre"
 167                                  _  -> []
 168                  , [show year]
 169                  ]
 170 instance L10n TL.Text EN where
 171         l10n_Colon _loc = ": "
 172         l10n_Table_of_Contents _loc = "Table of Contents"
 173         l10n_Quote msg _loc = "“"<>msg<>"”"
 174         l10n_Date Date{..} _loc =
 175                 TL.pack $
 176                 mconcat $
 177                 List.intersperse " " $
 178                 concat
 179                  [ maybe [] (pure . show) day
 180                  , case month of
 181                          Nothing -> []
 182                          Just (Nat1 m) ->
 183                                 case m of
 184                                  1  -> pure "January"
 185                                  2  -> pure "February"
 186                                  3  -> pure "March"
 187                                  4  -> pure "April"
 188                                  5  -> pure "May"
 189                                  6  -> pure "June"
 190                                  7  -> pure "July"
 191                                  8  -> pure "August"
 192                                  9  -> pure "September"
 193                                  10 -> pure "October"
 194                                  11 -> pure "November"
 195                                  12 -> pure "December"
 196                                  _  -> []
 197                  , [show year]
 198                  ]
 199
 200 instance L10n Plain FR where
 201         l10n_Colon loc = plainify (l10n_Colon loc::TL.Text)
 202         l10n_Table_of_Contents loc = plainify (l10n_Table_of_Contents loc::TL.Text)
 203         l10n_Quote msg _loc = do
 204                 depth <- R.asks reader_quote
 205                 let (o,c) =
 206                         case unNat depth `mod` 3 of
 207                          0 -> ("« "," »")
 208                          1 -> ("“","”")
 209                          _ -> ("‟","„")
 210                 m <- R.local (\ro -> ro{reader_quote=succNat depth}) msg
 211                 return $ o <> m <> c
 212         l10n_Date date loc = plainify (l10n_Date date loc::TL.Text)
 213 instance L10n Plain EN where
 214         l10n_Colon loc = plainify (l10n_Colon loc::TL.Text)
 215         l10n_Table_of_Contents loc = plainify (l10n_Table_of_Contents loc::TL.Text)
 216         l10n_Quote msg _loc = do
 217                 depth <- R.asks reader_quote
 218                 let (o,c) =
 219                         case unNat depth `mod` 3 of
 220                          0 -> ("“","”")
 221                          1 -> ("« "," »")
 222                          _ -> ("‟","„")
 223                 m <- R.local (\s -> s{reader_quote=succNat depth}) msg
 224                 return $ o <> m <> c
 225         l10n_Date date loc = plainify (l10n_Date date loc::TL.Text)
 226
 227 {-
 228 -- ** Type 'L10nPlain'
 229 -- | Useful newtype to just use 'plainify', instead of 'state_l10n'.
 230 newtype L10nPlain = L10nPlain (forall l. L10n l Plain => FullLocale l -> Plain)
 231 instance Plainify L10nPlain where
 232         plainify (L10nPlain l10n) = do
 233                 State{state_l10n} <- S.get
 234                 l10n state_l10n
 235 -}