]> Git — Sourcephile - doclang.git/blob - Language/TCT/Tree.hs
Add more elements in the <head> of the HTML5 rendering of DTC.
[doclang.git] / Language / TCT / Tree.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE ViewPatterns #-}
3 module Language.TCT.Tree
4 ( module Language.TCT.Tree
5 , Tree(..)
6 , Trees
7 ) where
8
9 import Data.Eq (Eq(..))
10 import Data.Function (($))
11 import Data.Functor ((<$>))
12 import Data.Maybe (Maybe(..))
13 import Data.Ord (Ordering(..), Ord(..))
14 import Data.Semigroup (Semigroup(..))
15 import Data.Sequence ((|>))
16 import Data.Text (Text)
17 import Data.TreeSeq.Strict (Tree(..), Trees)
18 import Prelude (undefined, Int, Num(..))
19 import Text.Show (Show(..))
20 import qualified Data.List as List
21 import qualified Data.Text as Text
22 import qualified System.FilePath as FP
23
24 import Language.TCT.Cell
25 import Language.TCT.Elem
26
27 -- * Type 'Row'
28 -- | A list of 'Key's, maybe ended by 'Value', all read on the same 'Line'.
29 type Row = [Tree (Cell Key) (Cell Text)]
30
31 -- * Type 'Key'
32 data Key = KeyColon !Name !White -- ^ @name: @
33 | KeyEqual !Name !White -- ^ @name=@
34 | KeyBar !Name !White -- ^ @name|@
35 | KeyGreat !Name !White -- ^ @name>@
36 | KeyLower !Name !Attrs -- ^ @<name a=b@
37 | KeyDot !Name -- ^ @1. @
38 | KeyDash -- ^ @- @
39 | KeyDashDash -- ^ @-- @
40 | KeySection !LevelSection -- ^ @# @
41 | KeyBrackets !Name -- ^ @[ name ]@
42 | KeyDotSlash !PathFile -- ^ @./file @
43 deriving (Eq, Ord, Show)
44
45 -- ** Type 'Name'
46 type Name = Text
47
48 -- ** Type 'PathFile'
49 type PathFile = FP.FilePath
50
51 -- ** Type 'LevelSection'
52 type LevelSection = Int
53
54 -- * Type 'Rows'
55 type Rows = [Tree (Cell Key) (Cell Text)]
56
57 -- | @appendRow rows row@ appends @row@ to @rows@.
58 --
59 -- [@rows@] parent 'Rows', from closest to farest (non-strictly descending)
60 -- [@row@] next 'Row', from leftest column to rightest (non-stricly ascending)
61 appendRow :: Rows -> Row -> Rows
62 appendRow [] row = List.reverse row
63 appendRow parents [] = parents
64 appendRow rows@(parent:parents) row@(cell:cells) =
65 trac ("appendRow: rows=" <> show rows) $
66 trac ("appendRow: row=" <> show row) $
67 dbg "appendRow" $
68 let colParent = columnPos $ posTree parent in
69 let colRow = columnPos $ posTree cell in
70 case dbg "colParent" colParent`compare`dbg "colRow" colRow of
71 LT ->
72 case (dbg "parent" parent,dbg "cell" cell) of
73 (Tree0{}, TreeN{}) -> eq
74 (Tree0 p, Tree0{}) | Text.null (unCell p) -> eq -- FIXME: useful?
75 (Tree0 p, Tree0 r) -> appendTree0 p r
76 _ -> lt
77 EQ ->
78 case (dbg "parent" parent,dbg "cell" cell) of
79 (Tree0 p, Tree0 r) -> appendTree0 p r
80 (_, TreeN (unCell -> KeySection sectionRow) _)
81 | Just (sectionParent, secPar:secPars) <- collapseSection colRow rows ->
82 case dbg "sectionParent" sectionParent`compare`dbg "sectionRow" sectionRow of
83 LT -> appendRow (cell:secPar:secPars) cells
84 EQ -> appendRow (cell:insertChild secPar secPars) cells
85 GT -> gt
86 (TreeN (unCell -> KeySection{}) _, Tree0{}) -> lt
87 (TreeN (unCell -> KeySection{}) _, TreeN{}) -> lt
88 (Tree0{}, TreeN{}) -> eq
89 (TreeN{}, TreeN{}) -> eq
90 (TreeN{}, Tree0{}) -> eq
91 GT -> gt
92 where
93 appendTree0 p r =
94 case appendCellText p r of
95 Nothing -> appendRow (Tree0 r : insertChild (Tree0 p) parents) cells
96 Just c -> appendRow (Tree0 c : parents) cells
97 lt = appendRow [] row <> rows
98 eq = appendRow (cell : insertChild parent parents) cells
99 gt = appendRow (insertChild parent parents) row
100 -- | Find the first section (if any), returning its level, and the path collapsed upto it.
101 collapseSection :: Column -> Rows -> Maybe (Int,Rows)
102 collapseSection col xxs@(x:xs) | columnPos (posTree x) == col =
103 case x of
104 TreeN (unCell -> KeySection lvl) _ -> Just (lvl,xxs)
105 _ -> (\(lvl,cs) -> (lvl,insertChild x cs)) <$> collapseSection col xs
106 collapseSection _ _ = Nothing
107
108 appendCellText :: Cell Text -> Cell Text -> Maybe (Cell Text)
109 appendCellText (Cell posPar posEndPar p)
110 (Cell posRow posEndRow r) =
111 trac ("appendCellText: p="<>show p) $
112 trac ("appendCellText: r="<>show r) $
113 dbg "appendCellText" $
114 case linePos posRow - linePos posEndPar of
115 0 -> Just $ Cell posPar posEndRow $ p <> pad <> r
116 where pad = padding (columnPos posEndPar) (columnPos posRow)
117 1 -> Just $ Cell posPar posEndRow $ p <> pad <> r
118 where pad = "\n" <> padding (columnPos posPar) (columnPos posRow)
119 _ -> Nothing
120 where
121 padding x y = Text.replicate (y - x) " "
122
123 insertChild :: Tree (Cell Key) (Cell Text) -> Rows -> Rows
124 insertChild child ps@[] =
125 trac ("insertChild: child="<>show child) $
126 trac ("insertChild: ps="<>show ps) $
127 dbg "insertChild" $
128 [child]
129 insertChild _child (Tree0{}:_) = undefined
130 insertChild child ps@(TreeN parent treesParent:parents) =
131 trac ("insertChild: child="<>show child) $
132 trac ("insertChild: ps="<>show ps) $
133 dbg "insertChild" $
134 case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of
135 LT -> TreeN parent (treesParent |> child) : parents
136 EQ -> TreeN parent (treesParent |> child) : parents
137 GT -> undefined
138
139 collapseRows :: Rows -> Tree (Cell Key) (Cell Text)
140 collapseRows [] = undefined
141 collapseRows [child] = dbg "collapseRows" $ child
142 collapseRows (child:parents) = dbg "collapseRows" $ collapseRows $ insertChild child parents