1 module Data.TreeSeq.Strict.Zipper where
3 import Control.Arrow (Kleisli(..))
4 import Control.Applicative (Applicative(..), Alternative(..))
5 import Control.Monad (Monad(..), (>=>))
8 import Data.Function (($), (.))
9 import Data.Functor ((<$>))
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
23 import Data.TreeSeq.Strict (Trees, Tree(..))
26 type Zipper k a = NonEmpty (Cursor k a)
28 -- | Return a 'Zipper' starting at the given 'Tree'.
29 zipper :: Tree k a -> Zipper k a
30 zipper t = Cursor mempty t mempty :| []
32 -- | Return a 'Zipper' starting at the left-most 'Tree' of the given 'Trees'.
33 zippers :: Trees k a -> [Zipper k a]
37 l :< ls -> pure $ Cursor mempty l ls :| []
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
43 -- | Return the keys within the 'TreeN' nodes
44 -- leading to the current 'Cursor' of the given 'Zipper'.
45 zipath :: Zipper k x -> [k]
48 NonEmpty.toList cs >>= \c ->
53 -- | Return the 'Tree' currently under the 'Cursor'.
54 current :: Zipper k a -> Tree k a
55 current (Cursor _ t _ :| _) = t
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
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
68 { cursor_precedings :: Trees k a
69 , cursor_self :: Tree k a
70 , cursor_followings :: Trees k a
71 } deriving (Eq, Show, Typeable)
74 type Axis k a = Zipper k a -> [Zipper k a]
76 -- ** Type 'KleisliAxis'
77 type KleisliAxis k a = Kleisli [] (Zipper k a) (Zipper k a)
80 -- | Like 'Axis', but generalized with 'Alternative'.
82 -- Useful to return a 'Maybe' instead of a list.
83 type AxisAlt f k a = Zipper k a -> f (Zipper k a)
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)
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)
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`
101 axis_filter_current :: Axis k a -> (Tree k a -> Bool) -> Axis k a
102 axis_filter_current axis f c = List.filter (f . current) (axis c)
103 infixl 5 `axis_filter_current`
106 axis_at :: Alternative f => Axis k a -> Int -> AxisAlt f k a
108 case List.drop i $ axis c of
114 axis_self :: Applicative f => AxisAlt f k a
118 axis_child :: Axis k a
120 axis_child_first c >>=
121 axis_repeat axis_following_sibling_nearest
123 axis_child_lookup_first :: Alternative f => (k -> Bool) -> AxisAlt f k a
124 axis_child_lookup_first fk c = listHead $ axis_child_lookup fk c
126 axis_child_lookup :: (k -> Bool) -> Axis k a
127 axis_child_lookup fk cs@(Cursor _ps t _fs :| _) =
128 (<$> Seq.findIndicesL flt ns) $ \i ->
129 let (ps, ps') = Seq.splitAt i ns in
130 case Seq.viewl ps' of
132 l :< ls -> Cursor ps l ls :| NonEmpty.toList cs
135 flt (TreeN k _) = fk k
138 axis_child_first :: Alternative f => AxisAlt f k a
139 axis_child_first cs@(Cursor _ps t _fs :| _) =
140 case Seq.viewl $ nodesTree t of
142 l :< ls -> pure $ Cursor mempty l ls :| NonEmpty.toList cs
144 axis_child_last :: Alternative f => AxisAlt f k a
145 axis_child_last cs@(Cursor _ps t _fs :| _) =
146 case Seq.viewr $ nodesTree t of
148 rs :> r -> pure $ Cursor rs r mempty :| NonEmpty.toList cs
150 -- ** Axis @ancestor@
151 axis_ancestor :: Axis k a
152 axis_ancestor = axis_repeat_without_self axis_parent
154 axis_ancestor_or_self :: Axis k a
155 axis_ancestor_or_self = axis_repeat axis_parent
157 axis_root :: Alternative f => AxisAlt f k a
158 axis_root = pure . List.last . axis_ancestor_or_self
160 -- ** Axis @descendant@
161 axis_descendant_or_self :: Axis k a
162 axis_descendant_or_self =
165 collect_child acc c =
167 (collect_following_first acc)
169 collect_following_first acc c =
172 (collect_following_first acc)
173 (axis_following_sibling_nearest c)
176 axis_descendant_or_self_reverse :: Axis k a
177 axis_descendant_or_self_reverse c =
180 axis_descendant_or_self_reverse
181 (List.reverse $ axis_child c)
183 axis_descendant :: Axis k a
184 axis_descendant = List.tail . axis_descendant_or_self
186 -- ** Axis @preceding@
187 axis_preceding_sibling :: Axis k a
188 axis_preceding_sibling = axis_repeat_without_self axis_preceding_sibling_nearest
190 axis_preceding_sibling_nearest :: Alternative f => AxisAlt f k a
191 axis_preceding_sibling_nearest (Cursor ps t fs :| cs) =
194 rs :> r -> pure $ Cursor rs r (t <| fs) :| cs
196 axis_preceding_sibling_farthest :: Alternative f => AxisAlt f k a
197 axis_preceding_sibling_farthest z@(Cursor ps t fs :| cs) =
198 case Seq.viewl (ps |> t) of
200 l :< ls -> pure $ Cursor mempty l (ls<>fs) :| cs
202 axis_preceding :: Axis k a
204 axis_ancestor_or_self >=>
205 axis_preceding_sibling >=>
206 axis_descendant_or_self_reverse
208 -- ** Axis @following@
209 axis_following_sibling :: Axis k a
210 axis_following_sibling = axis_repeat_without_self axis_following_sibling_nearest
212 axis_following_sibling_nearest :: Alternative f => AxisAlt f k a
213 axis_following_sibling_nearest (Cursor ps t fs :| cs) =
216 l :< ls -> pure $ Cursor (ps |> t) l ls :| cs
218 axis_following_sibling_farthest :: Alternative f => AxisAlt f k a
219 axis_following_sibling_farthest z@(Cursor ps t fs :| cs) =
220 case Seq.viewr (t <| fs) of
222 rs :> r -> pure $ Cursor (ps<>rs) r mempty :| cs
224 axis_following :: Axis k a
226 axis_ancestor_or_self >=>
227 axis_following_sibling >=>
228 axis_descendant_or_self
231 axis_parent :: Alternative f => AxisAlt f k a
232 axis_parent (Cursor ps t fs :| cs) =
234 Cursor ps' (TreeN k _) fs' : cs' ->
235 pure $ Cursor ps' (TreeN k $ (ps |> t) <> fs) fs' :| cs'
239 nodesTree :: Tree k a -> Trees k a
240 nodesTree Tree0{} = mempty
241 nodesTree (TreeN _k ts) = ts
243 listHead :: Alternative f => [a] -> f a
245 listHead (a:_) = pure a