]> Git — Sourcephile - doclang.git/blob - Hdoc/DTC/Write/Plain.hs
Rename Language -> Hdoc.
[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
61 = State
62 { state_l10n :: Loqualization (L10n Plain)
63 , state_italic :: Bool
64 , state_quote :: Nat
65 }
66 instance Default State where
67 def = State
68 { state_l10n = Loqualization EN_US
69 , state_italic = False
70 , state_quote = Nat 0
71 }
72
73 -- * Class 'Plainify'
74 class Plainify a where
75 plainify :: a -> Plain
76 instance Plainify String where
77 plainify = return . TLB.fromString
78 instance Plainify Text where
79 plainify = return . TLB.fromText
80 instance Plainify TL.Text where
81 plainify = return . TLB.fromLazyText
82 {-
83 instance Plainify Para where
84 plainify = \case
85 ParaItem{..} -> plainify item
86 ParaItems{..} -> plainify items
87 -}
88 instance Plainify DTC.Plain where
89 plainify = foldMap plainify
90 instance Plainify (Tree PlainNode) where
91 plainify (Tree n ls) =
92 case n of
93 PlainBreak -> "\n"
94 PlainText txt -> plainify txt
95 PlainGroup -> plainify ls
96 PlainB -> "*"<>plainify ls<>"*"
97 PlainCode -> "`"<>plainify ls<>"`"
98 PlainDel -> "-"<>plainify ls<>"-"
99 PlainI -> "/"<>plainify ls<>"/"
100 PlainNote{..} -> "" -- TODO: to be coded, with a switch on/off in State
101 PlainQ -> do
102 State{state_l10n=Loqualization loc} <- S.get
103 l10n_Quote (plainify ls) loc
104 PlainSC -> plainify ls
105 PlainSpan{..} -> 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 class L10n msg lang where
138 l10n_Colon :: FullLocale lang -> msg
139 l10n_Table_of_Contents :: FullLocale lang -> msg
140 l10n_Quote :: msg -> FullLocale lang -> msg
141 l10n_Date :: Date -> FullLocale lang -> msg
142
143 instance L10n TL.Text FR where
144 l10n_Colon _loc = " : "
145 l10n_Table_of_Contents _loc = "Sommaire"
146 l10n_Quote msg _loc = "« "<>msg<>" »"
147 l10n_Date Date{..} _loc =
148 TL.pack $
149 mconcat $
150 List.intersperse " " $
151 concat
152 [ maybe [] (pure . show) day
153 , case month of
154 Nothing -> []
155 Just (Nat1 m) ->
156 case m of
157 1 -> pure "janvier"
158 2 -> pure "février"
159 3 -> pure "mars"
160 4 -> pure "avril"
161 5 -> pure "mai"
162 6 -> pure "juin"
163 7 -> pure "juillet"
164 8 -> pure "août"
165 9 -> pure "septembre"
166 10 -> pure "octobre"
167 11 -> pure "novembre"
168 12 -> pure "décembre"
169 _ -> []
170 , [show year]
171 ]
172 instance L10n TL.Text EN where
173 l10n_Colon _loc = ": "
174 l10n_Table_of_Contents _loc = "Table of Contents"
175 l10n_Quote msg _loc = "“"<>msg<>"”"
176 l10n_Date Date{..} _loc =
177 TL.pack $
178 mconcat $
179 List.intersperse " " $
180 concat
181 [ maybe [] (pure . show) day
182 , case month of
183 Nothing -> []
184 Just (Nat1 m) ->
185 case m of
186 1 -> pure "January"
187 2 -> pure "February"
188 3 -> pure "March"
189 4 -> pure "April"
190 5 -> pure "May"
191 6 -> pure "June"
192 7 -> pure "July"
193 8 -> pure "August"
194 9 -> pure "September"
195 10 -> pure "October"
196 11 -> pure "November"
197 12 -> pure "December"
198 _ -> []
199 , [show year]
200 ]
201
202 instance L10n Plain FR where
203 l10n_Colon loc = plainify (l10n_Colon loc::TL.Text)
204 l10n_Table_of_Contents loc = plainify (l10n_Table_of_Contents loc::TL.Text)
205 l10n_Quote msg _loc = do
206 depth <- S.gets state_quote
207 let (o,c) =
208 case unNat depth `mod` 3 of
209 0 -> ("« "," »")
210 1 -> ("“","”")
211 _ -> ("‟","„")
212 S.modify' $ \s -> s{state_quote=succNat depth}
213 m <- msg
214 S.modify' $ \s -> s{state_quote=depth}
215 return $ o <> m <> c
216 l10n_Date date loc = plainify (l10n_Date date loc::TL.Text)
217 instance L10n Plain EN where
218 l10n_Colon loc = plainify (l10n_Colon loc::TL.Text)
219 l10n_Table_of_Contents loc = plainify (l10n_Table_of_Contents loc::TL.Text)
220 l10n_Quote msg _loc = do
221 depth <- S.gets state_quote
222 let (o,c) =
223 case unNat depth `mod` 3 of
224 0 -> ("“","”")
225 1 -> ("« "," »")
226 _ -> ("‟","„")
227 S.modify' $ \s -> s{state_quote=succNat depth}
228 m <- msg
229 S.modify' $ \s -> s{state_quote=depth}
230 return $ o <> m <> c
231 l10n_Date date loc = plainify (l10n_Date date loc::TL.Text)
232
233 {-
234 -- ** Type 'L10nPlain'
235 -- | Useful newtype to just use 'plainify', instead of 'state_l10n'.
236 newtype L10nPlain = L10nPlain (forall l. L10n l Plain => FullLocale l -> Plain)
237 instance Plainify L10nPlain where
238 plainify (L10nPlain l10n) = do
239 State{state_l10n} <- S.get
240 l10n state_l10n
241 -}