]> Git — Sourcephile - doclang.git/blob - Language/DTC/Write/Plain.hs
Add style/dtc-html5.css
[doclang.git] / Language / DTC / Write / Plain.hs
1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# OPTIONS_GHC -fno-warn-orphans #-}
8 module Language.DTC.Write.Plain where
9
10 import Control.Applicative (Applicative(..), liftA2)
11 import Control.Category
12 import Control.Monad
13 import Data.Bool
14 import Data.Default.Class (Default(..))
15 import Data.Eq (Eq(..))
16 import Data.Foldable (Foldable(..), concat)
17 import Data.Function (($))
18 import Data.Int (Int)
19 import Data.Maybe (Maybe(..), maybe)
20 import Data.Monoid (Monoid(..))
21 import Data.Semigroup (Semigroup(..))
22 import Data.Text (Text)
23 import Data.TreeSeq.Strict (Tree(..))
24 import Data.Tuple (fst, snd)
25 import Data.String (String, IsString(..))
26 import Prelude (mod)
27 import Text.Show (Show(..))
28 import qualified Control.Monad.Trans.State as S
29 import qualified Data.List as List
30 import qualified Data.Text.Lazy as TL
31 import qualified Data.Text.Lazy.Builder as TLB
32
33 import Data.Locale hiding (Index)
34
35 import Language.DTC.Write.XML ()
36 import Language.DTC.Document as DTC hiding (Plain)
37 import qualified Language.DTC.Document as DTC
38
39 -- * Type 'Plain'
40 type Plain = S.State State TLB.Builder
41
42 runPlain :: Plain -> State -> (TL.Text, State)
43 runPlain p s =
44 let (b,s') = S.runState p s in
45 (TLB.toLazyText b, s')
46
47 text :: Plainify a => State -> a -> TL.Text
48 text st a = fst $ runPlain (plainify a) st
49
50 instance IsString Plain where
51 fromString = return . fromString
52 instance Semigroup Plain where
53 (<>) = liftA2 (<>)
54 instance Monoid Plain where
55 mempty = return ""
56 mappend = (<>)
57
58 -- ** Type 'State'
59 data State
60 = State
61 { state_localize :: L10n -> Plain
62 , state_italic :: Bool
63 , state_quote :: Nat
64 }
65 instance Default State where
66 def = State
67 { state_localize = plainify . show
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 PlainBR -> "\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 ->
101 let depth = Nat 0 in
102 plainify L10n_QuoteOpen{..} <>
103 plainify ls <>
104 plainify L10n_QuoteClose{..}
105 PlainSC -> 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 data L10n
138 = L10n_Table_of_Contents
139 | L10n_Colon
140 | L10n_QuoteOpen {depth :: Nat}
141 | L10n_QuoteClose {depth :: Nat}
142 | L10n_Date Date
143 deriving (Show)
144 instance Plainify L10n where
145 plainify msg = do
146 loc <- S.gets state_localize
147 loc msg
148 instance LocalizeIn FR Plain L10n where
149 localizeIn _ = \case
150 L10n_Table_of_Contents -> "Sommaire"
151 L10n_Colon -> " : "
152 L10n_QuoteOpen{..} ->
153 case unNat depth `mod` 3 of
154 0 -> "« "
155 1 -> "“"
156 _ -> "‟"
157 L10n_QuoteClose{..} ->
158 case unNat depth `mod` 3 of
159 0 -> " »"
160 1 -> "”"
161 _ -> "„"
162 L10n_Date Date{..} ->
163 mconcat $
164 List.intersperse " " $
165 concat
166 [ maybe [] (pure . plainify) day
167 , case month of
168 Nothing -> []
169 Just (Nat1 m) ->
170 case m of
171 1 -> pure "janvier"
172 2 -> pure "février"
173 3 -> pure "mars"
174 4 -> pure "avril"
175 5 -> pure "mai"
176 6 -> pure "juin"
177 7 -> pure "juillet"
178 8 -> pure "août"
179 9 -> pure "septembre"
180 10 -> pure "octobre"
181 11 -> pure "novembre"
182 12 -> pure "décembre"
183 _ -> []
184 , [plainify year]
185 ]
186 instance LocalizeIn EN Plain L10n where
187 localizeIn _ = \case
188 L10n_Table_of_Contents -> "Summary"
189 L10n_Colon -> ": "
190 L10n_QuoteOpen{..} ->
191 case unNat depth `mod` 3 of
192 0 -> "“"
193 1 -> "« "
194 _ -> "‟"
195 L10n_QuoteClose{..} ->
196 case unNat depth `mod` 3 of
197 0 -> "”"
198 1 -> " »"
199 _ -> "„"
200 L10n_Date Date{..} ->
201 mconcat $
202 List.intersperse " " $
203 concat
204 [ maybe [] (pure . plainify) day
205 , case month of
206 Nothing -> []
207 Just (Nat1 m) ->
208 case m of
209 1 -> pure "January"
210 2 -> pure "February"
211 3 -> pure "March"
212 4 -> pure "April"
213 5 -> pure "May"
214 6 -> pure "June"
215 7 -> pure "July"
216 8 -> pure "August"
217 9 -> pure "September"
218 10 -> pure "October"
219 11 -> pure "November"
220 12 -> pure "December"
221 _ -> []
222 , [plainify year]
223 ]