]> Git — Sourcephile - haskell/treemap.git/blob - Data/TreeMap/Strict/Zipper.hs
stack: bump to lts-12.25
[haskell/treemap.git] / Data / TreeMap / Strict / Zipper.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE NamedFieldPuns #-}
3 {-# OPTIONS_GHC -fno-warn-tabs #-}
4
5 module Data.TreeMap.Strict.Zipper where
6
7 import Control.Applicative (Applicative(..), Alternative(..))
8 import Control.Monad (Monad(..), (>=>))
9 import Data.Bool (Bool)
10 import Data.Data (Data)
11 import Data.Eq (Eq)
12 import Data.Function (($), (.))
13 import Data.Functor ((<$>))
14 import Data.Int (Int)
15 import Data.Maybe (Maybe(..), maybe)
16 import Data.NonNull (nuncons)
17 import Data.Ord (Ord(..))
18 import Data.Tuple (fst)
19 import Data.Typeable (Typeable)
20 import Text.Show (Show(..))
21 import qualified Data.List as List
22 import qualified Data.Map.Strict as Map
23
24 import Data.TreeMap.Strict (TreeMap(..), Node(..), Path)
25 import qualified Data.TreeMap.Strict as TreeMap
26
27 -- * Type 'Zipper'
28 data Zipper k a
29 = Zipper
30 { zipper_path :: [Cursor k a]
31 , zipper_curr :: TreeMap k a
32 } deriving (Data, Eq, Show, Typeable)
33
34 zipper :: TreeMap k a -> Zipper k a
35 zipper = Zipper []
36
37 root :: Ord k => Zipper k a -> TreeMap k a
38 root = zipper_curr . List.last . axis_ancestor_or_self
39
40 zipath :: Zipper k a -> [k]
41 zipath z =
42 fst . cursor_self <$>
43 List.reverse (zipper_path z)
44
45 current :: Zipper k a -> TreeMap k a
46 current = zipper_curr
47
48 -- * Type 'Cursor'
49 data Cursor k a
50 = Cursor
51 { cursor_precedings :: TreeMap k a
52 , cursor_self :: (k, Node k a)
53 , cursor_followings :: TreeMap k a
54 } deriving (Data, Eq, Show, Typeable)
55
56 -- * Axis
57 type Axis k a = Zipper k a -> [Zipper k a]
58 type AxisAlt f k a = Zipper k a -> f (Zipper k a)
59
60 -- | Collect all 'Zipper's along a given axis,
61 -- including the first 'Zipper'.
62 axis_collect :: (z -> Maybe z) -> z -> [z]
63 axis_collect f z = z : maybe [] (axis_collect f) (f z)
64
65 -- | Collect all 'Zipper's along a given axis,
66 -- excluding the first 'Zipper'.
67 axis_collect_without_self :: (z -> Maybe z) -> z -> [z]
68 axis_collect_without_self f z = maybe [] (axis_collect f) (f z)
69
70 -- ** Axis @self@
71 axis_self :: Zipper k a -> Node k a
72 axis_self z =
73 case z of
74 Zipper{ zipper_path=
75 Cursor{cursor_self=(_, nod)}
76 : _ } -> nod
77 _ -> TreeMap.nodeEmpty
78
79 -- ** Axis @child@
80 axis_child :: Ord k => Axis k a
81 axis_child z =
82 axis_child_first z >>=
83 axis_collect axis_following_sibling_nearest
84
85 axis_child_lookup
86 :: (Ord k, Alternative f)
87 => k -> AxisAlt f k a
88 axis_child_lookup k (Zipper path (TreeMap m)) =
89 case Map.splitLookup k m of
90 (_, Nothing, _) -> empty
91 (ps, Just s, fs) ->
92 pure Zipper
93 { zipper_path = Cursor (TreeMap ps) (k, s) (TreeMap fs) : path
94 , zipper_curr = TreeMap.node_descendants s
95 }
96
97 axis_child_lookups :: (Ord k, Alternative f, Monad f) => Path k -> AxisAlt f k a
98 axis_child_lookups p =
99 case nuncons p of
100 (k, Nothing) -> axis_child_lookup k
101 (k, Just p') -> axis_child_lookup k >=> axis_child_lookups p'
102
103 axis_child_first :: Alternative f => AxisAlt f k a
104 axis_child_first (Zipper path (TreeMap m)) =
105 case Map.minViewWithKey m of
106 Nothing -> empty
107 Just ((k', s'), fs') ->
108 pure Zipper
109 { zipper_path = Cursor TreeMap.empty (k', s') (TreeMap fs') : path
110 , zipper_curr = TreeMap.node_descendants s'
111 }
112
113 axis_child_last :: Alternative f => AxisAlt f k a
114 axis_child_last (Zipper path (TreeMap m)) =
115 case Map.maxViewWithKey m of
116 Nothing -> empty
117 Just ((k', s'), ps') ->
118 pure Zipper
119 { zipper_path = Cursor (TreeMap ps') (k', s') TreeMap.empty : path
120 , zipper_curr = TreeMap.node_descendants s'
121 }
122
123 -- ** Axis @ancestor@
124 axis_ancestor :: Ord k => Axis k a
125 axis_ancestor = axis_collect_without_self axis_parent
126
127 axis_ancestor_or_self :: Ord k => Axis k a
128 axis_ancestor_or_self = axis_collect axis_parent
129
130 -- ** Axis @descendant@
131 axis_descendant_or_self :: Ord k => Axis k a
132 axis_descendant_or_self =
133 collect_child []
134 where
135 collect_child acc z =
136 z : maybe acc
137 (collect_foll acc)
138 (axis_child_first z)
139 collect_foll acc z =
140 collect_child
141 (maybe acc
142 (collect_foll acc)
143 (axis_following_sibling_nearest z)
144 ) z
145
146 axis_descendant_or_self_reverse :: Ord k => Axis k a
147 axis_descendant_or_self_reverse z =
148 z : List.concatMap
149 axis_descendant_or_self_reverse
150 (List.reverse $ axis_child z)
151
152 axis_descendant :: Ord k => Axis k a
153 axis_descendant = List.tail . axis_descendant_or_self
154
155 -- ** Axis @preceding@
156 axis_preceding_sibling_nearest :: (Ord k, Alternative f) => AxisAlt f k a
157 axis_preceding_sibling_nearest (Zipper path _curr) =
158 case path of
159 [] -> empty
160 Cursor (TreeMap ps) (k, s) (TreeMap fs):steps ->
161 case Map.maxViewWithKey ps of
162 Nothing -> empty
163 Just ((k', s'), ps') ->
164 pure Zipper
165 { zipper_path = Cursor (TreeMap ps')
166 (k', s')
167 (TreeMap $ Map.insert k s fs)
168 : steps
169 , zipper_curr = TreeMap.node_descendants s'
170 }
171
172 axis_preceding_sibling :: Ord k => Axis k a
173 axis_preceding_sibling = axis_collect_without_self axis_preceding_sibling_nearest
174
175 axis_preceding :: Ord k => Axis k a
176 axis_preceding =
177 axis_ancestor_or_self >=>
178 axis_preceding_sibling >=>
179 axis_descendant_or_self_reverse
180
181 -- ** Axis @following@
182 axis_following_sibling_nearest :: (Ord k, Alternative f) => AxisAlt f k a
183 axis_following_sibling_nearest (Zipper path _curr) =
184 case path of
185 [] -> empty
186 Cursor (TreeMap ps) (k, s) (TreeMap fs):steps ->
187 case Map.minViewWithKey fs of
188 Nothing -> empty
189 Just ((k', s'), fs') ->
190 pure Zipper
191 { zipper_path = Cursor (TreeMap $ Map.insert k s ps)
192 (k', s')
193 (TreeMap fs')
194 : steps
195 , zipper_curr = TreeMap.node_descendants s'
196 }
197
198 axis_following_sibling :: Ord k => Axis k a
199 axis_following_sibling = axis_collect_without_self axis_following_sibling_nearest
200
201 axis_following :: Ord k => Axis k a
202 axis_following =
203 axis_ancestor_or_self >=>
204 axis_following_sibling >=>
205 axis_descendant_or_self
206
207 -- ** Axis @parent@
208 axis_parent :: (Ord k, Alternative f) => AxisAlt f k a
209 axis_parent (Zipper path curr) =
210 case path of
211 [] -> empty
212 Cursor (TreeMap ps) (k, s) (TreeMap fs):steps ->
213 let nod = TreeMap.node (TreeMap.node_value s) curr in
214 pure Zipper
215 { zipper_path = steps
216 , zipper_curr = TreeMap $ Map.union ps $ Map.insert k nod fs
217 }
218
219 -- ** Filter
220 axis_filter :: Axis k a -> (Zipper k a -> Bool) -> Axis k a
221 axis_filter axis p z = List.filter p (axis z)
222 infixl 5 `axis_filter`
223
224 axis_at :: Alternative f => Axis k a -> Int -> AxisAlt f k a
225 axis_at axis n z = case List.drop n (axis z) of {[] -> empty; a:_ -> pure a}
226 infixl 5 `axis_at`
227
228 zipper_null :: Axis k a -> Zipper k a -> Bool
229 zipper_null axis = List.null . axis