]> Git — Sourcephile - doclang.git/blob - Language/DTC/Write/Plain.hs
Use Loqualization.
[doclang.git] / Language / 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 Language.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 Language.DTC.Write.XML ()
37 import Language.DTC.Document as DTC hiding (Plain)
38 import qualified Language.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 PlainBR -> "\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 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 -}