]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Lib/TreeMap/Zipper.hs
Ajout : Lib.TreeMap.Zipper : en prévision de collectes « à la XSLT » sur Chart.
[comptalang.git] / lib / Hcompta / Lib / TreeMap / Zipper.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE NamedFieldPuns #-}
3 {-# OPTIONS_GHC -fno-warn-tabs #-}
4
5 module Hcompta.Lib.TreeMap.Zipper where
6
7 import Control.Applicative ((<$>), (<*>), pure)
8 import Control.DeepSeq (NFData(..))
9 import Control.Monad (Monad(..), (>=>))
10 import Data.Bool
11 import Data.Eq (Eq)
12 import Data.Data (Data)
13 import Data.Foldable (Foldable, foldMap)
14 import Data.Functor (Functor(..))
15 import Data.Ord (Ord(..))
16 import qualified Data.List as List
17 import qualified Data.List.NonEmpty
18 import Data.List.NonEmpty (NonEmpty(..))
19 import Data.Map.Strict (Map)
20 import qualified Data.Map.Strict as Map
21 import Data.Maybe (Maybe(..), maybe, maybeToList)
22 import Data.Monoid (Monoid(..))
23 import qualified Data.Strict.Maybe as Strict
24 import Data.Traversable (Traversable(..))
25 import Data.Typeable (Typeable)
26 import Prelude (($), (.), Int, Num(..), Show, const, flip, id, seq)
27
28 import qualified Hcompta.Lib.Strict as Strict ()
29 import Hcompta.Lib.TreeMap (TreeMap(..))
30 import qualified Hcompta.Lib.TreeMap as TreeMap
31
32 -- * Type 'Zipper'
33
34 data Zipper k x
35 = Zipper
36 { zipper_path :: [Zipper_Step k x]
37 , zipper_curr :: TreeMap k x
38 } deriving (Data, Eq, Show, Typeable)
39
40 zipper :: TreeMap k x -> Zipper k x
41 zipper = Zipper []
42
43 zipper_root :: Ord k => Zipper k x -> TreeMap k x
44 zipper_root =
45 zipper_curr . List.last .
46 zipper_collect zipper_parent
47
48 -- * Type 'Zipper_Step'
49
50 data Zipper_Step k x
51 = Zipper_Step
52 { zipper_step_prec :: TreeMap k x
53 , zipper_step_self :: (k, TreeMap.Node k x)
54 , zipper_step_foll :: TreeMap k x
55 } deriving (Data, Eq, Show, Typeable)
56
57 -- * Axis
58
59 -- | Collect all 'Zipper's along a given axis,
60 -- including the first 'Zipper'.
61 zipper_collect :: (z -> Maybe z) -> z -> [z]
62 zipper_collect f z = z : maybe [] (zipper_collect f) (f z)
63
64 -- | Collect all 'Zipper's along a given axis,
65 -- excluding the first 'Zipper'.
66 zipper_collect_without_self :: (z -> Maybe z) -> z -> [z]
67 zipper_collect_without_self f z = maybe [] (zipper_collect f) (f z)
68
69 -- ** Axis self
70
71 zipper_self :: Ord k => Zipper k x -> Maybe (k, TreeMap.Node k x)
72 zipper_self z =
73 case z of
74 Zipper{ zipper_path=
75 Zipper_Step{zipper_step_self}
76 : _ } -> Just zipper_step_self
77 _ -> Nothing
78
79 -- ** Axis child
80
81 zipper_child :: Ord k => Zipper k x -> [Zipper k x]
82 zipper_child z =
83 maybeToList (zipper_child_first z)
84 >>= zipper_collect zipper_foll
85
86 zipper_child_at :: Ord k => k -> Zipper k x -> Maybe (Zipper k x)
87 zipper_child_at k (Zipper path (TreeMap m)) =
88 case Map.splitLookup k m of
89 (_, Nothing, _) -> Nothing
90 (ps, Just s, fs) ->
91 Just $ Zipper
92 { zipper_path = Zipper_Step (TreeMap ps) (k, s) (TreeMap fs) : path
93 , zipper_curr = TreeMap.node_descendants s
94 }
95
96 zipper_child_first :: Ord k => Zipper k x -> Maybe (Zipper k x)
97 zipper_child_first (Zipper path (TreeMap m)) =
98 case Map.minViewWithKey m of
99 Nothing -> Nothing
100 Just ((k', s'), fs') ->
101 Just $ Zipper
102 { zipper_path = Zipper_Step TreeMap.empty (k', s') (TreeMap fs') : path
103 , zipper_curr = TreeMap.node_descendants s'
104 }
105
106 zipper_child_last :: Ord k => Zipper k x -> Maybe (Zipper k x)
107 zipper_child_last (Zipper path (TreeMap m)) =
108 case Map.maxViewWithKey m of
109 Nothing -> Nothing
110 Just ((k', s'), ps') ->
111 Just $ Zipper
112 { zipper_path = Zipper_Step (TreeMap ps') (k', s') TreeMap.empty : path
113 , zipper_curr = TreeMap.node_descendants s'
114 }
115
116 -- ** Axis ancestor
117
118 zipper_ancestor :: Ord k => Zipper k x -> [Zipper k x]
119 zipper_ancestor = zipper_collect_without_self zipper_parent
120
121 zipper_ancestor_or_self :: Ord k => Zipper k x -> [Zipper k x]
122 zipper_ancestor_or_self = zipper_collect zipper_parent
123
124 -- ** Axis descendant
125
126 zipper_descendant_or_self :: Ord k => Zipper k x -> [Zipper k x]
127 zipper_descendant_or_self =
128 collect_child []
129 where
130 collect_child acc z =
131 z : maybe acc
132 (collect_foll acc)
133 (zipper_child_first z)
134 collect_foll acc z =
135 collect_child
136 (maybe acc
137 (collect_foll acc)
138 (zipper_foll z)
139 ) z
140
141 zipper_descendant_or_self_reverse :: Ord k => Zipper k x -> [Zipper k x]
142 zipper_descendant_or_self_reverse z =
143 z : List.concatMap
144 zipper_descendant_or_self_reverse
145 (List.reverse $ zipper_child z)
146
147 zipper_descendant :: Ord k => Zipper k x -> [Zipper k x]
148 zipper_descendant = List.tail . zipper_descendant_or_self
149
150 zipper_descendant_at :: Ord k => TreeMap.Path k -> Zipper k x -> Maybe (Zipper k x)
151 zipper_descendant_at (k:|ks) =
152 case ks of
153 [] -> zipper_child_at k
154 k':ks' -> zipper_child_at k >=> zipper_descendant_at (k':|ks')
155
156 -- ** Axis preceding
157
158 zipper_prec :: Ord k => Zipper k x -> Maybe (Zipper k x)
159 zipper_prec (Zipper path _curr) =
160 case path of
161 [] -> Nothing
162 Zipper_Step (TreeMap ps) (k, s) (TreeMap fs):steps ->
163 case Map.maxViewWithKey ps of
164 Nothing -> Nothing
165 Just ((k', s'), ps') ->
166 Just $ Zipper
167 { zipper_path = Zipper_Step (TreeMap ps')
168 (k', s')
169 (TreeMap $ Map.insert k s $ fs)
170 : steps
171 , zipper_curr = TreeMap.node_descendants s'
172 }
173
174 zipper_preceding :: Ord k => Zipper k x -> [Zipper k x]
175 zipper_preceding =
176 zipper_ancestor_or_self >=>
177 zipper_preceding_sibling >=>
178 zipper_descendant_or_self_reverse
179
180 zipper_preceding_sibling :: Ord k => Zipper k x -> [Zipper k x]
181 zipper_preceding_sibling = zipper_collect_without_self zipper_prec
182
183 -- ** Axis following
184
185 zipper_foll :: Ord k => Zipper k x -> Maybe (Zipper k x)
186 zipper_foll (Zipper path _curr) =
187 case path of
188 [] -> Nothing
189 Zipper_Step (TreeMap ps) (k, s) (TreeMap fs):steps ->
190 case Map.minViewWithKey fs of
191 Nothing -> Nothing
192 Just ((k', s'), fs') ->
193 Just $ Zipper
194 { zipper_path = Zipper_Step (TreeMap $ Map.insert k s $ ps)
195 (k', s')
196 (TreeMap fs')
197 : steps
198 , zipper_curr = TreeMap.node_descendants s'
199 }
200
201 zipper_following :: Ord k => Zipper k x -> [Zipper k x]
202 zipper_following =
203 zipper_ancestor_or_self >=>
204 zipper_following_sibling >=>
205 zipper_descendant_or_self
206
207 zipper_following_sibling :: Ord k => Zipper k x -> [Zipper k x]
208 zipper_following_sibling = zipper_collect_without_self zipper_foll
209
210 -- ** Axis parent
211
212 zipper_parent :: Ord k => Zipper k x -> Maybe (Zipper k x)
213 zipper_parent (Zipper path curr) =
214 case path of
215 [] -> Nothing
216 Zipper_Step (TreeMap ps) (k, s) (TreeMap fs):steps ->
217 let node = TreeMap.Node
218 { TreeMap.node_value = TreeMap.node_value s
219 , TreeMap.node_size = TreeMap.size curr
220 , TreeMap.node_descendants = curr
221 } in
222 Just $ Zipper
223 { zipper_path = steps
224 , zipper_curr = TreeMap $ Map.union ps $ Map.insert k node $ fs
225 }