Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit aae3ecc

Browse files
committed
Add some more
1 parent 64d3016 commit aae3ecc

File tree

3 files changed

+135
-34
lines changed

3 files changed

+135
-34
lines changed

‎containers-tests/containers-tests.cabal

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -106,7 +106,6 @@ library
106106
Data.Map.Strict.Internal
107107
Data.Sequence
108108
Data.Sequence.Internal
109-
Data.Sequence.Internal.Depth
110109
Data.Sequence.Internal.Sorting
111110
Data.Set
112111
Data.Set.Internal

‎containers/src/Data/Sequence/Internal.hs

Lines changed: 127 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -3454,6 +3454,48 @@ foldMapWithIndex f' (Seq xs') = foldMapWithIndexTreeE (lift_elem f') 0 xs'
34543454
-- access to the index of each element.
34553455
--
34563456
-- @since 0.5.8
3457+
#ifdef __GLASGOW_HASKELL__
3458+
traverseWithIndex :: forall f a b. Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)
3459+
traverseWithIndex f (Seq t) = Seq <$> traverseWithIndexFT Bottom2 0 t
3460+
where
3461+
traverseWithIndexFT :: Depth2 (Elem a) t (Elem b) u -> Int -> FingerTree t -> f (FingerTree u)
3462+
traverseWithIndexFT !_ !_ EmptyT = pure EmptyT
3463+
traverseWithIndexFT d s (Single xs) = Single <$> traverseWithIndexBlob d s xs
3464+
traverseWithIndexFT d s (Deep s' pr m sf) = case depthSized2 d of { Sizzy ->
3465+
liftA3 (Deep s')
3466+
(traverseWithIndexDigit (traverseWithIndexBlob d) s pr)
3467+
(traverseWithIndexFT (Deeper2 d) sPspr m)
3468+
(traverseWithIndexDigit (traverseWithIndexBlob d) sPsprm sf)
3469+
where
3470+
!sPspr = s + size pr
3471+
!sPsprm = sPspr + size m
3472+
}
3473+
3474+
traverseWithIndexBlob :: Depth2 (Elem a) t (Elem b) u -> Int -> t -> f u
3475+
traverseWithIndexBlob Bottom2 k (Elem a) = Elem <$> f k a
3476+
traverseWithIndexBlob (Deeper2 yop) k (Node2 s t1 t2) =
3477+
liftA2 (Node2 s)
3478+
(traverseWithIndexBlob yop k t1)
3479+
(traverseWithIndexBlob yop (k + sizeBlob2 yop t1) t2)
3480+
traverseWithIndexBlob (Deeper2 yop) k (Node3 s t1 t2 t3) =
3481+
liftA3 (Node3 s)
3482+
(traverseWithIndexBlob yop k t1)
3483+
(traverseWithIndexBlob yop (k + st1) t2)
3484+
(traverseWithIndexBlob yop (k + st1t2) t3)
3485+
where
3486+
st1 = sizeBlob2 yop t1
3487+
st1t2 = st1 + sizeBlob2 yop t2
3488+
3489+
{-# INLINABLE [1] traverseWithIndex #-}
3490+
3491+
{-# RULES
3492+
"travWithIndex/mapWithIndex" forall f g xs . traverseWithIndex f (mapWithIndex g xs) =
3493+
traverseWithIndex (\k a -> f k (g k a)) xs
3494+
"travWithIndex/fmapSeq" forall f g xs . traverseWithIndex f (fmapSeq g xs) =
3495+
traverseWithIndex (\k a -> f k (g a)) xs
3496+
#-}
3497+
3498+
#else
34573499
traverseWithIndex :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)
34583500
traverseWithIndex f' (Seq xs') = Seq <$> traverseWithIndexTreeE (\s (Elem a) -> Elem <$> f' s a) 0 xs'
34593501
where
@@ -3491,24 +3533,6 @@ traverseWithIndex f' (Seq xs') = Seq <$> traverseWithIndexTreeE (\s (Elem a) ->
34913533
traverseWithIndexDigitN :: Applicative f => (Int -> Node a -> f b) -> Int -> Digit (Node a) -> f (Digit b)
34923534
traverseWithIndexDigitN f i t = traverseWithIndexDigit f i t
34933535

3494-
{-# INLINE traverseWithIndexDigit #-}
3495-
traverseWithIndexDigit :: (Applicative f, Sized a) => (Int -> a -> f b) -> Int -> Digit a -> f (Digit b)
3496-
traverseWithIndexDigit f !s (One a) = One <$> f s a
3497-
traverseWithIndexDigit f s (Two a b) = liftA2 Two (f s a) (f sPsa b)
3498-
where
3499-
!sPsa = s + size a
3500-
traverseWithIndexDigit f s (Three a b c) =
3501-
liftA3 Three (f s a) (f sPsa b) (f sPsab c)
3502-
where
3503-
!sPsa = s + size a
3504-
!sPsab = sPsa + size b
3505-
traverseWithIndexDigit f s (Four a b c d) =
3506-
liftA3 Four (f s a) (f sPsa b) (f sPsab c) <*> f sPsabc d
3507-
where
3508-
!sPsa = s + size a
3509-
!sPsab = sPsa + size b
3510-
!sPsabc = sPsab + size c
3511-
35123536
traverseWithIndexNodeE :: Applicative f => (Int -> Elem a -> f b) -> Int -> Node (Elem a) -> f (Node b)
35133537
traverseWithIndexNodeE f i t = traverseWithIndexNode f i t
35143538

@@ -3526,21 +3550,27 @@ traverseWithIndex f' (Seq xs') = Seq <$> traverseWithIndexTreeE (\s (Elem a) ->
35263550
!sPsa = s + size a
35273551
!sPsab = sPsa + size b
35283552

3529-
3530-
#ifdef __GLASGOW_HASKELL__
3531-
{-# INLINABLE [1] traverseWithIndex #-}
3532-
#else
35333553
{-# INLINE [1] traverseWithIndex #-}
35343554
#endif
35353555

3536-
#ifdef __GLASGOW_HASKELL__
3537-
{-# RULES
3538-
"travWithIndex/mapWithIndex" forall f g xs . traverseWithIndex f (mapWithIndex g xs) =
3539-
traverseWithIndex (\k a -> f k (g k a)) xs
3540-
"travWithIndex/fmapSeq" forall f g xs . traverseWithIndex f (fmapSeq g xs) =
3541-
traverseWithIndex (\k a -> f k (g a)) xs
3542-
#-}
3543-
#endif
3556+
{-# INLINE traverseWithIndexDigit #-}
3557+
traverseWithIndexDigit :: (Applicative f, Sized a) => (Int -> a-> f b) -> Int -> Digit a -> f (Digit b)
3558+
traverseWithIndexDigit f !s (One a) = One <$> f s a
3559+
traverseWithIndexDigit f s (Two a b) = liftA2 Two (f s a) (f sPsa b)
3560+
where
3561+
!sPsa = s + size a
3562+
traverseWithIndexDigit f s (Three a b c) =
3563+
liftA3 Three (f s a) (f sPsa b) (f sPsab c)
3564+
where
3565+
!sPsa = s + size a
3566+
!sPsab = sPsa + size b
3567+
traverseWithIndexDigit f s (Four a b c d) =
3568+
liftA3 Four (f s a) (f sPsa b) (f sPsab c) <*> f sPsabc d
3569+
where
3570+
!sPsa = s + size a
3571+
!sPsab = sPsa + size b
3572+
!sPsabc = sPsab + size c
3573+
35443574
{-
35453575
It might be nice to be able to rewrite
35463576
@@ -5149,12 +5179,79 @@ zipWith f s1 s2 = zipWith' f s1' s2'
51495179
s1' = take minLen s1
51505180
s2' = take minLen s2
51515181

5182+
#ifdef __GLASGOW_HASKELL__
5183+
-- | A version of zipWith that assumes the sequences have the same length.
5184+
zipWith' :: forall a b c. (a -> b -> c) -> Seq a -> Seq b -> Seq c
5185+
zipWith' f = \(Seq t1) s2 -> Seq (zipFT Bottom2 t1 s2)
5186+
where
5187+
5188+
zipBlob :: Depth2 (Elem a) t (Elem c) v -> t -> Seq b -> v
5189+
zipBlob Bottom2 (Elem a) s2
5190+
| Seq (Single (Elem b)) <- s2 = Elem (f a b)
5191+
| otherwise = error "zipWith': invariant failure"
5192+
zipBlob (Deeper2 w) (Node2 s (x :: q) y) s2 = Node2 s (zipBlob w x s2l) (zipBlob w y s2r)
5193+
where
5194+
sz :: q -> Int
5195+
sz = case w of
5196+
Bottom2 -> size
5197+
Deeper2 _ -> size
5198+
(s2l, s2r) = splitAt (sz x) s2
5199+
zipBlob (Deeper2 w) (Node3 s (x :: q) y z) s2 = Node3 s (zipBlob w x s2l) (zipBlob w y s2c) (zipBlob w z s2r)
5200+
where
5201+
sz :: q -> Int
5202+
sz = case w of
5203+
Bottom2 -> size
5204+
Deeper2 _ -> size
5205+
(s2l, s2rem) = splitAt (sz x) s2
5206+
(s2c, s2r) = splitAt (sz y) s2rem
5207+
5208+
zipDigit :: forall t v. Depth2 (Elem a) t (Elem c) v -> Digit t -> Seq b -> Digit v
5209+
zipDigit p = \d s2 ->
5210+
case d of
5211+
One t -> One (zipBlob p t s2)
5212+
Two t u -> Two (zipBlob p t s2l) (zipBlob p u s2r)
5213+
where
5214+
(s2l, s2r) = splitAt (sz t) s2
5215+
Three t u v -> Three (zipBlob p t s2l) (zipBlob p u s2c) (zipBlob p v s2r)
5216+
where
5217+
(s2l, s2rem) = splitAt (sz t) s2
5218+
(s2c, s2r) = splitAt (sz u) s2rem
5219+
Four t u v w -> Four (zipBlob p t s21) (zipBlob p u s22) (zipBlob p v s23) (zipBlob p w s24)
5220+
where
5221+
(s2l, s2r) = splitAt (sz t + sz u) s2
5222+
(s21, s22) = splitAt (sz t) s2l
5223+
(s23, s24) = splitAt (sz v) s2r
5224+
where
5225+
sz :: t -> Int
5226+
sz = case p of
5227+
Bottom2 -> size
5228+
Deeper2 _ -> size
5229+
5230+
zipFT :: forall t v. Depth2 (Elem a) t (Elem c) v -> FingerTree t -> Seq b -> FingerTree v
5231+
zipFT !_ EmptyT !_ = EmptyT
5232+
zipFT w (Single t) s2 = Single (zipBlob w t s2)
5233+
zipFT w (Deep s pr m sf) s2 =
5234+
Deep s
5235+
(zipDigit w pr s2l)
5236+
(zipFT (Deeper2 w) m s2c)
5237+
(zipDigit w sf s2r)
5238+
where
5239+
szd :: Digit t -> Int
5240+
szd = case w of
5241+
Bottom2 -> size
5242+
Deeper2 _ -> size
5243+
(s2l, s2rem) = splitAt (szd pr) s2
5244+
(s2c, s2r) = splitAt (size m) s2rem
5245+
5246+
5247+
#else
51525248
-- | A version of zipWith that assumes the sequences have the same length.
51535249
zipWith' :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
51545250
zipWith' f s1 s2 = splitMap uncheckedSplitAt goLeaf s2 s1
51555251
where
51565252
goLeaf (Seq (Single (Elem b))) a = f a b
51575253
goLeaf _ _ = error "Data.Sequence.zipWith'.goLeaf internal error: not a singleton"
5254+
#endif
51585255

51595256
-- | \( O(\min(n_1,n_2,n_3)) \). 'zip3' takes three sequences and returns a
51605257
-- sequence of triples, analogous to 'zip'.

‎containers/src/Data/Sequence/Internal/Depth.hs

Lines changed: 8 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,3 @@
1-
{-# OPTIONS_GHC -ddump-prep #-}
21
{-# LANGUAGE GADTs #-}
32
{-# LANGUAGE KindSignatures #-}
43
{-# LANGUAGE PatternSynonyms #-}
@@ -64,6 +63,7 @@ pattern Bottom :: () => t ~ a => Depth_ node a t
6463
pattern Bottom <- (checkBottom -> AtBottom)
6564
where
6665
Bottom = Depth_ 0
66+
{-# INLINE Bottom #-}
6767

6868
-- | The depth is non-zero.
6969
pattern Deeper :: () => t ~ node t' => Depth_ node a t' -> Depth_ node a t
@@ -72,6 +72,7 @@ pattern Deeper d <- (checkBottom -> NotBottom d)
7272
Deeper (Depth_ d)
7373
| d == maxBound = error "Depth overflow"
7474
| otherwise = Depth_ (d + 1)
75+
{-# INLINE Deeper #-}
7576

7677
{-# COMPLETE Bottom, Deeper #-}
7778

@@ -82,14 +83,15 @@ data CheckedBottom node a t where
8283
checkBottom :: Depth_ node a t -> CheckedBottom node a t
8384
checkBottom (Depth_ 0) = unsafeCoerce AtBottom
8485
checkBottom (Depth_ d) = unsafeCoerce (NotBottom (Depth_ (d - 1)))
86+
{-# INLINE checkBottom #-}
8587

8688

8789
-- | A version of 'Depth_' for implementing traversals. Conceptually,
8890
--
8991
-- @
9092
-- data Depth2_ node a t b u where
91-
-- Bottom2 :: Depth_ node a a b b
92-
-- Deeper2 :: !(Depth_ node a t b u) -> Depth_ node a (node t) b (node u)
93+
-- Bottom2 :: Depth2_ node a a b b
94+
-- Deeper2 :: !(Depth2_ node a t b u) -> Depth_ node a (node t) b (node u)
9395
-- @
9496
newtype Depth2_ (node :: Type -> Type) (a :: Type) (t :: Type) (b :: Type) (u :: Type)
9597
= Depth2_ Word
@@ -100,6 +102,7 @@ pattern Bottom2 :: () => (t ~ a, u ~ b) => Depth2_ node a t b u
100102
pattern Bottom2 <- (checkBottom2 -> AtBottom2)
101103
where
102104
Bottom2 = Depth2_ 0
105+
{-# INLINE Bottom2 #-}
103106

104107
-- | The depth is non-zero.
105108
pattern Deeper2 :: () => (t ~ node t', u ~ node u') => Depth2_ node a t' b u' -> Depth2_ node a t b u
@@ -108,6 +111,7 @@ pattern Deeper2 d <- (checkBottom2 -> NotBottom2 d)
108111
Deeper2 (Depth2_ d)
109112
| d == maxBound = error "Depth2 overflow"
110113
| otherwise = Depth2_ (d + 1)
114+
{-# INLINE Deeper2 #-}
111115

112116
{-# COMPLETE Bottom2, Deeper2 #-}
113117

@@ -118,3 +122,4 @@ data CheckedBottom2 node a t b u where
118122
checkBottom2 :: Depth2_ node a t b u -> CheckedBottom2 node a t b u
119123
checkBottom2 (Depth2_ 0) = unsafeCoerce AtBottom2
120124
checkBottom2 (Depth2_ d) = unsafeCoerce (NotBottom2 (Depth2_ (d - 1)))
125+
{-# INLINE checkBottom2 #-}

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /