{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.DTC.Write.Plain where import Control.Applicative (Applicative(..), liftA2) import Control.Category import Control.Monad import Data.Bool import Data.Default.Class (Default(..)) import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..), concat) import Data.Function (($)) import Data.Int (Int) import Data.Maybe (Maybe(..), maybe) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.Text (Text) import Data.TreeSeq.Strict (Tree(..)) import Data.Tuple (fst, snd) import Data.String (String, IsString(..)) import Prelude (mod) import Text.Show (Show(..)) import qualified Control.Monad.Trans.State as S import qualified Data.List as List import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import Data.Locale hiding (Index) import Language.DTC.Write.XML () import Language.DTC.Document as DTC hiding (Plain) import qualified Language.DTC.Document as DTC -- * Type 'Plain' type Plain = S.State State TLB.Builder runPlain :: Plain -> State -> (TL.Text, State) runPlain p s = let (b,s') = S.runState p s in (TLB.toLazyText b, s') text :: Plainify a => State -> a -> TL.Text text st a = fst $ runPlain (plainify a) st instance IsString Plain where fromString = return . fromString instance Semigroup Plain where (<>) = liftA2 (<>) instance Monoid Plain where mempty = return "" mappend = (<>) -- ** Type 'State' data State = State { state_l10n :: Loqualization (L10n Plain) , state_italic :: Bool , state_quote :: Nat } instance Default State where def = State { state_l10n = Loqualization EN_US , state_italic = False , state_quote = Nat 0 } -- * Class 'Plainify' class Plainify a where plainify :: a -> Plain instance Plainify String where plainify = return . TLB.fromString instance Plainify Text where plainify = return . TLB.fromText instance Plainify TL.Text where plainify = return . TLB.fromLazyText {- instance Plainify Para where plainify = \case ParaItem{..} -> plainify item ParaItems{..} -> plainify items -} instance Plainify DTC.Plain where plainify = foldMap plainify instance Plainify (Tree PlainNode) where plainify (Tree n ls) = case n of PlainBR -> "\n" PlainText txt -> plainify txt PlainGroup -> plainify ls PlainB -> "*"<>plainify ls<>"*" PlainCode -> "`"<>plainify ls<>"`" PlainDel -> "-"<>plainify ls<>"-" PlainI -> "/"<>plainify ls<>"/" PlainNote{..} -> "" -- TODO: to be coded, with a switch on/off in State PlainQ -> do State{state_l10n=Loqualization loc} <- S.get l10n_Quote (plainify ls) loc PlainSC -> plainify ls PlainSub -> plainify ls PlainSup -> plainify ls PlainU -> "_"<>plainify ls<>"_" PlainEref{..} -> plainify ls PlainIref{..} -> plainify ls PlainRef{..} -> plainify ls PlainRref{..} -> plainify ls instance Plainify Title where plainify (Title t) = plainify t instance Plainify PosPath where plainify = plainify . snd . foldl' (\(nParent,acc) (n,c) -> (n, (if TL.null acc then acc else acc <> ".") <> (if n == nParent then TL.pack (show c) else TL.pack (show n)<>TL.pack (show c)) ) ) ("","") instance Plainify XmlName where plainify = plainify . show instance Plainify Int where plainify = plainify . show instance Plainify Nat where plainify (Nat n) = plainify n instance Plainify Nat1 where plainify (Nat1 n) = plainify n -- * Type 'L10n' class L10n msg lang where l10n_Colon :: FullLocale lang -> msg l10n_Table_of_Contents :: FullLocale lang -> msg l10n_Quote :: msg -> FullLocale lang -> msg l10n_Date :: Date -> FullLocale lang -> msg instance L10n TL.Text FR where l10n_Colon _loc = " : " l10n_Table_of_Contents _loc = "Sommaire" l10n_Quote msg _loc = "« "<>msg<>" »" l10n_Date Date{..} _loc = TL.pack $ mconcat $ List.intersperse " " $ concat [ maybe [] (pure . show) day , case month of Nothing -> [] Just (Nat1 m) -> case m of 1 -> pure "janvier" 2 -> pure "février" 3 -> pure "mars" 4 -> pure "avril" 5 -> pure "mai" 6 -> pure "juin" 7 -> pure "juillet" 8 -> pure "août" 9 -> pure "septembre" 10 -> pure "octobre" 11 -> pure "novembre" 12 -> pure "décembre" _ -> [] , [show year] ] instance L10n TL.Text EN where l10n_Colon _loc = ": " l10n_Table_of_Contents _loc = "Table of Contents" l10n_Quote msg _loc = "“"<>msg<>"”" l10n_Date Date{..} _loc = TL.pack $ mconcat $ List.intersperse " " $ concat [ maybe [] (pure . show) day , case month of Nothing -> [] Just (Nat1 m) -> case m of 1 -> pure "January" 2 -> pure "February" 3 -> pure "March" 4 -> pure "April" 5 -> pure "May" 6 -> pure "June" 7 -> pure "July" 8 -> pure "August" 9 -> pure "September" 10 -> pure "October" 11 -> pure "November" 12 -> pure "December" _ -> [] , [show year] ] instance L10n Plain FR where l10n_Colon loc = plainify (l10n_Colon loc::TL.Text) l10n_Table_of_Contents loc = plainify (l10n_Table_of_Contents loc::TL.Text) l10n_Quote msg _loc = do depth <- S.gets state_quote let (o,c) = case unNat depth `mod` 3 of 0 -> ("« "," »") 1 -> ("“","”") _ -> ("‟","„") S.modify' $ \s -> s{state_quote=succNat depth} m <- msg S.modify' $ \s -> s{state_quote=depth} return $ o <> m <> c l10n_Date date loc = plainify (l10n_Date date loc::TL.Text) instance L10n Plain EN where l10n_Colon loc = plainify (l10n_Colon loc::TL.Text) l10n_Table_of_Contents loc = plainify (l10n_Table_of_Contents loc::TL.Text) l10n_Quote msg _loc = do depth <- S.gets state_quote let (o,c) = case unNat depth `mod` 3 of 0 -> ("“","”") 1 -> ("« "," »") _ -> ("‟","„") S.modify' $ \s -> s{state_quote=succNat depth} m <- msg S.modify' $ \s -> s{state_quote=depth} return $ o <> m <> c l10n_Date date loc = plainify (l10n_Date date loc::TL.Text) {- -- ** Type 'L10nPlain' -- | Useful newtype to just use 'plainify', instead of 'state_l10n'. newtype L10nPlain = L10nPlain (forall l. L10n l Plain => FullLocale l -> Plain) instance Plainify L10nPlain where plainify (L10nPlain l10n) = do State{state_l10n} <- S.get l10n state_l10n -}