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