]> Git — Sourcephile - doclang.git/blob - Data/TreeSeq/Strict/Zipper.hs
Add HTML5 rendition of DTC.Index.
[doclang.git] / Data / TreeSeq / Strict / Zipper.hs
1 module Data.TreeSeq.Strict.Zipper where
2
3 import Control.Arrow (Kleisli(..))
4 import Control.Applicative (Applicative(..), Alternative(..))
5 import Control.Monad (Monad(..), (>=>))
6 import Data.Bool
7 import Data.Eq (Eq)
8 import Data.Function (($), (.))
9 import Data.Functor ((<$>))
10 import Data.Int (Int)
11 import Data.List.NonEmpty (NonEmpty(..))
12 import Data.Maybe (Maybe(..), maybe, mapMaybe)
13 import Data.Monoid (Monoid(..))
14 import Data.Semigroup (Semigroup(..))
15 import Data.Sequence (ViewL(..), ViewR(..), (<|), (|>))
16 import Data.Typeable (Typeable)
17 import Prelude (undefined)
18 import Text.Show (Show(..))
19 import qualified Data.List as List
20 import qualified Data.List.NonEmpty as NonEmpty
21 import qualified Data.Sequence as Seq
22
23 import Data.TreeSeq.Strict (Trees, Tree(..))
24
25 -- * Type 'Zipper'
26 type Zipper k a = NonEmpty (Cursor k a)
27
28 -- | Return a 'Zipper' starting at the given 'Tree'.
29 zipper :: Tree k a -> Zipper k a
30 zipper t = Cursor mempty t mempty :| []
31
32 -- | Return a 'Zipper' starting at the left-most 'Tree' of the given 'Trees'.
33 zippers :: Trees k a -> [Zipper k a]
34 zippers ts =
35 case Seq.viewl ts of
36 EmptyL -> empty
37 l :< ls -> pure $ Cursor mempty l ls :| []
38
39 -- | Return the 'Cursor' after zipping the given 'Zipper' upto its last parent.
40 root :: Zipper k a -> Cursor k a
41 root = NonEmpty.head . List.last . axis_ancestor_or_self
42
43 -- | Return the keys within the 'TreeN' nodes
44 -- leading to the current 'Cursor' of the given 'Zipper'.
45 path :: Zipper k x -> [k]
46 path cs =
47 List.reverse $
48 NonEmpty.toList cs >>= \c ->
49 case cursor_self c of
50 TreeN k _ -> [k]
51 Tree0{} -> []
52
53 -- | Return the 'Tree' currently under the 'Cursor'.
54 current :: Zipper k a -> Tree k a
55 current (Cursor _ t _ :| _) = t
56
57 -- | Return the 'Tree's selected by the given 'Axis' from the given 'Zipper'.
58 select :: Axis k a -> Zipper k a -> [Tree k a]
59 select axis c = cursor_self . NonEmpty.head <$> axis c
60
61 -- | Return the filtered values selected by the given 'Axis' from the given 'Zipper'.
62 filter :: Axis k a -> (Zipper k a -> Maybe b) -> Zipper k a -> [b]
63 filter axis f c = f `mapMaybe` axis c
64
65 -- ** Type 'Cursor'
66 data Cursor k a
67 = Cursor
68 { cursor_precedings :: Trees k a
69 , cursor_self :: Tree k a
70 , cursor_followings :: Trees k a
71 } deriving (Eq, Show, Typeable)
72
73 -- * Type 'Axis'
74 type Axis k a = Zipper k a -> [Zipper k a]
75
76 -- ** Type 'KleisliAxis'
77 type KleisliAxis k a = Kleisli [] (Zipper k a) (Zipper k a)
78
79 -- ** Type 'AxisAlt'
80 -- | Like 'Axis', but generalized with 'Alternative'.
81 --
82 -- Useful to return a 'Maybe' instead of a list.
83 type AxisAlt f k a = Zipper k a -> f (Zipper k a)
84
85 -- ** Axis @repeat@
86 -- | Collect all 'Zipper's along a given axis,
87 -- including the first 'Zipper'.
88 axis_repeat :: AxisAlt Maybe k a -> Axis k a
89 axis_repeat f c = c : maybe [] (axis_repeat f) (f c)
90
91 -- | Collect all 'Zipper's along a given axis,
92 -- excluding the starting 'Zipper'.
93 axis_repeat_without_self :: AxisAlt Maybe k a -> Axis k a
94 axis_repeat_without_self f c = maybe [] (axis_repeat f) (f c)
95
96 -- ** Axis @filter@
97 axis_filter :: Axis k a -> (Zipper k a -> Bool) -> Axis k a
98 axis_filter axis f c = List.filter f (axis c)
99 infixl 5 `axis_filter`
100
101 -- ** Axis @at@
102 axis_at :: Alternative f => Axis k a -> Int -> AxisAlt f k a
103 axis_at axis i c =
104 case List.drop i $ axis c of
105 [] -> empty
106 a:_ -> pure a
107 infixl 5 `axis_at`
108
109 -- ** Axis @self@
110 axis_self :: Applicative f => AxisAlt f k a
111 axis_self = pure
112
113 -- ** Axis @child@
114 axis_child :: Axis k a
115 axis_child c =
116 axis_child_first c >>=
117 axis_repeat axis_following1
118
119 axis_child_lookup_first :: Alternative f => (k -> Bool) -> AxisAlt f k a
120 axis_child_lookup_first fk c = listHead $ axis_child_lookup fk c
121
122 axis_child_lookup :: (k -> Bool) -> Axis k a
123 axis_child_lookup fk cs@(Cursor _ps t _fs :| _) =
124 (<$> Seq.findIndicesL flt ns) $ \i ->
125 let (ps, ps') = Seq.splitAt i ns in
126 case Seq.viewl ps' of
127 EmptyL -> undefined
128 l :< ls -> Cursor ps l ls :| NonEmpty.toList cs
129 where
130 ns = nodesTree t
131 flt (TreeN k _) = fk k
132 flt Tree0{} = False
133
134 axis_child_first :: Alternative f => AxisAlt f k a
135 axis_child_first cs@(Cursor _ps t _fs :| _) =
136 case Seq.viewl $ nodesTree t of
137 EmptyL -> empty
138 l :< ls -> pure $ Cursor mempty l ls :| NonEmpty.toList cs
139
140 axis_child_last :: Alternative f => AxisAlt f k a
141 axis_child_last cs@(Cursor _ps t _fs :| _) =
142 case Seq.viewr $ nodesTree t of
143 EmptyR -> empty
144 rs :> r -> pure $ Cursor rs r mempty :| NonEmpty.toList cs
145
146 -- ** Axis @ancestor@
147 axis_ancestor :: Axis k a
148 axis_ancestor = axis_repeat_without_self axis_parent
149
150 axis_ancestor_or_self :: Axis k a
151 axis_ancestor_or_self = axis_repeat axis_parent
152
153 axis_root :: Alternative f => AxisAlt f k a
154 axis_root = pure . List.last . axis_ancestor_or_self
155
156 -- ** Axis @descendant@
157 axis_descendant_or_self :: Axis k a
158 axis_descendant_or_self =
159 collect_child []
160 where
161 collect_child acc c =
162 c : maybe acc
163 (collect_following_first acc)
164 (axis_child_first c)
165 collect_following_first acc c =
166 collect_child
167 (maybe acc
168 (collect_following_first acc)
169 (axis_following1 c)
170 ) c
171
172 axis_descendant_or_self_reverse :: Axis k a
173 axis_descendant_or_self_reverse c =
174 c :
175 List.concatMap
176 axis_descendant_or_self_reverse
177 (List.reverse $ axis_child c)
178
179 axis_descendant :: Axis k a
180 axis_descendant = List.tail . axis_descendant_or_self
181
182 -- ** Axis @preceding@
183 axis_preceding1 :: Alternative f => AxisAlt f k a
184 axis_preceding1 (Cursor ps t fs :| cs) =
185 case Seq.viewr ps of
186 EmptyR -> empty
187 rs :> r -> pure $ Cursor rs r (t <| fs) :| cs
188
189 axis_preceding_sibling :: Axis k a
190 axis_preceding_sibling = axis_repeat_without_self axis_preceding1
191
192 axis_preceding_sibling_first :: Alternative f => AxisAlt f k a
193 axis_preceding_sibling_first z@(Cursor ps t fs :| cs) =
194 case Seq.viewl (ps |> t) of
195 EmptyL -> pure z
196 l :< ls -> pure $ Cursor mempty l (ls<>fs) :| cs
197
198 axis_preceding :: Axis k a
199 axis_preceding =
200 axis_ancestor_or_self >=>
201 axis_preceding_sibling >=>
202 axis_descendant_or_self_reverse
203
204 -- ** Axis @following@
205 axis_following1 :: Alternative f => AxisAlt f k a
206 axis_following1 (Cursor ps t fs :| cs) =
207 case Seq.viewl fs of
208 EmptyL -> empty
209 l :< ls -> pure $ Cursor (ps |> t) l ls :| cs
210
211 axis_following_sibling :: Axis k a
212 axis_following_sibling = axis_repeat_without_self axis_following1
213
214 axis_following_sibling_last :: Alternative f => AxisAlt f k a
215 axis_following_sibling_last z@(Cursor ps t fs :| cs) =
216 case Seq.viewr (t <| fs) of
217 EmptyR -> pure z
218 rs :> r -> pure $ Cursor (ps<>rs) r mempty :| cs
219
220 axis_following :: Axis k a
221 axis_following =
222 axis_ancestor_or_self >=>
223 axis_following_sibling >=>
224 axis_descendant_or_self
225
226 -- ** Axis @parent@
227 axis_parent :: Alternative f => AxisAlt f k a
228 axis_parent (Cursor ps t fs :| cs) =
229 case cs of
230 Cursor ps' (TreeN k _) fs' : cs' ->
231 pure $ Cursor ps' (TreeN k $ (ps |> t) <> fs) fs' :| cs'
232 _ -> empty
233
234 -- * Utilities
235 nodesTree :: Tree k a -> Trees k a
236 nodesTree Tree0{} = mempty
237 nodesTree (TreeN _k ts) = ts
238
239 listHead :: Alternative f => [a] -> f a
240 listHead [] = empty
241 listHead (a:_) = pure a