Language/DTC/Write/Plain.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE DuplicateRecordFields #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE FlexibleContexts #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE ScopedTypeVariables #-}
   8 {-# LANGUAGE TypeApplications #-}
   9 {-# OPTIONS_GHC -fno-warn-orphans #-}
  10 module Language.DTC.Write.Plain where
  11
  12 import Control.Applicative (Applicative(..), liftA2)
  13 import Control.Category
  14 import Control.Monad
  15 import Data.Bool
  16 import Data.Default.Class (Default(..))
  17 import Data.Eq (Eq(..))
  18 import Data.Foldable (Foldable(..), concat)
  19 import Data.Function (($))
  20 import Data.Int (Int)
  21 import Data.Maybe (Maybe(..), maybe)
  22 import Data.Monoid (Monoid(..))
  23 import Data.Semigroup (Semigroup(..))
  24 import Data.String (String)
  25 import Data.Text (Text)
  26 import Data.TreeSeq.Strict (Tree(..))
  27 import Data.Tuple (fst, snd)
  28 import Data.String (IsString(..))
  29 import Prelude (mod)
  30 import Text.Show (Show(..))
  31 import qualified Control.Monad.Trans.State as S
  32 import qualified Data.List as List
  33 import qualified Data.Text.Lazy as TL
  34 import qualified Data.Text.Lazy.Builder as TLB
  35
  36 import Data.Locale hiding (localize, Index)
  37
  38 import Language.DTC.Write.XML ()
  39 import qualified Language.DTC.Document as DTC
  40
  41 -- * Type 'Plain'
  42 type Plain = S.State State TLB.Builder
  43
  44 runPlain :: Plain -> State -> (TL.Text, State)
  45 runPlain p s =
  46         let (b,s') = S.runState p s in
  47         (TLB.toLazyText b, s')
  48
  49 text :: Plainify a => State -> a -> TL.Text
  50 text st a = fst $ runPlain (plainify a) st
  51
  52 instance IsString Plain where
  53         fromString = return . fromString
  54 instance Semigroup Plain where
  55         (<>) = liftA2 (<>)
  56 instance Monoid Plain where
  57         mempty = return ""
  58         mappend = (<>)
  59
  60 -- ** Type 'State'
  61 data State
  62  =   State
  63  {   state_localize :: L10n -> Plain
  64  ,   state_italic   :: Bool
  65  ,   state_quote    :: DTC.Nat
  66  }
  67 instance Default State where
  68         def = State
  69          { state_localize = plainify . show
  70          , state_italic   = False
  71          , state_quote    = DTC.Nat 0
  72          }
  73
  74
  75 -- * Class 'Plainify'
  76 class Plainify a where
  77         plainify :: a -> Plain
  78 instance Plainify String where
  79         plainify = return . TLB.fromString
  80 instance Plainify Text where
  81         plainify = return . TLB.fromText
  82 instance Plainify TL.Text where
  83         plainify = return . TLB.fromLazyText
  84 instance Plainify DTC.Para where
  85         plainify = foldMap plainify
  86 instance Plainify DTC.Lines where
  87         plainify = \case
  88          Tree0 v ->
  89                 case v of
  90                  DTC.BR -> "\n"
  91                  DTC.Plain p -> plainify p
  92          TreeN k ls ->
  93                 case k of
  94                  DTC.B        -> "*"<>plainify ls<>"*"
  95                  DTC.Code     -> "`"<>plainify ls<>"`"
  96                  DTC.Del      -> "-"<>plainify ls<>"-"
  97                  DTC.I        -> "/"<>plainify ls<>"/"
  98                  DTC.Note     -> ""
  99                  DTC.Q        ->
 100                         let depth = DTC.Nat 0 in
 101                         plainify (L10n_QuoteOpen{..}) <>
 102                         plainify ls <>
 103                         plainify (L10n_QuoteClose{..})
 104                  DTC.SC       -> plainify ls
 105                  DTC.Sub      -> plainify ls
 106                  DTC.Sup      -> plainify ls
 107                  DTC.U        -> "_"<>plainify ls<>"_"
 108                  DTC.Eref{..} -> plainify ls
 109                  DTC.Iref{..} -> plainify ls
 110                  DTC.Ref{..}  -> plainify ls
 111                  DTC.Rref{..} -> plainify ls
 112 instance Plainify DTC.Title where
 113         plainify (DTC.Title t) = plainify t
 114 instance Plainify DTC.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 DTC.XmlName where
 127         plainify = plainify . show
 128 instance Plainify Int where
 129         plainify = plainify . show
 130 instance Plainify DTC.Nat where
 131         plainify (DTC.Nat n) = plainify n
 132 instance Plainify DTC.Nat1 where
 133         plainify (DTC.Nat1 n) = plainify n
 134
 135 -- * Type 'L10n'
 136 data L10n
 137  =   L10n_Table_of_Contents
 138  |   L10n_Colon
 139  |   L10n_QuoteOpen  {depth :: DTC.Nat}
 140  |   L10n_QuoteClose {depth :: DTC.Nat}
 141  |   L10n_Date DTC.Date
 142  deriving (Show)
 143 instance Plainify L10n where
 144         plainify msg = do
 145                 loc <- S.gets state_localize
 146                 loc msg
 147 instance LocalizeIn FR Plain L10n where
 148         localizeIn _ = \case
 149          L10n_Table_of_Contents -> "Sommaire"
 150          L10n_Colon -> " :"
 151          L10n_QuoteOpen{..} ->
 152                 case DTC.unNat depth `mod` 3 of
 153                  0 -> "« "
 154                  1 -> "“"
 155                  _ -> "‟"
 156          L10n_QuoteClose{..} ->
 157                 case DTC.unNat depth `mod` 3 of
 158                  0 -> " »"
 159                  1 -> "”"
 160                  _ -> "„"
 161          L10n_Date DTC.Date{..} ->
 162                 mconcat $
 163                 List.intersperse " " $
 164                 concat
 165                  [ maybe [] (pure . plainify) day
 166                  , case month of
 167                          Nothing -> []
 168                          Just (DTC.Nat1 m) ->
 169                                 case m of
 170                                  1  -> pure "janvier"
 171                                  2  -> pure "février"
 172                                  3  -> pure "mars"
 173                                  4  -> pure "avril"
 174                                  5  -> pure "mai"
 175                                  6  -> pure "juin"
 176                                  7  -> pure "juillet"
 177                                  8  -> pure "août"
 178                                  9  -> pure "septembre"
 179                                  10 -> pure "octobre"
 180                                  11 -> pure "novembre"
 181                                  12 -> pure "décembre"
 182                                  _  -> []
 183                  , [plainify year]
 184                  ]
 185 instance LocalizeIn EN Plain L10n where
 186         localizeIn _ = \case
 187          L10n_Table_of_Contents -> "Summary"
 188          L10n_Colon -> ":"
 189          L10n_QuoteOpen{..} ->
 190                 case DTC.unNat depth `mod` 3 of
 191                  0 -> "“"
 192                  1 -> "« "
 193                  _ -> "‟"
 194          L10n_QuoteClose{..} ->
 195                 case DTC.unNat depth `mod` 3 of
 196                  0 -> "”"
 197                  1 -> " »"
 198                  _ -> "„"
 199          L10n_Date DTC.Date{..} ->
 200                 mconcat $
 201                 List.intersperse " " $
 202                 concat
 203                  [ maybe [] (pure . plainify) day
 204                  , case month of
 205                          Nothing -> []
 206                          Just (DTC.Nat1 m) ->
 207                                 case m of
 208                                  1  -> pure "January"
 209                                  2  -> pure "February"
 210                                  3  -> pure "March"
 211                                  4  -> pure "April"
 212                                  5  -> pure "May"
 213                                  6  -> pure "June"
 214                                  7  -> pure "July"
 215                                  8  -> pure "August"
 216                                  9  -> pure "September"
 217                                  10 -> pure "October"
 218                                  11 -> pure "November"
 219                                  12 -> pure "December"
 220                                  _  -> []
 221                  , [plainify year]
 222                  ]