]> Git — Sourcephile - doclang.git/blob - Language/TCT/Write/DTC.hs
Revert "Use Text.Lazy to speedup Token parsing."
[doclang.git] / Language / TCT / Write / DTC.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE RecordWildCards #-}
3 {-# LANGUAGE ViewPatterns #-}
4 {-# OPTIONS_GHC -fno-warn-orphans #-}
5 -- | Render a TCT file in DTC.
6 module Language.TCT.Write.DTC where
7
8 import Control.Monad (Monad(..), forM_, when)
9 import Data.Bool
10 import Data.Foldable (foldr, null, foldMap, foldl', any)
11 import Data.Function (($), (.), flip)
12 import Data.Functor ((<$>))
13 import Data.Map.Strict (Map)
14 import Data.Maybe (Maybe(..))
15 import Data.Monoid (Monoid(..))
16 import Data.Semigroup (Semigroup(..))
17 import Data.Sequence (ViewL(..), (<|), (|>))
18 import Data.String (String)
19 import Data.Text (Text)
20 import GHC.Exts (toList)
21 import Text.Blaze ((!))
22 import Text.Show (Show(..))
23 import qualified Data.Char as Char
24 import qualified Data.Map.Strict as Map
25 import qualified Data.Sequence as Seq
26 import qualified Data.Text as Text
27 import qualified Data.Text.Lazy as TL
28 import qualified Text.Blaze as B
29 import qualified Text.Blaze.Internal as B
30
31 import Language.TCT.Tree
32 import Language.TCT.Token
33 import Language.TCT.Elem hiding (trac,dbg)
34 import qualified Language.TCT.Write.Text as Write
35 import Text.Blaze.Utils
36 import Text.Blaze.DTC (DTC)
37 import qualified Text.Blaze.DTC as D
38 import qualified Text.Blaze.DTC.Attributes as DA
39
40 import Debug.Trace (trace)
41 trac :: String -> a -> a
42 -- trac _m x = x
43 trac m x = trace m x
44 dbg :: Show a => String -> a -> a
45 dbg m x = trac (m <> ": " <> show x) x
46
47 dtc :: Trees (Cell Key) (Cell Tokens) -> DTC
48 dtc ts = do
49 let lang = "fr"
50 D.xmlModel "./schema/dtc.rnc"
51 D.xmlStylesheet $ "./xsl/document.html5."<>lang<>".xsl"
52 D.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl"
53 D.atomStylesheet $ "./xsl/document.atom."<>lang<>".xsl"
54 D.document $
55 case Seq.viewl ts of
56 TreeN (unCell -> KeySection{})
57 (Seq.viewl -> Tree0 (unCell -> Write.t_Tokens -> TL.toStrict -> title) :< head)
58 :< body -> do
59 d_Trees [] (mangleHead title head)
60 d_Trees [] body
61 _ ->
62 d_Trees [] ts
63 where
64 mangleHead ::
65 Text ->
66 Trees (Cell Key) (Cell Tokens) ->
67 Trees (Cell Key) (Cell Tokens)
68 mangleHead title head =
69 let mi =
70 (`Seq.findIndexL` head) $ \case
71 TreeN (unCell -> KeyColon "about" _) _ -> True
72 _ -> False in
73 case mi of
74 Nothing ->
75 TreeN (cell0 (KeyColon "about" ""))
76 (Seq.fromList names)
77 <| head
78 Just i -> Seq.adjust f i head
79 where
80 f (TreeN c about) = TreeN c $ Seq.fromList names <> about
81 f t = t
82 where
83 names = name <$> Text.splitOn "\n" title
84 name =
85 TreeN (cell0 (KeyColon "name" "")) .
86 Seq.singleton .
87 Tree0 . cell0 .
88 Tokens . Seq.singleton . TokenPlain
89
90 d_Trees :: [Key] -> Trees (Cell Key) (Cell Tokens) -> DTC
91 d_Trees path ts =
92 case () of
93 _ | (ul,ts') <- gatherUL ts, not (null ul) -> do
94 D.ul $ forM_ ul $ d_Tree path
95 d_Trees path ts'
96 _ | (ol,ts') <- gatherOL ts, not (null ol) -> do
97 D.ol $ forM_ ol $ d_Tree path
98 d_Trees path ts'
99 _ | t:<ts' <- Seq.viewl ts -> do
100 d_Tree path t
101 d_Trees path ts'
102 _ ->
103 return ()
104
105 gatherUL ::
106 Trees (Cell Key) (Cell Tokens) ->
107 ( Trees (Cell Key) (Cell Tokens)
108 , Trees (Cell Key) (Cell Tokens) )
109 gatherUL ts =
110 let (lis, ts') = spanLIs ts in
111 foldl' accumLIs (mempty,ts') lis
112 where
113 spanLIs = Seq.spanl $ \case
114 TreeN (unCell -> KeyDash) _ -> True
115 Tree0 (unCell -> Tokens toks) ->
116 (`any` toks) $ \case
117 TokenPair (PairElem "li" _) _ -> True
118 _ -> False
119 _ -> False
120 accumLIs acc@(oks,kos) t =
121 case t of
122 TreeN (unCell -> KeyDash) _ -> (oks|>t,kos)
123 Tree0 (Cell pos posEnd (Tokens toks)) ->
124 let mk = Tree0 . Cell pos posEnd . Tokens in
125 let (ok,ko) =
126 (`Seq.spanl` toks) $ \case
127 TokenPair (PairElem "li" _) _ -> True
128 TokenPlain txt -> Char.isSpace`Text.all`txt
129 _ -> False in
130 ( if null ok then oks else oks|>mk (rmTokenPlain ok)
131 , if null ko then kos else mk ko<|kos )
132 _ -> acc
133 rmTokenPlain =
134 Seq.filter $ \case
135 TokenPlain{} -> False
136 _ -> True
137
138 gatherOL ::
139 Trees (Cell Key) (Cell Tokens) ->
140 ( Trees (Cell Key) (Cell Tokens)
141 , Trees (Cell Key) (Cell Tokens) )
142 gatherOL ts =
143 let (lis, ts') = spanLIs ts in
144 foldl' accumLIs (mempty,ts') lis
145 where
146 spanLIs = Seq.spanl $ \case
147 TreeN (unCell -> KeyDot{}) _ -> True
148 Tree0 (unCell -> Tokens toks) ->
149 (`any` toks) $ \case
150 TokenPair (PairElem "li" _) _ -> True
151 _ -> False
152 _ -> False
153 accumLIs acc@(oks,kos) t =
154 case t of
155 TreeN (unCell -> KeyDot{}) _ -> (oks|>t,kos)
156 Tree0 (Cell pos posEnd (Tokens toks)) ->
157 let mk = Tree0 . Cell pos posEnd . Tokens in
158 let (ok,ko) =
159 (`Seq.spanl` toks) $ \case
160 TokenPair (PairElem "li" _) _ -> True
161 TokenPlain txt -> Char.isSpace`Text.all`txt
162 _ -> False in
163 ( if null ok then oks else oks|>mk (rmTokenPlain ok)
164 , if null ko then kos else mk ko<|kos )
165 _ -> acc
166 rmTokenPlain =
167 Seq.filter $ \case
168 TokenPlain{} -> False
169 _ -> True
170
171 d_Tree :: [Key] -> Tree (Cell Key) (Cell Tokens) -> DTC
172 d_Tree path (TreeN (unCell -> key@KeySection{}) ts) =
173 case Seq.viewl children of
174 Tree0 (Cell _posTitle _ (toList -> [TokenPlain title])) :< body ->
175 d_attrs (mangleAttrs title attrs) $
176 case Text.splitOn "\n" title of
177 t0:t1 ->
178 D.section ! DA.name (attrValue t0) $ do
179 let st = Text.intercalate "\n" t1
180 when (not (Text.null st)) $
181 D.name $ B.toMarkup st
182 d_content body
183 [] ->
184 D.section ! DA.name (attrValue title) $
185 d_content body
186 Tree0 (Cell _posTitle _ title) :< body ->
187 d_attrs (mangleAttrs (TL.toStrict $ Write.t_Tokens title) attrs) $
188 D.section $ do
189 D.name $ d_Tokens (key:path) title
190 d_content body
191 _ ->
192 d_attrs attrs $
193 D.section $ d_content children
194 where
195 (attrs,children) = partitionAttributesChildren ts
196 d_content cs = d_Trees (key:path) cs
197 mangleAttrs :: Text -> Attributes -> Attributes
198 mangleAttrs title = Map.insertWith (\_new old -> old) "id" title
199 d_Tree path (Tree0 cell) = d_CellTokens path cell
200 d_Tree path (TreeN cell@(unCell -> KeyColon{}) ts) =
201 let (attrs,children) = partitionAttributesChildren ts in
202 d_attrs attrs $ d_CellKey path cell children
203 d_Tree path (TreeN cell ts) = d_CellKey path cell ts
204
205 d_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Tokens) -> DTC
206 d_CellKey path (Cell _pos _posEnd key) cells = do
207 case key of
208 KeyColon n _wh -> d_Key n
209 KeyGreat n _wh -> d_Key n
210 KeyEqual n _wh -> d_Key n
211 KeyBar n _wh -> d_Key n
212 KeyDot _n -> D.li $ d_Trees (key:path) cells
213 KeyDash -> D.li $ d_Trees (key:path) cells
214 {-
215 KeyLower name attrs -> do
216 B.Content $ "<"<>B.toMarkup name
217 d_Attrs attrs
218 forM_ cells $ d_Tree path
219 -}
220 where
221 d_Key :: Text -> DTC
222 d_Key name | null cells =
223 B.CustomLeaf (B.Text name) True mempty
224 d_Key name =
225 B.CustomParent (B.Text name) $
226 d_Trees (key:path) cells
227
228 d_CellTokens :: [Key] -> Cell Tokens -> DTC
229 d_CellTokens path (Cell _pos _posEnd ts) =
230 -- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellTokens: path:" path of
231 case dbg "d_CellTokens: path" path of
232 [] ->
233 case ts of
234 (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts
235 _ -> D.para $ d_Tokens path ts
236 KeySection{}:_ ->
237 case ts of
238 (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts
239 _ -> D.para $ d_Tokens path ts
240 _ -> d_Tokens path ts
241
242 d_Tokens :: [Key] -> Tokens -> DTC
243 d_Tokens _path tok = goTokens tok
244 where
245 -- indent = Text.replicate (columnPos pos - 1) " "
246 go :: Token -> DTC
247 go (TokenPlain t) = B.toMarkup t
248 go (TokenTag t) = D.ref mempty ! DA.to (attrValue t)
249 go (TokenEscape c) = B.toMarkup c
250 go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk)
251 go (TokenPair PairSlash ts) = D.i $ goTokens ts
252 go (TokenPair PairBackquote ts) = D.code $ goTokens ts
253 go (TokenPair PairFrenchquote ts) = D.q $ goTokens ts
254 go (TokenPair PairHash (toList -> [TokenPlain ts])) =
255 D.ref mempty ! DA.to (attrValue ts)
256 go (TokenPair (PairElem name attrs) ts) =
257 d_Attrs attrs $
258 case ts of
259 Tokens s | Seq.null s ->
260 B.CustomLeaf (B.Text name) True mempty
261 _ -> B.CustomParent (B.Text name) $ goTokens ts
262 go (TokenPair p ts) = do
263 let (o,c) = pairBorders p ts
264 B.toMarkup o
265 goTokens ts
266 B.toMarkup c
267 goTokens :: Tokens -> DTC
268 goTokens (Tokens ts) = foldMap go ts
269
270 d_Attrs :: Attrs -> DTC -> DTC
271 d_Attrs = flip $ foldl' d_Attr
272
273 d_Attr :: DTC -> (Text,Attr) -> DTC
274 d_Attr acc (_,Attr{..}) =
275 B.AddCustomAttribute
276 (B.Text attr_name)
277 (B.Text attr_value)
278 acc
279
280 -- attr_id :: Text -> [(Text,Text)] -> [(Text,Text)]
281 -- attr_id title = ("id",title)
282
283 -- * Type 'Attributes'
284 type Attributes = Map Name Text
285
286 d_attrs :: Attributes -> DTC -> DTC
287 d_attrs = flip $ Map.foldrWithKey $ \n v ->
288 B.AddCustomAttribute (B.Text n) (B.Text v)
289
290 partitionAttributesChildren ::
291 Trees (Cell Key) (Cell Tokens) ->
292 (Attributes, Trees (Cell Key) (Cell Tokens))
293 partitionAttributesChildren ts = (attrs,children)
294 where
295 attrs :: Attributes
296 attrs =
297 foldr (\t acc ->
298 case t of
299 Tree0{} -> acc
300 TreeN (unCell -> KeyEqual n _wh) a -> Map.insert n v acc
301 where
302 v = TL.toStrict $
303 Write.text Write.config_text{Write.config_text_escape = False} $
304 Write.treeRackUpLeft <$> a
305 TreeN{} -> acc
306 ) mempty ts
307 children = Seq.filter (\t ->
308 case t of
309 Tree0{} -> True
310 TreeN (unCell -> KeyEqual{}) _cs -> False
311 TreeN{} -> True
312 ) ts