]> Git — Sourcephile - doclang.git/blob - Language/DTC/Write/Plain.hs
Add Plainify.
[doclang.git] / Language / DTC / Write / Plain.hs
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE DuplicateRecordFields #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE FlexibleContexts #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE OverloadedStrings #-}
7 {-# LANGUAGE ScopedTypeVariables #-}
8 {-# LANGUAGE TypeApplications #-}
9 {-# OPTIONS_GHC -fno-warn-orphans #-}
10 module Language.DTC.Write.Plain where
11
12 import Control.Applicative (Applicative(..), liftA2)
13 import Control.Category
14 import Control.Monad
15 import Data.Bool
16 import Data.Default.Class (Default(..))
17 import Data.Eq (Eq(..))
18 import Data.Foldable (Foldable(..), concat)
19 import Data.Function (($))
20 import Data.Int (Int)
21 import Data.Maybe (Maybe(..), maybe)
22 import Data.Monoid (Monoid(..))
23 import Data.Semigroup (Semigroup(..))
24 import Data.String (String)
25 import Data.Text (Text)
26 import Data.TreeSeq.Strict (Tree(..))
27 import Data.Tuple (fst, snd)
28 import Data.String (IsString(..))
29 import Prelude (mod)
30 import Text.Show (Show(..))
31 import qualified Control.Monad.Trans.State as S
32 import qualified Data.List as List
33 import qualified Data.Text.Lazy as TL
34 import qualified Data.Text.Lazy.Builder as TLB
35
36 import Data.Locale hiding (localize, Index)
37
38 import Language.DTC.Write.XML ()
39 import qualified Language.DTC.Document as DTC
40
41 -- * Type 'Plain'
42 type Plain = S.State State TLB.Builder
43
44 runPlain :: Plain -> State -> (TL.Text, State)
45 runPlain p s =
46 let (b,s') = S.runState p s in
47 (TLB.toLazyText b, s')
48
49 text :: Plainify a => State -> a -> TL.Text
50 text st a = fst $ runPlain (plainify a) st
51
52 instance IsString Plain where
53 fromString = return . fromString
54 instance Semigroup Plain where
55 (<>) = liftA2 (<>)
56 instance Monoid Plain where
57 mempty = return ""
58 mappend = (<>)
59
60 -- ** Type 'State'
61 data State
62 = State
63 { state_localize :: L10n -> Plain
64 , state_italic :: Bool
65 , state_quote :: DTC.Nat
66 }
67 instance Default State where
68 def = State
69 { state_localize = plainify . show
70 , state_italic = False
71 , state_quote = DTC.Nat 0
72 }
73
74
75 -- * Class 'Plainify'
76 class Plainify a where
77 plainify :: a -> Plain
78 instance Plainify String where
79 plainify = return . TLB.fromString
80 instance Plainify Text where
81 plainify = return . TLB.fromText
82 instance Plainify TL.Text where
83 plainify = return . TLB.fromLazyText
84 instance Plainify DTC.Para where
85 plainify = foldMap plainify
86 instance Plainify DTC.Lines where
87 plainify = \case
88 Tree0 v ->
89 case v of
90 DTC.BR -> "\n"
91 DTC.Plain p -> plainify p
92 TreeN k ls ->
93 case k of
94 DTC.B -> "*"<>plainify ls<>"*"
95 DTC.Code -> "`"<>plainify ls<>"`"
96 DTC.Del -> "-"<>plainify ls<>"-"
97 DTC.I -> "/"<>plainify ls<>"/"
98 DTC.Note -> ""
99 DTC.Q ->
100 let depth = DTC.Nat 0 in
101 plainify (L10n_QuoteOpen{..}) <>
102 plainify ls <>
103 plainify (L10n_QuoteClose{..})
104 DTC.SC -> plainify ls
105 DTC.Sub -> plainify ls
106 DTC.Sup -> plainify ls
107 DTC.U -> "_"<>plainify ls<>"_"
108 DTC.Eref{..} -> plainify ls
109 DTC.Iref{..} -> plainify ls
110 DTC.Ref{..} -> plainify ls
111 DTC.Rref{..} -> plainify ls
112 instance Plainify DTC.Title where
113 plainify (DTC.Title t) = plainify t
114 instance Plainify DTC.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 DTC.XmlName where
127 plainify = plainify . show
128 instance Plainify Int where
129 plainify = plainify . show
130 instance Plainify DTC.Nat where
131 plainify (DTC.Nat n) = plainify n
132 instance Plainify DTC.Nat1 where
133 plainify (DTC.Nat1 n) = plainify n
134
135 -- * Type 'L10n'
136 data L10n
137 = L10n_Table_of_Contents
138 | L10n_Colon
139 | L10n_QuoteOpen {depth :: DTC.Nat}
140 | L10n_QuoteClose {depth :: DTC.Nat}
141 | L10n_Date DTC.Date
142 deriving (Show)
143 instance Plainify L10n where
144 plainify msg = do
145 loc <- S.gets state_localize
146 loc msg
147 instance LocalizeIn FR Plain L10n where
148 localizeIn _ = \case
149 L10n_Table_of_Contents -> "Sommaire"
150 L10n_Colon -> " :"
151 L10n_QuoteOpen{..} ->
152 case DTC.unNat depth `mod` 3 of
153 0 -> "« "
154 1 -> "“"
155 _ -> "‟"
156 L10n_QuoteClose{..} ->
157 case DTC.unNat depth `mod` 3 of
158 0 -> " »"
159 1 -> "”"
160 _ -> "„"
161 L10n_Date DTC.Date{..} ->
162 mconcat $
163 List.intersperse " " $
164 concat
165 [ maybe [] (pure . plainify) day
166 , case month of
167 Nothing -> []
168 Just (DTC.Nat1 m) ->
169 case m of
170 1 -> pure "janvier"
171 2 -> pure "février"
172 3 -> pure "mars"
173 4 -> pure "avril"
174 5 -> pure "mai"
175 6 -> pure "juin"
176 7 -> pure "juillet"
177 8 -> pure "août"
178 9 -> pure "septembre"
179 10 -> pure "octobre"
180 11 -> pure "novembre"
181 12 -> pure "décembre"
182 _ -> []
183 , [plainify year]
184 ]
185 instance LocalizeIn EN Plain L10n where
186 localizeIn _ = \case
187 L10n_Table_of_Contents -> "Summary"
188 L10n_Colon -> ":"
189 L10n_QuoteOpen{..} ->
190 case DTC.unNat depth `mod` 3 of
191 0 -> "“"
192 1 -> "« "
193 _ -> "‟"
194 L10n_QuoteClose{..} ->
195 case DTC.unNat depth `mod` 3 of
196 0 -> "”"
197 1 -> " »"
198 _ -> "„"
199 L10n_Date DTC.Date{..} ->
200 mconcat $
201 List.intersperse " " $
202 concat
203 [ maybe [] (pure . plainify) day
204 , case month of
205 Nothing -> []
206 Just (DTC.Nat1 m) ->
207 case m of
208 1 -> pure "January"
209 2 -> pure "February"
210 3 -> pure "March"
211 4 -> pure "April"
212 5 -> pure "May"
213 6 -> pure "June"
214 7 -> pure "July"
215 8 -> pure "August"
216 9 -> pure "September"
217 10 -> pure "October"
218 11 -> pure "November"
219 12 -> pure "December"
220 _ -> []
221 , [plainify year]
222 ]