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