]> Git — Sourcephile - doclang.git/blob - Language/TCT/Tree.hs
Fix HeaderDotSlash rendering.
[doclang.git] / Language / TCT / Tree.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE PatternSynonyms #-}
3 {-# LANGUAGE ViewPatterns #-}
4 module Language.TCT.Tree
5 ( module Language.TCT.Tree
6 , Tree(..), Trees
7 ) where
8
9 import Control.Monad (Monad(..))
10 import Data.Bool
11 import Data.Char (Char)
12 import Data.Eq (Eq(..))
13 import Data.Foldable (Foldable(..), any)
14 import Data.Function (($))
15 import Data.Functor ((<$>))
16 import Data.Int (Int)
17 import Data.List.NonEmpty (NonEmpty(..))
18 import Data.Monoid (Monoid(..))
19 import Data.Ord (Ordering(..), Ord(..))
20 import Data.Semigroup (Semigroup(..))
21 import Data.Sequence ((|>))
22 import Data.TreeSeq.Strict (Tree(..), Trees)
23 import Prelude (undefined, Num(..))
24 import System.FilePath (FilePath)
25 import Text.Show (Show(..))
26 import qualified Data.List as List
27 import qualified Data.Sequence as Seq
28 import qualified Data.Text.Lazy as TL
29
30 import Language.TCT.Utils
31 import Language.TCT.Cell
32 import Language.TCT.Elem
33 import Language.TCT.Debug
34
35 -- * Type 'Root'
36 -- | A single 'Tree' to rule all the 'Node's
37 -- simplifies greatly the navigation and transformations,
38 -- especially because the later XML or DTC output
39 -- are themselves a single tree-like data structure.
40 --
41 -- Also, having a single 'Tree' is easier to merge
42 -- XML coming from the first parsing phase (eg. @('NodeHeader' ('HeaderEqual' "li" ""))@),
43 -- and XML coming from the second parsing phase (eg. @NodePair (PairElem "li" [])@).
44 --
45 -- For error reporting, each 'Node' is annotated with a 'Cell'
46 -- spanning over all its content (sub-'Trees' included).
47 type Root = Tree (Cell Node)
48 type Roots = Trees (Cell Node)
49
50 pattern Tree0 :: a -> Tree a
51 pattern Tree0 a <- Tree a (null -> True)
52 where Tree0 a = Tree a mempty
53
54 -- * Type 'Node'
55 data Node
56 = NodeHeader !Header -- ^ node, from first parsing (indentation-sensitive)
57 | NodeText !TL.Text -- ^ leaf verbatim text, from first parsing (indentation-sensitive)
58 | NodePair !Pair -- ^ node, from second parsing (on some 'NodeText's)
59 | NodeToken !Token -- ^ leaf, from second parsing (on some 'NodeText's)
60 | NodeLower !Name !ElemAttrs -- ^ node, @<name a=b@
61 | NodePara -- ^ node, gather trees by paragraph,
62 -- useful to know when to generate a <para> XML node
63 deriving (Eq,Show)
64 instance Pretty Node
65
66 -- * Type 'Header'
67 data Header
68 = HeaderColon !Name !White -- ^ @name: @
69 | HeaderEqual !Name !White -- ^ @name=@
70 | HeaderBar !Name !White -- ^ @name|@
71 | HeaderGreat !Name !White -- ^ @name>@
72 | HeaderBrackets !Name -- ^ @[name]@
73 | HeaderDot !Name -- ^ @1. @
74 | HeaderDash -- ^ @- @
75 | HeaderDashDash -- ^ @-- @
76 | HeaderSection !LevelSection -- ^ @# @
77 | HeaderDotSlash !FilePath -- ^ @./file @
78 deriving (Eq, Ord, Show)
79 instance Pretty Header
80
81 -- ** Type 'Name'
82 type Name = TL.Text
83
84 -- ** Type 'LevelSection'
85 type LevelSection = Int
86
87 -- * Type 'Pair'
88 data Pair
89 = PairElem !ElemName !ElemAttrs -- ^ @\<name a0=v0 a1=v1>text\</name>@
90 | PairHash -- ^ @\#text#@
91 | PairStar -- ^ @*text*@
92 | PairSlash -- ^ @/text/@
93 | PairUnderscore -- ^ @_value_@
94 | PairDash -- ^ @-text-@
95 | PairBackquote -- ^ @`text`@
96 | PairSinglequote -- ^ @'text'@
97 | PairDoublequote -- ^ @"text"@
98 | PairFrenchquote -- ^ @«text»@
99 | PairParen -- ^ @(text)@
100 | PairBrace -- ^ @{text}@
101 | PairBracket -- ^ @[text]@
102 deriving (Eq,Ord,Show)
103 instance Pretty Pair
104
105 -- * Type 'Token'
106 data Token
107 = TokenText !TL.Text
108 | TokenEscape !Char
109 | TokenLink !Link
110 | TokenTag !Tag
111 deriving (Eq,Show)
112
113 -- ** Type 'Tag'
114 type Tag = TL.Text
115
116 -- ** Type 'Link'
117 type Link = TL.Text
118
119 -- * Type 'Row'
120 -- | In normal order: a list of 'Header's, maybe ended by 'Value', all read on the same line.
121 type Row = [Root]
122
123 -- ** Type 'Rows'
124 -- | In reverse order: a list of nodes in scope
125 -- (hence to which the next line can append to).
126 type Rows = [Root]
127
128 -- | Having an initial 'Root' simplifies 'mergeRowIndent':
129 -- one can always put the last 'Root' as a child to a previous one.
130 -- This 'Root' just has to be discarded by 'collapseRows'.
131 initRows :: Rows
132 initRows = [Tree0 $ Cell (Span "" p p :| []) $ NodeHeader HeaderDash]
133 where p = Pos{pos_line= -1, pos_column=0}
134 -- NOTE: such that any following 'Root'
135 -- is 'NodePara' if possible, and always a child.
136
137 -- | @mergeRow rows row@ append @row@ into @rows@, while merging what has to be.
138 --
139 -- * [@rows@] is old 'Rows', its |Root|s' 'cell_begin' are descending (non-strictly),
140 -- they MAY span over multilines, and they can be many from a single line.
141 -- * [@row@] is new 'Row', its |Root|s' 'cell_begin' are descending (non-strictly),
142 -- they MUST span only over a single and entire line.
143 --
144 -- This is the main entry point to build 'Rows' by accumulating 'Row' into them.
145 mergeRow :: Rows -> Row -> Rows
146 mergeRow rows row =
147 debug2_ "mergeRow" ("news",List.reverse row) ("olds",rows) $
148 mergeRowPrefix 0 rows $ List.reverse row
149
150 -- | Merge by considering matching prefixes.
151 --
152 -- 'HeaderGreat' and 'HeaderBar' work, not on indentation,
153 -- but on their vertical alignment as prefixes.
154 -- Hence, each new 'Row' has those prefixes zipped into a single one
155 -- when they match, are aligned and adjacent.
156 mergeRowPrefix :: ColNum -> Rows -> Row -> Rows
157 mergeRowPrefix col rows row =
158 debug3_ "mergeRowPrefix" ("col",col) ("news",row) ("olds",rows) $
159 case (row,rows) of
160 ([], _) -> rows
161 (_, []) -> undefined -- NOTE: cannot happen with initRows
162 ( _new@(Tree (Cell (Span _fn bn _en:|_sn) n) _ns):news
163 , _old@(Tree (Cell (Span _fo _bo eo:|_so) _o) _os):_olds ) ->
164 case collapseRowsWhile isCollapsable rows of
165 [] -> mergeRowIndent rows row
166 head@(unTree -> ch@(Cell (Span _fh bh _eh:|_sh) h)) : olds' ->
167 case (n,h) of
168 -- NOTE: zipping: when new is HeaderGreat, collapse last line downto col
169 -- then check if there is a matching HeaderGreat,
170 -- if so, discard new and restart with a col advanced to new's beginning
171 (NodeHeader HeaderGreat{}, NodeHeader HeaderGreat{})
172 | isAdjacent && isMatching ch -> discard
173 -- NOTE: same for HeaderBar
174 (NodeHeader HeaderBar{}, NodeHeader HeaderBar{})
175 | isAdjacent && isMatching ch -> discard
176 -- NOTE: collapsing: any other new aligned or on the right of an adjacent head
177 -- makes it collapse entirely
178 (_, NodeHeader HeaderGreat{})
179 | col < pos_column bh -> collapse
180 -- NOTE: same for HeaderBar
181 (_, NodeHeader HeaderBar{})
182 | col < pos_column bh -> collapse
183 _ -> debug "mergeRowPrefix/indent" $ mergeRowIndent rows row
184 where
185 isAdjacent = pos_line bn - pos_line eo <= 1
186 discard = debug "mergeRowPrefix/discard" $ mergeRowPrefix (pos_column bh) rows news
187 collapse = debug "mergeRowPrefix/collapse" $ mergeRowPrefix col (collapseRoot head olds') row
188 where
189 isMatching (Cell (Span _fh bh _eh:|_sh) h) =
190 pos_column bn == pos_column bh &&
191 n == h
192 isCollapsable = debug2 "mergeRowPrefix/isCollapsable" "new" "old" $
193 \_t0@(unTree -> c0@(Cell (Span _f0 b0 _e0:|_s0) _n0))
194 _t1@(unTree -> Cell (Span _f1 b1 e1:|_s1) _n1) ->
195 not (isMatching c0) &&
196 (pos_line b0 - pos_line e1 <= 1) && -- adjacent
197 col < pos_column b1 -- righter than col
198
199 -- | Merge by considering indentation.
200 mergeRowIndent :: Rows -> Row -> Rows
201 mergeRowIndent rows row =
202 debug2_ "mergeRowIndent" ("news",row) ("olds",rows) $
203 case (row,rows) of
204 ([], _) -> rows
205 (_, []) -> undefined -- NOTE: cannot happen with initRows
206 ( new@(Tree (Cell ssn@(Span fn bn en:|sn) n) ns):news
207 ,old@(Tree (Cell sso@(Span fo bo eo:|so) o) os):olds ) ->
208 case debug0 "mergeRowIndent/colNew" (pos_column bn) `compare`
209 debug0 "mergeRowIndent/colOld" (pos_column bo) of
210 -- NOTE: new is on the left
211 LT ->
212 case (n,o) of
213 -- NOTE: merge adjacent NodeText
214 -- first
215 -- second
216 (NodeText tn, NodeText to)
217 | TL.null tn || TL.null to
218 , not isVerbatim -> collapse
219 | isAdjacent && isIndented -> merge $ Tree t (os<>ns)
220 where
221 t = NodeText <$> Cell (Span fo boNew eo:|so) (indent<>to) <> Cell ssn tn
222 boNew = bo{pos_column=pos_column bn}
223 indent = TL.replicate (int64 $ pos_column bo - pos_column bn) " "
224 -- | Whether the horizontal delta is made of spaces
225 isIndented =
226 debug0 "mergeRowIndent/isIndented" $
227 case olds of
228 [] -> True
229 (unTree -> (cell_spans -> (span_end -> ep) :| _)) : _ ->
230 case pos_line ep `compare` pos_line bo of
231 LT -> True
232 EQ -> pos_column ep <= pos_column bn
233 _ -> False
234 _ -> collapse
235 -- NOTE: new is vertically aligned
236 EQ ->
237 case (n,o) of
238 -- NOTE: preserve all NodeText "", but still split into two NodePara
239 (NodeText tn, NodeText to)
240 | TL.null tn || TL.null to
241 , not isVerbatim -> collapse
242 | isAdjacent -> merge $ Tree (NodeText <$> Cell sso to <> Cell ssn tn) (os<>ns)
243 -- NOTE: HeaderSection can parent Nodes at the same level
244 (NodeHeader (HeaderSection lvlNew), NodeHeader (HeaderSection lvlOld)) ->
245 if debug0 "mergeRowIndent/lvlNew" lvlNew
246 > debug0 "mergeRowIndent/lvlOld" lvlOld
247 -- # old
248 -- ## new
249 then concat
250 -- ## old or # old
251 -- # new # new
252 else collapse
253 -- NOTE: old is no HeaderSection, then collapse to any older and loop
254 (NodeHeader HeaderSection{}, _)
255 | rows'@(sec:_) <- collapseRowsWhile isCollapsable rows
256 , (unTree -> (unCell -> NodeHeader HeaderSection{})) <- sec ->
257 mergeRowIndent rows' row
258 where
259 isCollapsable = debug2 "mergeRowIndent/isCollapsable" "new" "old" $
260 \_t0@(unTree -> Cell (Span _f0 b0 _e0:|_ss0) n0) _t1 ->
261 case n0 of
262 NodeHeader HeaderSection{} -> False
263 _ -> pos_column bn == pos_column b0
264 -- NOTE: in case of alignment, HeaderSection is parent
265 (_, NodeHeader HeaderSection{}) -> concat
266 --
267 _ -> replace
268 -- NOTE: new is on the right
269 GT ->
270 case (n,o) of
271 -- NOTE: only same line Root can be pushed on HeaderBar
272 -- DELME: (_, NodeHeader HeaderBar{}) | pos_column bn /= pos_column eo -> collapse
273 -- NOTE: keep NodeText "" out of old NodePara
274 (NodeText "", NodePara) -> collapse
275 -- NOTE: merge adjacent NodeText
276 (NodeText tn, NodeText to) ->
277 case isAdjacent of
278 _ | TL.null tn || TL.null to
279 , not isVerbatim -> collapse
280 -- old
281 -- new
282 True -> merge $ Tree (NodeText <$> Cell sso to <> Cell ssn tn) (os<>ns)
283 -- old
284 --
285 -- new
286 False -> mergeRowIndent (collapseRoot old olds) (shifted:news)
287 where
288 shifted = Tree (Cell (Span fn bnNew en:|sn) $ NodeText $ indent<>tn) (os<>ns)
289 bnNew = bn{pos_column=pos_column bo}
290 indent = TL.replicate (int64 $ pos_column bn - pos_column bo) " "
291 --
292 _ -> concat
293 where
294 isAdjacent = pos_line bn - pos_line eo <= 1
295 -- | Whether a parent semantic want new to stay a NodeText
296 isVerbatim = any p rows
297 where
298 p (unTree -> (unCell -> NodeHeader HeaderBar{})) = True
299 p _ = False
300 concat = debug "mergeRowIndent/concat" $ List.reverse row <> rows
301 merge m = debug "mergeRowIndent/merge" $ mergeRowIndent (m : olds) news
302 collapse = debug "mergeRowIndent/collapse" $ mergeRowIndent (collapseRoot old olds) row
303 replace = debug "mergeRowIndent/replace" $ mergeRowIndent (new : collapseRoot old olds) news
304
305 -- | Like 'mergeRowIndent', but without maintaining the appending,
306 -- hence collapsing all the 'Root's of the given 'Rows'.
307 --
308 -- NOTE: 'initRows' MUST have been the first 'Rows'
309 -- before calling 'mergeRowIndent' on it to get the given 'Rows'.
310 collapseRows :: Rows -> Roots
311 collapseRows rows =
312 debug1_ "collapseRows" ("rows",rows) $
313 case collapseRowsWhile (\_new _old -> True) rows of
314 [t] -> subTrees t
315 _ -> undefined
316 -- NOTE: subTrees returns the children of the updated initRows
317
318 -- | Collapse downto any last HeaderSection, returning it and its level.
319 collapseSection :: ColNum -> Rows -> Rows
320 collapseSection col = debug1 "collapseSection" "rows" go
321 where
322 go rows@(new@(unTree -> Cell (Span _fn bn _en:|_sn) n):olds)
323 | col <= pos_column bn =
324 case n of
325 NodeHeader HeaderSection{} -> rows
326 _ -> collapseSection col $ collapseRoot new $ go olds
327 go _ = mempty
328
329 collapseRowsWhile :: (Root -> Root -> Bool) -> Rows -> Rows
330 collapseRowsWhile test = debug1 "collapseRowsWhile" "rows" $ \case
331 [] -> mempty
332 rows@(new@(Tree (Cell (Span _fn bn _en:|_sn) n) _ns):news) ->
333 case news of
334 [] -> rows
335 old@(Tree (Cell (Span _fo bo eo:|_so) o) _os):olds
336 | not $ test new old -> rows
337 | otherwise ->
338 case debug0 "collapseRowsWhile/colNew" (pos_column bn) `compare`
339 debug0 "collapseRowsWhile/colOld" (pos_column bo) of
340 -- NOTE: new is vertically aligned
341 EQ ->
342 case (n,o) of
343 -- NOTE: HeaderSection can parent Nodes at the same level
344 (NodeHeader (HeaderSection lvlNew), NodeHeader (HeaderSection lvlOld)) ->
345 if debug0 "collapseRowsWhile/lvlNew" lvlNew
346 > debug0 "collapseRowsWhile/lvlOld" lvlOld
347 -- # old
348 -- ## new
349 then collapse
350 -- ## old or # old
351 -- # new # new
352 else
353 debug "collapseRowsWhile/replace" $
354 collapseRowsWhile test $ (new:) $ collapseRoot old olds
355 -- NOTE: old is no HeaderSection, then collapse to any older and loop
356 (NodeHeader HeaderSection{}, _)
357 | news'@(sec:_) <- debug0 "collapseRowsWhile/section" $ collapseRowsWhile isCollapsable news
358 , (unTree -> (unCell -> NodeHeader HeaderSection{})) <- sec ->
359 collapseRowsWhile test news'
360 where
361 isCollapsable = debug2 "collapseRowsWhile/isCollapsable" "new" "old" $
362 \_t0@(unTree -> Cell (Span _f0 b0 _e0:|_s0) n0) _t1 ->
363 case n0 of
364 NodeHeader HeaderSection{} -> False
365 _ -> pos_column bn == pos_column b0
366 -- NOTE: in case of alignment, HeaderSection is parent
367 (_, NodeHeader HeaderSection{}) -> debug "collapseRowsWhile/section/parent" collapse
368 -- NOTE: merge within old NodePara.
369 (_, NodePara) | isAdjacent -> collapse
370 --
371 _ -> collapse2
372 -- NOTE: new is either on the left or on the right
373 _ -> collapse
374 where
375 isAdjacent = pos_line bn - pos_line eo <= 1
376 collapse = debug "collapseRowsWhile/collapse" $ collapseRowsWhile test $ collapseRoot new $ news
377 collapse2 = debug "collapseRowsWhile/collapse2" $ collapseRowsWhile test $ collapseRoot new $ collapseRoot old $ olds
378
379 -- | Put a 'Root' as a child of the head 'Root'.
380 --
381 -- NOTE: 'collapseRoot' is where 'NodePara' may be introduced.
382 --
383 -- NOTE: any NodeText/NodeText merging must have been done before.
384 collapseRoot :: Root -> Rows -> Rows
385 collapseRoot new@(Tree (Cell ssn@(Span _fn bn en:|_sn) n) _ns) rows =
386 debug2_ "collapseRoot" ("new",Seq.singleton new) ("rows",rows) $
387 case rows of
388 [] -> return new
389 old@(Tree (Cell (Span fo bo eo:|so) o) os) : olds ->
390 case (n,o) of
391 -- NOTE: no child into NodeText
392 (_, NodeText{}) -> collapse2
393 -- NOTE: NodeText can begin a NodePara
394 (NodeText tn, _) | not $ TL.null tn ->
395 case o of
396 -- NOTE: no NodePara within those
397 NodeHeader HeaderEqual{} -> collapse
398 NodeHeader HeaderBar{} -> collapse
399 NodeHeader HeaderDashDash{} -> collapse
400 -- NOTE: NodePara within those
401 NodePara | not isAdjacent -> para
402 NodeHeader{} -> para
403 _ -> collapse
404 -- NOTE: amongst remaining nodes, only adjacent ones may enter an old NodePara.
405 -- Note that since a NodePara is never adjacent to another,
406 -- it is not nested within another.
407 (_, NodePara)
408 | isAdjacent ->
409 case n of
410 -- NOTE: no HeaderSection (even adjacent) within a NodePara
411 NodeHeader HeaderSection{} -> collapse2
412 _ -> collapse
413 | otherwise -> collapse2
414 _ -> collapse
415 where
416 isAdjacent = pos_line bn - pos_line eo <= 1
417 para = Tree (Cell ssn NodePara) (return new) : rows
418 collapse = Tree (Cell (Span fo bo en:|so) o) (os |> new) : olds
419 collapse2 = collapseRoot new $ collapseRoot old olds