Language/DTC/Write/Plain.hs

   1 {-# LANGUAGE DuplicateRecordFields #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE MultiParamTypeClasses #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7 {-# OPTIONS_GHC -fno-warn-orphans #-}
   8 module Language.DTC.Write.Plain where
   9
  10 import Control.Applicative (Applicative(..), liftA2)
  11 import Control.Category
  12 import Control.Monad
  13 import Data.Bool
  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 (fst, snd)
  25 import Data.String (String, IsString(..))
  26 import Prelude (mod)
  27 import Text.Show (Show(..))
  28 import qualified Control.Monad.Trans.State as S
  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 Language.DTC.Write.XML ()
  36 import Language.DTC.Document as DTC hiding (Plain)
  37 import qualified Language.DTC.Document as DTC
  38
  39 -- * Type 'Plain'
  40 type Plain = S.State State TLB.Builder
  41
  42 runPlain :: Plain -> State -> (TL.Text, State)
  43 runPlain p s =
  44         let (b,s') = S.runState p s in
  45         (TLB.toLazyText b, s')
  46
  47 text :: Plainify a => State -> a -> TL.Text
  48 text st a = fst $ runPlain (plainify a) st
  49
  50 instance IsString Plain where
  51         fromString = return . fromString
  52 instance Semigroup Plain where
  53         (<>) = liftA2 (<>)
  54 instance Monoid Plain where
  55         mempty  = return ""
  56         mappend = (<>)
  57
  58 -- ** Type 'State'
  59 data State
  60  =   State
  61  {   state_localize :: L10n -> Plain
  62  ,   state_italic   :: Bool
  63  ,   state_quote    :: Nat
  64  }
  65 instance Default State where
  66         def = State
  67          { state_localize = plainify . show
  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                  PlainBR       -> "\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        ->
 101                         let depth = Nat 0 in
 102                         plainify L10n_QuoteOpen{..} <>
 103                         plainify ls <>
 104                         plainify L10n_QuoteClose{..}
 105                  PlainSC       -> plainify ls
 106                  PlainSub      -> plainify ls
 107                  PlainSup      -> plainify ls
 108                  PlainU        -> "_"<>plainify ls<>"_"
 109                  PlainEref{..} -> plainify ls
 110                  PlainIref{..} -> plainify ls
 111                  PlainRef{..}  -> plainify ls
 112                  PlainRref{..} -> plainify ls
 113 instance Plainify Title where
 114         plainify (Title t) = plainify t
 115 instance Plainify PosPath where
 116         plainify =
 117                 plainify .
 118                 snd . foldl' (\(nParent,acc) (n,c) ->
 119                         (n,
 120                                 (if TL.null acc then acc else acc <> ".") <>
 121                                 (if n == nParent
 122                                         then TL.pack (show c)
 123                                         else TL.pack (show n)<>TL.pack (show c))
 124                         )
 125                  )
 126                  ("","")
 127 instance Plainify XmlName where
 128         plainify = plainify . show
 129 instance Plainify Int where
 130         plainify = plainify . show
 131 instance Plainify Nat where
 132         plainify (Nat n) = plainify n
 133 instance Plainify Nat1 where
 134         plainify (Nat1 n) = plainify n
 135
 136 -- * Type 'L10n'
 137 data L10n
 138  =   L10n_Table_of_Contents
 139  |   L10n_Colon
 140  |   L10n_QuoteOpen  {depth :: Nat}
 141  |   L10n_QuoteClose {depth :: Nat}
 142  |   L10n_Date Date
 143  deriving (Show)
 144 instance Plainify L10n where
 145         plainify msg = do
 146                 loc <- S.gets state_localize
 147                 loc msg
 148 instance LocalizeIn FR Plain L10n where
 149         localizeIn _ = \case
 150          L10n_Table_of_Contents -> "Sommaire"
 151          L10n_Colon -> " : "
 152          L10n_QuoteOpen{..} ->
 153                 case unNat depth `mod` 3 of
 154                  0 -> "« "
 155                  1 -> "“"
 156                  _ -> "‟"
 157          L10n_QuoteClose{..} ->
 158                 case unNat depth `mod` 3 of
 159                  0 -> " »"
 160                  1 -> "”"
 161                  _ -> "„"
 162          L10n_Date Date{..} ->
 163                 mconcat $
 164                 List.intersperse " " $
 165                 concat
 166                  [ maybe [] (pure . plainify) day
 167                  , case month of
 168                          Nothing -> []
 169                          Just (Nat1 m) ->
 170                                 case m of
 171                                  1  -> pure "janvier"
 172                                  2  -> pure "février"
 173                                  3  -> pure "mars"
 174                                  4  -> pure "avril"
 175                                  5  -> pure "mai"
 176                                  6  -> pure "juin"
 177                                  7  -> pure "juillet"
 178                                  8  -> pure "août"
 179                                  9  -> pure "septembre"
 180                                  10 -> pure "octobre"
 181                                  11 -> pure "novembre"
 182                                  12 -> pure "décembre"
 183                                  _  -> []
 184                  , [plainify year]
 185                  ]
 186 instance LocalizeIn EN Plain L10n where
 187         localizeIn _ = \case
 188          L10n_Table_of_Contents -> "Summary"
 189          L10n_Colon -> ": "
 190          L10n_QuoteOpen{..} ->
 191                 case unNat depth `mod` 3 of
 192                  0 -> "“"
 193                  1 -> "« "
 194                  _ -> "‟"
 195          L10n_QuoteClose{..} ->
 196                 case unNat depth `mod` 3 of
 197                  0 -> "”"
 198                  1 -> " »"
 199                  _ -> "„"
 200          L10n_Date Date{..} ->
 201                 mconcat $
 202                 List.intersperse " " $
 203                 concat
 204                  [ maybe [] (pure . plainify) day
 205                  , case month of
 206                          Nothing -> []
 207                          Just (Nat1 m) ->
 208                                 case m of
 209                                  1  -> pure "January"
 210                                  2  -> pure "February"
 211                                  3  -> pure "March"
 212                                  4  -> pure "April"
 213                                  5  -> pure "May"
 214                                  6  -> pure "June"
 215                                  7  -> pure "July"
 216                                  8  -> pure "August"
 217                                  9  -> pure "September"
 218                                  10 -> pure "October"
 219                                  11 -> pure "November"
 220                                  12 -> pure "December"
 221                                  _  -> []
 222                  , [plainify year]
 223                  ]