]> Git — Sourcephile - haskell/treeseq.git/blob - Data/TreeSeq/Strict/Zipper.hs
init, by extracting from hdoc
[haskell/treeseq.git] / Data / TreeSeq / Strict / Zipper.hs
1 module Data.TreeSeq.Strict.Zipper where
2
3 import Control.Arrow (Kleisli(..))
4 import Control.Category (Category(..), (>>>))
5 import Control.Applicative (Applicative(..), Alternative(..))
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 a = NonEmpty (Cursor a)
27
28 -- | Return a 'Zipper' starting at the given 'Tree'.
29 zipper :: Tree a -> Zipper 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 a -> [Zipper 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 a -> Cursor a
41 root = NonEmpty.head . List.last . runAxis axis_ancestor_or_self
42
43 -- | Like 'root', but concatenate the 'Cursor' into a 'Trees'.
44 roots :: Zipper a -> Trees a
45 roots z = ps <> (s <| fs)
46 where Cursor ps s fs = root z
47
48 -- | Return the keys within the 'Tree' nodes
49 -- leading to the current 'Cursor' of the given 'Zipper'.
50 zipath :: Zipper a -> [a]
51 zipath z =
52 List.reverse $
53 unTree . cursor_self
54 <$> NonEmpty.toList z
55
56 -- | Return the 'Tree's selected by the given 'Axis' from the given 'Zipper'.
57 select :: Axis a -> Zipper a -> [Tree a]
58 select axis z = cursor_self . NonEmpty.head <$> runAxis axis z
59
60 -- | Return the filtered values selected by the given 'Axis' from the given 'Zipper'.
61 filter :: Axis a -> (Zipper a -> Maybe b) -> Zipper a -> [b]
62 filter axis f z = f `mapMaybe` runAxis axis z
63
64 -- ** Type 'Cursor'
65 data Cursor a
66 = Cursor
67 { cursor_preceding_siblings :: Trees a
68 , cursor_self :: Tree a
69 , cursor_following_siblings :: Trees a
70 } deriving (Eq, Show, Typeable)
71
72 -- | Return the current 'Cursor' of a 'Zipper'.
73 cursor :: Zipper a -> Cursor a
74 cursor = NonEmpty.head
75
76 -- | Set the current 'Cursor' of a 'Zipper'.
77 setCursor :: Zipper a -> Cursor a -> Zipper a
78 setCursor (_c :| cs) c = c :| cs
79
80 -- | Return the 'Tree' currently under the 'Cursor'.
81 current :: Zipper a -> Tree a
82 current (Cursor _ t _ :| _) = t
83
84 -- ** Type 'Axis'
85 type Axis a = AxisAlt [] a
86
87 runAxis :: Axis a -> Zipper a -> [Zipper a]
88 runAxis = runKleisli
89
90 -- ** Type 'AxisAlt'
91 -- | Like 'Axis', but generalized with 'Alternative'.
92 --
93 -- Useful to return a 'Maybe' instead of a list.
94 type AxisAlt f a = Kleisli f (Zipper a) (Zipper a)
95
96 runAxisAlt :: AxisAlt f a -> Zipper a -> f (Zipper a)
97 runAxisAlt = runKleisli
98
99 -- ** Axis @repeat@
100 -- | Collect all 'Zipper's along a given axis,
101 -- including the first 'Zipper'.
102 axis_repeat :: AxisAlt Maybe a -> Axis a
103 axis_repeat f = Kleisli $ \z -> z : maybe [] (runAxis $ axis_repeat f) (runAxisAlt f z)
104
105 -- | Collect all 'Zipper's along a given axis,
106 -- excluding the starting 'Zipper'.
107 axis_repeat_without_self :: AxisAlt Maybe a -> Axis a
108 axis_repeat_without_self f = Kleisli $ \z -> maybe [] (runAxis $ axis_repeat f) (runAxisAlt f z)
109
110 -- ** Axis @filter@
111 axis_filter :: Axis a -> (Zipper a -> Bool) -> Axis a
112 axis_filter axis f = Kleisli $ \z -> List.filter f (runAxis axis z)
113 infixl 5 `axis_filter`
114
115 axis_filter_current :: Axis a -> (Tree a -> Bool) -> Axis a
116 axis_filter_current axis f = Kleisli $ \z -> List.filter (f . current) (runAxis axis z)
117 infixl 5 `axis_filter_current`
118
119 -- ** Axis @first@
120 axis_first :: Axis a -> Axis a
121 axis_first axis = Kleisli $ List.take 1 . runAxis axis
122
123 -- ** Axis @last@
124 axis_last :: Axis a -> Axis a
125 axis_last axis = Kleisli $ List.take 1 . List.reverse . runAxis axis
126
127 -- ** Axis @at@
128 axis_at :: Alternative f => Axis a -> Int -> AxisAlt f a
129 axis_at axis i = Kleisli $ \z ->
130 case List.drop i $ runAxis axis z of
131 [] -> empty
132 a:_ -> pure a
133 infixl 5 `axis_at`
134
135 -- ** Axis @self@
136 axis_self :: Applicative f => AxisAlt f a
137 axis_self = Kleisli pure
138
139 -- ** Axis @child@
140 axis_child :: Axis a
141 axis_child =
142 axis_child_first >>>
143 axis_repeat axis_following_sibling_nearest
144
145 axis_child_lookup_first :: Alternative f => (a -> Bool) -> AxisAlt f a
146 axis_child_lookup_first fa = Kleisli $ listHead . runAxis (axis_child_lookup fa)
147
148 axis_child_lookup :: (a -> Bool) -> Axis a
149 axis_child_lookup f = Kleisli $ \z@(Cursor _ps t _fs :| _) ->
150 let ns = subTrees t in
151 (<$> Seq.findIndicesL (f . unTree) ns) $ \i ->
152 let (ps, ps') = Seq.splitAt i ns in
153 case Seq.viewl ps' of
154 EmptyL -> undefined
155 l :< ls -> Cursor ps l ls :| NonEmpty.toList z
156
157 axis_child_first :: Alternative f => AxisAlt f a
158 axis_child_first = Kleisli $ \z@(Cursor _ps t _fs :| _) ->
159 case Seq.viewl $ subTrees t of
160 EmptyL -> empty
161 l :< ls -> pure $ Cursor mempty l ls :| NonEmpty.toList z
162
163 axis_child_last :: Alternative f => AxisAlt f a
164 axis_child_last = Kleisli $ \z@(Cursor _ps t _fs :| _) ->
165 case Seq.viewr $ subTrees t of
166 EmptyR -> empty
167 rs :> r -> pure $ Cursor rs r mempty :| NonEmpty.toList z
168
169 -- ** Axis @ancestor@
170 axis_ancestor :: Axis a
171 axis_ancestor = axis_repeat_without_self axis_parent
172
173 axis_ancestor_or_self :: Axis a
174 axis_ancestor_or_self = axis_repeat axis_parent
175
176 axis_root :: Alternative f => AxisAlt f a
177 axis_root = Kleisli $ pure . List.last . runAxis axis_ancestor_or_self
178
179 -- ** Axis @descendant@
180 axis_descendant_or_self :: Axis a
181 axis_descendant_or_self =
182 Kleisli $ collect_child []
183 where
184 collect_child acc z =
185 z : maybe acc
186 (collect_following_first acc)
187 (runAxisAlt axis_child_first z)
188 collect_following_first acc z =
189 collect_child
190 (maybe acc
191 (collect_following_first acc)
192 (runAxisAlt axis_following_sibling_nearest z)
193 ) z
194
195 axis_descendant_or_self_reverse :: Axis a
196 axis_descendant_or_self_reverse = Kleisli go
197 where go z = z : List.concatMap go (List.reverse $ runAxis axis_child z)
198
199 axis_descendant :: Axis a
200 axis_descendant = Kleisli $ List.tail . runAxis axis_descendant_or_self
201
202 -- ** Axis @preceding@
203 axis_preceding_sibling :: Axis a
204 axis_preceding_sibling = axis_repeat_without_self axis_preceding_sibling_nearest
205
206 axis_preceding_sibling_nearest :: Alternative f => AxisAlt f a
207 axis_preceding_sibling_nearest = Kleisli $ \(Cursor ps t fs :| cs) ->
208 case Seq.viewr ps of
209 EmptyR -> empty
210 rs :> r -> pure $ Cursor rs r (t <| fs) :| cs
211
212 axis_preceding_sibling_farthest :: Alternative f => AxisAlt f a
213 axis_preceding_sibling_farthest = Kleisli $ \z@(Cursor ps t fs :| cs) ->
214 case Seq.viewl (ps |> t) of
215 EmptyL -> pure z
216 l :< ls -> pure $ Cursor mempty l (ls<>fs) :| cs
217
218 axis_preceding :: Axis a
219 axis_preceding =
220 axis_ancestor_or_self >>>
221 axis_preceding_sibling >>>
222 axis_descendant_or_self_reverse
223
224 -- ** Axis @following@
225 axis_following_sibling :: Axis a
226 axis_following_sibling = axis_repeat_without_self axis_following_sibling_nearest
227
228 axis_following_sibling_nearest :: Alternative f => AxisAlt f a
229 axis_following_sibling_nearest = Kleisli $ \(Cursor ps t fs :| cs) ->
230 case Seq.viewl fs of
231 EmptyL -> empty
232 l :< ls -> pure $ Cursor (ps |> t) l ls :| cs
233
234 axis_following_sibling_farthest :: Alternative f => AxisAlt f a
235 axis_following_sibling_farthest = Kleisli $ \z@(Cursor ps t fs :| cs) ->
236 case Seq.viewr (t <| fs) of
237 EmptyR -> pure z
238 rs :> r -> pure $ Cursor (ps<>rs) r mempty :| cs
239
240 axis_following :: Axis a
241 axis_following =
242 axis_ancestor_or_self >>>
243 axis_following_sibling >>>
244 axis_descendant_or_self
245
246 -- ** Axis @parent@
247 axis_parent :: Alternative f => AxisAlt f a
248 axis_parent = Kleisli $ \(Cursor ps t fs :| cs) ->
249 case cs of
250 Cursor ps' (Tree a _) fs' : cs' ->
251 pure $ Cursor ps' (Tree a $ (ps |> t) <> fs) fs' :| cs'
252 _ -> empty
253
254 -- * Utilities
255 listHead :: Alternative f => [a] -> f a
256 listHead [] = empty
257 listHead (a:_) = pure a