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