1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE FunctionalDependencies #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE UndecidableInstances #-}
6 module T13429a where -- Originally FingerTree.hs from the ticket
8 import Data.Semigroup (Semigroup(..))
10 class (Monoid v) => Measured v a | a -> v where
11 measure :: a -> v
13 instance (Measured v a) => Measured v (Digit a) where
14 measure = foldMap measure
16 instance (Monoid v) => Measured v (Node v a) where
17 measure (Node2 v _ _) = v
18 measure (Node3 v _ _ _) = v
20 instance (Measured v a) => Measured v (FingerTree v a) where
21 measure Empty = mempty
22 measure (Single x) = measure x
23 measure (Deep v _ _ _) = v
25 data FingerTree v a
26 = Empty
27 | Single a
28 | Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a)
29 deriving Show
31 instance Foldable (FingerTree v) where
32 foldMap _ Empty = mempty
33 foldMap f (Single x) = f x
34 foldMap f (Deep _ pr m sf) =
35 foldMap f pr `mappend` foldMap (foldMap f) m `mappend` foldMap f sf
37 instance Measured v a => Semigroup (FingerTree v a) where
38 (<>) = (><)
40 instance Measured v a => Monoid (FingerTree v a) where
41 mempty = empty
43 empty :: Measured v a => FingerTree v a
44 empty = Empty
46 infixr 5 ><
47 infixr 5 <|
48 infixl 5 |>
50 (<|) :: (Measured v a) => a -> FingerTree v a -> FingerTree v a
51 a <| Empty = Single a
52 a <| Single b = deep (One a) Empty (One b)
53 a <| Deep v (Four b c d e) m sf = m `seq`
54 Deep (measure a `mappend` v) (Two a b) (node3 c d e <| m) sf
55 a <| Deep v pr m sf =
56 Deep (measure a `mappend` v) (consDigit a pr) m sf
58 consDigit :: a -> Digit a -> Digit a
59 consDigit a (One b) = Two a b
60 consDigit a (Two b c) = Three a b c
61 consDigit a (Three b c d) = Four a b c d
62 consDigit _ (Four _ _ _ _) = illegal_argument "consDigit"
64 (|>) :: (Measured v a) => FingerTree v a -> a -> FingerTree v a
65 Empty |> a = Single a
66 Single a |> b = deep (One a) Empty (One b)
67 Deep v pr m (Four a b c d) |> e = m `seq`
68 Deep (v `mappend` measure e) pr (m |> node3 a b c) (Two d e)
69 Deep v pr m sf |> x =
70 Deep (v `mappend` measure x) pr m (snocDigit sf x)
72 snocDigit :: Digit a -> a -> Digit a
73 snocDigit (One a) b = Two a b
74 snocDigit (Two a b) c = Three a b c
75 snocDigit (Three a b c) d = Four a b c d
76 snocDigit (Four _ _ _ _) _ = illegal_argument "snocDigit"
78 (><) :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a
79 (><) = appendTree0
81 appendTree0 :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a
82 appendTree0 Empty xs =
83 xs
84 appendTree0 xs Empty =
85 xs
86 appendTree0 (Single x) xs =
87 x <| xs
88 appendTree0 xs (Single x) =
89 xs |> x
90 appendTree0 (Deep _ pr1 m1 sf1) (Deep _ pr2 m2 sf2) =
91 deep pr1 (addDigits0 m1 sf1 pr2 m2) sf2
93 addDigits0 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
94 addDigits0 m1 (One a) (One b) m2 =
95 appendTree1 m1 (node2 a b) m2
96 addDigits0 m1 (One a) (Two b c) m2 =
97 appendTree1 m1 (node3 a b c) m2
98 addDigits0 m1 (One a) (Three b c d) m2 =
99 appendTree2 m1 (node2 a b) (node2 c d) m2
100 addDigits0 m1 (One a) (Four b c d e) m2 =
101 appendTree2 m1 (node3 a b c) (node2 d e) m2
102 addDigits0 m1 (Two a b) (One c) m2 =
103 appendTree1 m1 (node3 a b c) m2
104 addDigits0 m1 (Two a b) (Two c d) m2 =
105 appendTree2 m1 (node2 a b) (node2 c d) m2
106 addDigits0 m1 (Two a b) (Three c d e) m2 =
107 appendTree2 m1 (node3 a b c) (node2 d e) m2
108 addDigits0 m1 (Two a b) (Four c d e f) m2 =
109 appendTree2 m1 (node3 a b c) (node3 d e f) m2
110 addDigits0 m1 (Three a b c) (One d) m2 =
111 appendTree2 m1 (node2 a b) (node2 c d) m2
112 addDigits0 m1 (Three a b c) (Two d e) m2 =
113 appendTree2 m1 (node3 a b c) (node2 d e) m2
114 addDigits0 m1 (Three a b c) (Three d e f) m2 =
115 appendTree2 m1 (node3 a b c) (node3 d e f) m2
116 addDigits0 m1 (Three a b c) (Four d e f g) m2 =
117 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
118 addDigits0 m1 (Four a b c d) (One e) m2 =
119 appendTree2 m1 (node3 a b c) (node2 d e) m2
120 addDigits0 m1 (Four a b c d) (Two e f) m2 =
121 appendTree2 m1 (node3 a b c) (node3 d e f) m2
122 addDigits0 m1 (Four a b c d) (Three e f g) m2 =
123 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
124 addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
125 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
127 appendTree1 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a -> FingerTree v a
128 appendTree1 Empty a xs =
129 a <| xs
130 appendTree1 xs a Empty =
131 xs |> a
132 appendTree1 (Single x) a xs =
133 x <| a <| xs
134 appendTree1 xs a (Single x) =
135 xs |> a |> x
136 appendTree1 (Deep _ pr1 m1 sf1) a (Deep _ pr2 m2 sf2) =
137 deep pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
139 addDigits1 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
140 addDigits1 m1 (One a) b (One c) m2 =
141 appendTree1 m1 (node3 a b c) m2
142 addDigits1 m1 (One a) b (Two c d) m2 =
143 appendTree2 m1 (node2 a b) (node2 c d) m2
144 addDigits1 m1 (One a) b (Three c d e) m2 =
145 appendTree2 m1 (node3 a b c) (node2 d e) m2
146 addDigits1 m1 (One a) b (Four c d e f) m2 =
147 appendTree2 m1 (node3 a b c) (node3 d e f) m2
148 addDigits1 m1 (Two a b) c (One d) m2 =
149 appendTree2 m1 (node2 a b) (node2 c d) m2
150 addDigits1 m1 (Two a b) c (Two d e) m2 =
151 appendTree2 m1 (node3 a b c) (node2 d e) m2
152 addDigits1 m1 (Two a b) c (Three d e f) m2 =
153 appendTree2 m1 (node3 a b c) (node3 d e f) m2
154 addDigits1 m1 (Two a b) c (Four d e f g) m2 =
155 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
156 addDigits1 m1 (Three a b c) d (One e) m2 =
157 appendTree2 m1 (node3 a b c) (node2 d e) m2
158 addDigits1 m1 (Three a b c) d (Two e f) m2 =
159 appendTree2 m1 (node3 a b c) (node3 d e f) m2
160 addDigits1 m1 (Three a b c) d (Three e f g) m2 =
161 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
162 addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
163 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
164 addDigits1 m1 (Four a b c d) e (One f) m2 =
165 appendTree2 m1 (node3 a b c) (node3 d e f) m2
166 addDigits1 m1 (Four a b c d) e (Two f g) m2 =
167 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
168 addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
169 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
170 addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
171 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
173 appendTree2 :: (Measured v a) => FingerTree v a -> a -> a -> FingerTree v a -> FingerTree v a
174 appendTree2 Empty a b xs =
175 a <| b <| xs
176 appendTree2 xs a b Empty =
177 xs |> a |> b
178 appendTree2 (Single x) a b xs =
179 x <| a <| b <| xs
180 appendTree2 xs a b (Single x) =
181 xs |> a |> b |> x
182 appendTree2 (Deep _ pr1 m1 sf1) a b (Deep _ pr2 m2 sf2) =
183 deep pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
185 addDigits2 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
186 addDigits2 m1 (One a) b c (One d) m2 =
187 appendTree2 m1 (node2 a b) (node2 c d) m2
188 addDigits2 m1 (One a) b c (Two d e) m2 =
189 appendTree2 m1 (node3 a b c) (node2 d e) m2
190 addDigits2 m1 (One a) b c (Three d e f) m2 =
191 appendTree2 m1 (node3 a b c) (node3 d e f) m2
192 addDigits2 m1 (One a) b c (Four d e f g) m2 =
193 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
194 addDigits2 m1 (Two a b) c d (One e) m2 =
195 appendTree2 m1 (node3 a b c) (node2 d e) m2
196 addDigits2 m1 (Two a b) c d (Two e f) m2 =
197 appendTree2 m1 (node3 a b c) (node3 d e f) m2
198 addDigits2 m1 (Two a b) c d (Three e f g) m2 =
199 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
200 addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
201 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
202 addDigits2 m1 (Three a b c) d e (One f) m2 =
203 appendTree2 m1 (node3 a b c) (node3 d e f) m2
204 addDigits2 m1 (Three a b c) d e (Two f g) m2 =
205 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
206 addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
207 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
208 addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
209 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
210 addDigits2 m1 (Four a b c d) e f (One g) m2 =
211 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
212 addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
213 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
214 addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
215 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
216 addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
217 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
219 appendTree3 :: (Measured v a) => FingerTree v a -> a -> a -> a -> FingerTree v a -> FingerTree v a
220 appendTree3 Empty a b c xs =
221 a <| b <| c <| xs
222 appendTree3 xs a b c Empty =
223 xs |> a |> b |> c
224 appendTree3 (Single x) a b c xs =
225 x <| a <| b <| c <| xs
226 appendTree3 xs a b c (Single x) =
227 xs |> a |> b |> c |> x
228 appendTree3 (Deep _ pr1 m1 sf1) a b c (Deep _ pr2 m2 sf2) =
229 deep pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
231 addDigits3 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
232 addDigits3 m1 (One a) b c d (One e) m2 =
233 appendTree2 m1 (node3 a b c) (node2 d e) m2
234 addDigits3 m1 (One a) b c d (Two e f) m2 =
235 appendTree2 m1 (node3 a b c) (node3 d e f) m2
236 addDigits3 m1 (One a) b c d (Three e f g) m2 =
237 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
238 addDigits3 m1 (One a) b c d (Four e f g h) m2 =
239 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
240 addDigits3 m1 (Two a b) c d e (One f) m2 =
241 appendTree2 m1 (node3 a b c) (node3 d e f) m2
242 addDigits3 m1 (Two a b) c d e (Two f g) m2 =
243 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
244 addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
245 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
246 addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
247 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
248 addDigits3 m1 (Three a b c) d e f (One g) m2 =
249 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
250 addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
251 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
252 addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
253 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
254 addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
255 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
256 addDigits3 m1 (Four a b c d) e f g (One h) m2 =
257 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
258 addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
259 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
260 addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
261 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
262 addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
263 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
265 appendTree4 :: (Measured v a) => FingerTree v a -> a -> a -> a -> a -> FingerTree v a -> FingerTree v a
266 appendTree4 Empty a b c d xs =
267 a <| b <| c <| d <| xs
268 appendTree4 xs a b c d Empty =
269 xs |> a |> b |> c |> d
270 appendTree4 (Single x) a b c d xs =
271 x <| a <| b <| c <| d <| xs
272 appendTree4 xs a b c d (Single x) =
273 xs |> a |> b |> c |> d |> x
274 appendTree4 (Deep _ pr1 m1 sf1) a b c d (Deep _ pr2 m2 sf2) =
275 deep pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
277 addDigits4 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
278 addDigits4 m1 (One a) b c d e (One f) m2 =
279 appendTree2 m1 (node3 a b c) (node3 d e f) m2
280 addDigits4 m1 (One a) b c d e (Two f g) m2 =
281 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
282 addDigits4 m1 (One a) b c d e (Three f g h) m2 =
283 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
284 addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
285 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
286 addDigits4 m1 (Two a b) c d e f (One g) m2 =
287 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
288 addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
289 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
290 addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
291 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
292 addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
293 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
294 addDigits4 m1 (Three a b c) d e f g (One h) m2 =
295 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
296 addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
297 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
298 addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
299 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
300 addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
301 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
302 addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
303 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
304 addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
305 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
306 addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
307 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
308 addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
309 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
311 deep :: (Measured v a) =>
312 Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a
313 deep pr m sf = Deep ((measure pr `mappendVal` m) `mappend` measure sf) pr m sf
315 data Digit a
316 = One a
317 | Two a a
318 | Three a a a
319 | Four a a a a
320 deriving Show
322 instance Foldable Digit where
323 foldMap f (One a) = f a
324 foldMap f (Two a b) = f a `mappend` f b
325 foldMap f (Three a b c) = f a `mappend` f b `mappend` f c
326 foldMap f (Four a b c d) = f a `mappend` f b `mappend` f c `mappend` f d
328 data Node v a = Node2 !v a a | Node3 !v a a a
329 deriving Show
331 instance Foldable (Node v) where
332 foldMap f (Node2 _ a b) = f a `mappend` f b
333 foldMap f (Node3 _ a b c) = f a `mappend` f b `mappend` f c
335 node2 :: (Measured v a) => a -> a -> Node v a
336 node2 a b = Node2 (measure a `mappend` measure b) a b
338 node3 :: (Measured v a) => a -> a -> a -> Node v a
339 node3 a b c = Node3 (measure a `mappend` measure b `mappend` measure c) a b c
341 mappendVal :: (Measured v a) => v -> FingerTree v a -> v
342 mappendVal v Empty = v
343 mappendVal v t = v `mappend` measure t
345 illegal_argument :: String -> a
346 illegal_argument name =
347 error \$ "Logic error: " ++ name ++ " called with illegal argument"