]> Git — Sourcephile - doclang.git/blob - Language/TCT/Tree.hs
Remove unused code.
[doclang.git] / Language / TCT / Tree.hs
1 {-# LANGUAGE DeriveFunctor #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 module Language.TCT.Tree where
4
5 import Control.Applicative (Applicative(..))
6 import Data.Bool
7 import Data.Eq (Eq(..))
8 import Data.Foldable (Foldable(..))
9 import Data.Foldable (foldr)
10 import Data.Function (($), (.))
11 import Data.Functor (Functor, (<$>))
12 import Data.Maybe (Maybe(..))
13 import Data.Ord (Ordering(..), Ord(..))
14 import Data.Semigroup (Semigroup(..))
15 import Data.Sequence (Seq, ViewL(..), (|>))
16 import Data.Text (Text)
17 import Data.Traversable (Traversable(..))
18 import Prelude (undefined, Int, Num(..))
19 import Text.Show (Show(..))
20 import qualified Data.List as List
21 import qualified Data.Sequence as Seq
22 import qualified Data.Text as Text
23
24 import Language.TCT.Elem
25
26 -- * Type 'Tree'
27 data Tree k a
28 = TreeN k (Trees k a)
29 | Tree0 a
30 deriving (Eq, Show, Functor)
31
32 instance Traversable (Tree k) where
33 traverse f (Tree0 a) = Tree0 <$> f a
34 traverse f (TreeN k ts) = TreeN k <$> traverse (traverse f) ts
35 sequenceA (Tree0 a) = Tree0 <$> a
36 sequenceA (TreeN k ts) = TreeN k <$> traverse sequenceA ts
37 instance Foldable (Tree k) where
38 foldMap f (TreeN _k ts) = foldMap (foldMap f) ts
39 foldMap f (Tree0 k) = f k
40
41 mapTreeWithKey :: (Maybe k -> a -> b) -> Tree k a -> Tree k b
42 mapTreeWithKey = go Nothing
43 where
44 go _k f (TreeN k ts) = TreeN k (go (Just k) f <$> ts)
45 go k f (Tree0 a) = Tree0 (f k a)
46
47 mapTreeKey :: (k -> l) -> (Maybe k -> a -> b) -> Tree k a -> Tree l b
48 mapTreeKey fk fv = go Nothing
49 where
50 go _k (TreeN k ts) = TreeN (fk k) $ go (Just k) <$> ts
51 go k (Tree0 a) = Tree0 (fv k a)
52
53 traverseTreeWithKey :: Applicative f => (Maybe k -> a -> f b) -> Tree k a -> f (Tree k b)
54 traverseTreeWithKey = go Nothing
55 where
56 go _p f (TreeN k ts) = TreeN k <$> traverse (go (Just k) f) ts
57 go p f (Tree0 a) = Tree0 <$> f p a
58
59 -- ** Type 'Trees'
60 type Trees k a = Seq (Tree k a)
61
62 newtype PrettyTree k a = PrettyTree (Trees k a)
63 instance (Show k, Show a) => Show (PrettyTree k a) where
64 show (PrettyTree t) = Text.unpack $ prettyTrees t
65
66 prettyTree :: (Show k, Show a) => Tree k a -> Text
67 prettyTree = Text.unlines . pretty
68
69 prettyTrees :: (Show k, Show a) => Trees k a -> Text
70 prettyTrees = foldr (\t acc -> prettyTree t <> "\n" <> acc) ""
71
72 pretty :: (Show k, Show a) => Tree k a -> [Text]
73 pretty (Tree0 a) = [Text.pack (show a)]
74 pretty (TreeN k ts0) = Text.pack (show k) : prettySubTrees ts0
75 where
76 prettySubTrees s =
77 case Seq.viewl s of
78 Seq.EmptyL -> []
79 t:<ts | Seq.null ts -> "|" : shift "`- " " " (pretty t)
80 | otherwise -> "|" : shift "+- " "| " (pretty t) <> prettySubTrees ts
81 shift first other = List.zipWith (<>) (first : List.repeat other)
82
83 -- * Type 'Pos'
84 data Pos = Pos {-# UNPACK #-} !Line {-# UNPACK #-} !Column
85 deriving (Eq, Show)
86
87 posTree :: Tree (Cell k) (Cell a) -> Pos
88 posTree (TreeN c _) = posCell c
89 posTree (Tree0 c) = posCell c
90
91 posEndTree :: Tree (Cell k) (Cell a) -> Pos
92 posEndTree (TreeN c _) = posEndCell c
93 posEndTree (Tree0 c) = posEndCell c
94
95 pos0 :: Pos
96 pos0 = Pos 0 0
97 pos1 :: Pos
98 pos1 = Pos 1 1
99
100 -- ** Type 'Line'
101 -- | Line in the source file, counting from 1.
102 type Line = Int
103 linePos :: Pos -> Line
104 linePos (Pos l _) = l
105
106 -- ** Type 'Column'
107 -- | Column in the source file, counting from 1.
108 type Column = Int
109 columnPos :: Pos -> Column
110 columnPos (Pos _ c) = c
111
112 -- * Type 'Row'
113 -- | A list of 'Key's, maybe ended by 'Value', all read on the same 'Line'.
114 type Row = [Tree (Cell Key) (Cell Text)]
115
116 -- ** Type 'Cell'
117 -- | NOTE: every 'Cell' as a 'Pos',
118 -- which is useful to indicate matches/errors/warnings/whatever,
119 -- or outputing in a format somehow preserving
120 -- the original input style.
121 data Cell a = Cell {-# UNPACK #-} !Pos {-# UNPACK #-} !Pos a
122 deriving (Eq, Show)
123
124 unCell :: Cell a -> a
125 unCell (Cell _ _ a) = a
126
127 posCell :: Cell a -> Pos
128 posCell (Cell pos _ _) = pos
129 posEndCell :: Cell a -> Pos
130 posEndCell (Cell _ pos _) = pos
131
132 lineCell :: Cell a -> Line
133 lineCell = linePos . posCell
134 columnCell :: Cell a -> Column
135 columnCell = columnPos . posCell
136
137 cell0 :: a -> Cell a
138 cell0 = Cell pos0 pos0
139 cell1 :: a -> Cell a
140 cell1 = Cell pos1 pos1
141
142 -- * Type 'Key'
143 data Key = KeyColon !Name !White -- ^ @name: @
144 | KeyEqual !Name !White -- ^ @name=@
145 | KeyBar !Name !White -- ^ @name|@
146 | KeyGreat !Name !White -- ^ @name>@
147 | KeyLower !Name !Attrs -- ^ @<name a=b@
148 | KeyDot !Name -- ^ @1. @
149 | KeyDash -- ^ @- @
150 | KeyDashDash -- ^ @-- @
151 | KeySection !LevelSection -- ^ @# @
152 | KeyBrackets !Name -- ^ @[ name ]@
153 deriving (Eq, Show)
154
155 -- ** Type 'Name'
156 type Name = Text
157
158 -- ** Type 'LevelSection'
159 type LevelSection = Int
160
161 -- * Type 'Rows'
162 type Rows = [Tree (Cell Key) (Cell Text)]
163
164 -- | @appendRow rows row@ appends @row@ to @rows@.
165 --
166 -- [@rows@] parent 'Rows', from closest to farest (non-strictly descending)
167 -- [@row@] next 'Row', from leftest column to rightest (non-stricly ascending)
168 appendRow :: Rows -> Row -> Rows
169 appendRow [] row = List.reverse row
170 appendRow parents [] = parents
171 appendRow rows@(parent:parents) row@(cell:cells) =
172 trac ("appendRow: rows=" <> show rows) $
173 trac ("appendRow: row=" <> show row) $
174 dbg "appendRow" $
175 let colParent = columnPos $ posTree parent in
176 let colRow = columnPos $ posTree cell in
177 case dbg "colParent" colParent`compare`dbg "colRow" colRow of
178 LT ->
179 case (dbg "parent" parent,dbg "cell" cell) of
180 (Tree0{}, TreeN{}) -> eq
181 (Tree0 p, Tree0{}) | Text.null (unCell p) -> eq -- FIXME: useful?
182 (Tree0 p, Tree0 r) -> appendTree0 p r
183 _ -> lt
184 EQ ->
185 case (dbg "parent" parent,dbg "cell" cell) of
186 (Tree0 p, Tree0 r) -> appendTree0 p r
187 (_, TreeN (unCell -> KeySection sectionRow) _)
188 | Just (sectionParent, secPar:secPars) <- collapseSection colRow rows ->
189 case dbg "sectionParent" sectionParent`compare`dbg "sectionRow" sectionRow of
190 LT -> appendRow (cell:secPar:secPars) cells
191 EQ -> appendRow (cell:insertChild secPar secPars) cells
192 GT -> gt
193 (TreeN (unCell -> KeySection{}) _, Tree0{}) -> lt
194 (TreeN (unCell -> KeySection{}) _, TreeN{}) -> lt
195 (Tree0{}, TreeN{}) -> eq
196 (TreeN{}, TreeN{}) -> eq
197 (TreeN{}, Tree0{}) -> eq
198 GT -> gt
199 where
200 appendTree0 p r =
201 case appendCellText p r of
202 Nothing -> appendRow (Tree0 r : insertChild (Tree0 p) parents) cells
203 Just c -> appendRow (Tree0 c : parents) cells
204 lt = appendRow [] row <> rows
205 eq = appendRow (cell : insertChild parent parents) cells
206 gt = appendRow (insertChild parent parents) row
207 -- | Find the first section (if any), returning its level, and the path collapsed upto it.
208 collapseSection :: Column -> Rows -> Maybe (Int,Rows)
209 collapseSection col xxs@(x:xs) | columnPos (posTree x) == col =
210 case x of
211 TreeN (unCell -> KeySection lvl) _ -> Just (lvl,xxs)
212 _ -> (\(lvl,cs) -> (lvl,insertChild x cs)) <$> collapseSection col xs
213 collapseSection _ _ = Nothing
214
215 appendCellText :: Cell Text -> Cell Text -> Maybe (Cell Text)
216 appendCellText (Cell posPar posEndPar p)
217 (Cell posRow posEndRow r) =
218 trac ("appendCellText: p="<>show p) $
219 trac ("appendCellText: r="<>show r) $
220 dbg "appendCellText" $
221 case linePos posRow - linePos posEndPar of
222 0 -> Just $ Cell posPar posEndRow $ p <> pad <> r
223 where pad = padding (columnPos posEndPar) (columnPos posRow)
224 1 -> Just $ Cell posPar posEndRow $ p <> pad <> r
225 where pad = "\n" <> padding (columnPos posPar) (columnPos posRow)
226 _ -> Nothing
227 where
228 padding x y = Text.replicate (y - x) " "
229
230 insertChild :: Tree (Cell Key) (Cell Text) -> Rows -> Rows
231 insertChild child ps@[] =
232 trac ("insertChild: child="<>show child) $
233 trac ("insertChild: ps="<>show ps) $
234 dbg "insertChild" $
235 [child]
236 insertChild _child (Tree0{}:_) = undefined
237 insertChild child ps@(TreeN parent treesParent:parents) =
238 trac ("insertChild: child="<>show child) $
239 trac ("insertChild: ps="<>show ps) $
240 dbg "insertChild" $
241 case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of
242 LT -> TreeN parent (treesParent |> child) : parents
243 EQ -> TreeN parent (treesParent |> child) : parents
244 GT -> undefined
245
246 collapseRows :: Rows -> Tree (Cell Key) (Cell Text)
247 collapseRows [] = undefined
248 collapseRows [child] = dbg "collapseRows" $ child
249 collapseRows (child:parents) = dbg "collapseRows" $ collapseRows $ insertChild child parents