]> Git — Sourcephile - doclang.git/blob - Hdoc/DTC/Write/Plain.hs
Add Majority Judgment support.
[doclang.git] / 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.Bool
15 import Data.Default.Class (Default(..))
16 import Data.Eq (Eq(..))
17 import Data.Foldable (Foldable(..), concat)
18 import Data.Function (($))
19 import Data.Int (Int)
20 import Data.Maybe (Maybe(..), maybe)
21 import Data.Monoid (Monoid(..))
22 import Data.Semigroup (Semigroup(..))
23 import Data.Text (Text)
24 import Data.TreeSeq.Strict (Tree(..))
25 import Data.Tuple (fst, snd)
26 import Data.String (String, IsString(..))
27 import Prelude (mod)
28 import Text.Show (Show(..))
29 import qualified Control.Monad.Trans.State as S
30 import qualified Data.List as List
31 import qualified Data.Text.Lazy as TL
32 import qualified Data.Text.Lazy.Builder as TLB
33
34 import Data.Locale hiding (Index)
35
36 import Hdoc.DTC.Write.XML ()
37 import Hdoc.DTC.Document as DTC hiding (Plain)
38 import qualified Hdoc.DTC.Document as DTC
39
40 -- * Type 'Plain'
41 type Plain = S.State State TLB.Builder
42
43 runPlain :: Plain -> State -> (TL.Text, State)
44 runPlain p s =
45 let (b,s') = S.runState p s in
46 (TLB.toLazyText b, s')
47
48 text :: Plainify a => State -> a -> TL.Text
49 text st a = fst $ runPlain (plainify a) st
50
51 instance IsString Plain where
52 fromString = return . fromString
53 instance Semigroup Plain where
54 (<>) = liftA2 (<>)
55 instance Monoid Plain where
56 mempty = return ""
57 mappend = (<>)
58
59 -- ** Type 'State'
60 data State = State -- TODO: could be a Reader
61 { state_l10n :: Loqualization (L10n Plain)
62 , state_italic :: Bool
63 , state_quote :: Nat
64 }
65 instance Default State where
66 def = State
67 { state_l10n = Loqualization EN_US
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 PlainBreak -> "\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 -> do
101 State{state_l10n=Loqualization loc} <- S.get
102 l10n_Quote (plainify ls) loc
103 PlainSC -> plainify ls
104 PlainSpan{..} -> plainify ls
105 PlainSub -> plainify ls
106 PlainSup -> plainify ls
107 PlainU -> "_"<>plainify ls<>"_"
108 PlainEref{..} -> plainify ls
109 PlainIref{..} -> plainify ls
110 PlainRef{..} -> plainify ls
111 PlainRref{..} -> plainify ls
112 instance Plainify Title where
113 plainify (Title t) = plainify t
114 instance Plainify 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 XmlName where
127 plainify = plainify . show
128 instance Plainify Int where
129 plainify = plainify . show
130 instance Plainify Nat where
131 plainify (Nat n) = plainify n
132 instance Plainify Nat1 where
133 plainify (Nat1 n) = plainify n
134
135 -- * Type 'L10n'
136 class L10n msg lang where
137 l10n_Colon :: FullLocale lang -> msg
138 l10n_Table_of_Contents :: FullLocale lang -> msg
139 l10n_Quote :: msg -> FullLocale lang -> msg
140 l10n_Date :: Date -> FullLocale lang -> msg
141
142 instance L10n TL.Text FR where
143 l10n_Colon _loc = " : "
144 l10n_Table_of_Contents _loc = "Sommaire"
145 l10n_Quote msg _loc = "« "<>msg<>" »"
146 l10n_Date Date{..} _loc =
147 TL.pack $
148 mconcat $
149 List.intersperse " " $
150 concat
151 [ maybe [] (pure . show) day
152 , case month of
153 Nothing -> []
154 Just (Nat1 m) ->
155 case m of
156 1 -> pure "janvier"
157 2 -> pure "février"
158 3 -> pure "mars"
159 4 -> pure "avril"
160 5 -> pure "mai"
161 6 -> pure "juin"
162 7 -> pure "juillet"
163 8 -> pure "août"
164 9 -> pure "septembre"
165 10 -> pure "octobre"
166 11 -> pure "novembre"
167 12 -> pure "décembre"
168 _ -> []
169 , [show year]
170 ]
171 instance L10n TL.Text EN where
172 l10n_Colon _loc = ": "
173 l10n_Table_of_Contents _loc = "Table of Contents"
174 l10n_Quote msg _loc = "“"<>msg<>"”"
175 l10n_Date Date{..} _loc =
176 TL.pack $
177 mconcat $
178 List.intersperse " " $
179 concat
180 [ maybe [] (pure . show) day
181 , case month of
182 Nothing -> []
183 Just (Nat1 m) ->
184 case m of
185 1 -> pure "January"
186 2 -> pure "February"
187 3 -> pure "March"
188 4 -> pure "April"
189 5 -> pure "May"
190 6 -> pure "June"
191 7 -> pure "July"
192 8 -> pure "August"
193 9 -> pure "September"
194 10 -> pure "October"
195 11 -> pure "November"
196 12 -> pure "December"
197 _ -> []
198 , [show year]
199 ]
200
201 instance L10n Plain FR where
202 l10n_Colon loc = plainify (l10n_Colon loc::TL.Text)
203 l10n_Table_of_Contents loc = plainify (l10n_Table_of_Contents loc::TL.Text)
204 l10n_Quote msg _loc = do
205 depth <- S.gets state_quote
206 let (o,c) =
207 case unNat depth `mod` 3 of
208 0 -> ("« "," »")
209 1 -> ("“","”")
210 _ -> ("‟","„")
211 S.modify' $ \s -> s{state_quote=succNat depth}
212 m <- msg
213 S.modify' $ \s -> s{state_quote=depth}
214 return $ o <> m <> c
215 l10n_Date date loc = plainify (l10n_Date date loc::TL.Text)
216 instance L10n Plain EN where
217 l10n_Colon loc = plainify (l10n_Colon loc::TL.Text)
218 l10n_Table_of_Contents loc = plainify (l10n_Table_of_Contents loc::TL.Text)
219 l10n_Quote msg _loc = do
220 depth <- S.gets state_quote
221 let (o,c) =
222 case unNat depth `mod` 3 of
223 0 -> ("“","”")
224 1 -> ("« "," »")
225 _ -> ("‟","„")
226 S.modify' $ \s -> s{state_quote=succNat depth}
227 m <- msg
228 S.modify' $ \s -> s{state_quote=depth}
229 return $ o <> m <> c
230 l10n_Date date loc = plainify (l10n_Date date loc::TL.Text)
231
232 {-
233 -- ** Type 'L10nPlain'
234 -- | Useful newtype to just use 'plainify', instead of 'state_l10n'.
235 newtype L10nPlain = L10nPlain (forall l. L10n l Plain => FullLocale l -> Plain)
236 instance Plainify L10nPlain where
237 plainify (L10nPlain l10n) = do
238 State{state_l10n} <- S.get
239 l10n state_l10n
240 -}