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