diff --git a/Data/Graph.hs b/Data/Graph.hs
--- a/Data/Graph.hs
+++ b/Data/Graph.hs
@@ -69,10 +69,6 @@
import Data.Array
import Data.List
-#ifdef __HADDOCK__
-import Prelude
-#endif
-
-------------------------------------------------------------------------
-- -
-- External interface
@@ -320,12 +316,15 @@
-- Algorithm 1: depth first search numbering
------------------------------------------------------------
-preorder :: Tree a -> [a]
-preorder (Node a ts) = a : preorderF ts
+preorder' :: Tree a -> [a] -> [a]
+preorder' (Node a ts) = (a :) . preorderF' ts
-preorderF :: Forest a -> [a]
-preorderF ts = concat (map preorder ts)
+preorderF' :: Forest a -> [a] -> [a]
+preorderF' ts = foldr (.) id $ map preorder' ts
+preorderF :: Forest a -> [a]
+preorderF ts = preorderF' ts []
+
tabulate :: Bounds -> [Vertex] -> Table Int
tabulate bnds vs = array bnds (zipWith (,) vs [1..])
@@ -336,14 +335,14 @@
-- Algorithm 2: topological sorting
------------------------------------------------------------
-postorder :: Tree a -> [a]
-postorder (Node a ts) = postorderF ts ++ [a]
+postorder :: Tree a -> [a] -> [a]
+postorder (Node a ts) = postorderF ts . (a :)
-postorderF :: Forest a -> [a]
-postorderF ts = concat (map postorder ts)
+postorderF :: Forest a -> [a] -> [a]
+postorderF ts = foldr (.) id $ map postorder ts
-postOrd :: Graph -> [Vertex]
-postOrd = postorderF . dff
+postOrd :: Graph -> [Vertex]
+postOrd g = postorderF (dff g) []
-- | A topological sort of the graph.
-- The order is partially specified by the condition that a vertex /i/
diff --git a/Data/IntMap.hs b/Data/IntMap.hs
--- a/Data/IntMap.hs
+++ b/Data/IntMap.hs
@@ -1,7 +1,4 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE MagicHash #-}
-{-# OPTIONS_GHC -cpp -XNoBangPatterns -XScopedTypeVariables #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, NoBangPatterns, MagicHash, ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.IntMap
@@ -42,7 +39,12 @@
-- (32 or 64).
-----------------------------------------------------------------------------
-module Data.IntMap (
+-- It is essential that the bit fiddling functions like mask, zero, branchMask
+-- etc are inlined. If they do not, the memory allocation skyrockets. The GHC
+-- usually gets it right, but it is disastrous if it does not. Therefore we
+-- explicitly mark these functions INLINE.
+
+module Data.IntMap (
-- * Map type
#if !defined(TESTING)
IntMap, Key -- instance Eq,Show
@@ -60,15 +62,19 @@
, notMember
, lookup
, findWithDefault
-
+
-- * Construction
, empty
, singleton
-- ** Insertion
, insert
- , insertWith, insertWithKey, insertLookupWithKey
-
+ , insertWith
+ , insertWith'
+ , insertWithKey
+ , insertWithKey'
+ , insertLookupWithKey
+
-- ** Delete\/Update
, delete
, adjust
@@ -77,12 +83,12 @@
, updateWithKey
, updateLookupWithKey
, alter
-
+
-- * Combine
-- ** Union
- , union
- , unionWith
+ , union
+ , unionWith
, unionWithKey
, unions
, unionsWith
@@ -91,9 +97,9 @@
, difference
, differenceWith
, differenceWithKey
-
+
-- ** Intersection
- , intersection
+ , intersection
, intersectionWith
, intersectionWithKey
@@ -104,7 +110,7 @@
, mapAccum
, mapAccumWithKey
, mapAccumRWithKey
-
+
-- ** Fold
, fold
, foldWithKey
@@ -114,7 +120,7 @@
, keys
, keysSet
, assocs
-
+
-- ** Lists
, toList
, fromList
@@ -128,7 +134,7 @@
, fromAscListWithKey
, fromDistinctAscList
- -- * Filter
+ -- * Filter
, filter
, filterWithKey
, partition
@@ -139,18 +145,15 @@
, mapEither
, mapEitherWithKey
- , split
- , splitLookup
+ , split
+ , splitLookup
-- * Submap
, isSubmapOf, isSubmapOfBy
, isProperSubmapOf, isProperSubmapOfBy
-
- -- * Min\/Max
- , maxView
- , minView
- , findMin
+ -- * Min\/Max
+ , findMin
, findMax
, deleteMin
, deleteMax
@@ -159,7 +162,9 @@
, updateMin
, updateMax
, updateMinWithKey
- , updateMaxWithKey
+ , updateMaxWithKey
+ , minView
+ , maxView
, minViewWithKey
, maxViewWithKey
@@ -168,7 +173,6 @@
, showTreeWith
) where
-
import Prelude hiding (lookup,map,filter,foldr,foldl,null)
import Data.Bits
import qualified Data.IntSet as IntSet
@@ -208,9 +212,11 @@
natFromInt :: Key -> Nat
natFromInt = fromIntegral
+{-# INLINE natFromInt #-}
intFromNat :: Nat -> Key
intFromNat = fromIntegral
+{-# INLINE intFromNat #-}
shiftRL :: Nat -> Key -> Nat
#if __GLASGOW_HASKELL__
@@ -221,6 +227,7 @@
= W# (shiftRL# x i)
#else
shiftRL x i = shiftR x i
+{-# INLINE shiftRL #-}
#endif
{--------------------------------------------------------------------
@@ -234,7 +241,7 @@
-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'
(!) :: IntMap a -> Key -> a
-m ! k = find' k m
+m ! k = find k m
-- | Same as 'difference'.
(\\) :: IntMap a -> IntMap b -> IntMap a
@@ -328,25 +335,25 @@
notMember :: Key -> IntMap a -> Bool
notMember k m = not $ member k m
+-- The 'go' function in the lookup causes 10% speedup, but also an increased
+-- memory allocation. It does not cause speedup with other methods like insert
+-- and delete, so it is present only in lookup.
+
-- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'.
lookup :: Key -> IntMap a -> Maybe a
-lookup k t
- = let nk = natFromInt k in seq nk (lookupN nk t)
+lookup k = k `seq` go
+ where
+ go (Bin _ m l r)
+ | zero k m = go l
+ | otherwise = go r
+ go (Tip kx x)
+ | k == kx = Just x
+ | otherwise = Nothing
+ go Nil = Nothing
-lookupN :: Nat -> IntMap a -> Maybe a
-lookupN k t
- = case t of
- Bin _ m l r
- | zeroN k (natFromInt m) -> lookupN k l
- | otherwise -> lookupN k r
- Tip kx x
- | (k == natFromInt kx) -> Just x
- | otherwise -> Nothing
- Nil -> Nothing
--- ^ inlining lookup doesn't seem to help.
-find' :: Key -> IntMap a -> a
-find' k m
+find :: Key -> IntMap a -> a
+find k m
= case lookup k m of
Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map")
Just x -> x
@@ -398,16 +405,16 @@
-- > insert 5 'x' empty == singleton 5 'x'
insert :: Key -> a -> IntMap a -> IntMap a
-insert k x t
- = case t of
- Bin p m l r
- | nomatch k p m -> join k (Tip k x) p t
- | zero k m -> Bin p m (insert k x l) r
- | otherwise -> Bin p m l (insert k x r)
- Tip ky _
- | k==ky -> Tip k x
- | otherwise -> join k (Tip k x) ky t
- Nil -> Tip k x
+insert k x t = k `seq`
+ case t of
+ Bin p m l r
+ | nomatch k p m -> join k (Tip k x) p t
+ | zero k m -> Bin p m (insert k x l) r
+ | otherwise -> Bin p m l (insert k x r)
+ Tip ky _
+ | k==ky -> Tip k x
+ | otherwise -> join k (Tip k x) ky t
+ Nil -> Tip k x
-- right-biased insertion, used by 'union'
-- | /O(min(n,W))/. Insert with a combining function.
@@ -424,6 +431,11 @@
insertWith f k x t
= insertWithKey (\_ x' y' -> f x' y') k x t
+-- | Same as 'insertWith', but the combining function is applied strictly.
+insertWith' :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
+insertWith' f k x t
+ = insertWithKey' (\_ x' y' -> f x' y') k x t
+
-- | /O(min(n,W))/. Insert with a combining function.
-- @'insertWithKey' f key value mp@
-- will insert the pair (key, value) into @mp@ if key does
@@ -436,19 +448,29 @@
-- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"
insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
-insertWithKey f k x = k `seq` go
- where
- go t@(Bin p m l r)
- | nomatch k p m = join k (Tip k x) p t
- | zero k m = Bin p m (go l) r
- | otherwise = Bin p m l (go r)
-
- go t@(Tip ky y)
- | k==ky = Tip k (f k x y)
- | otherwise = join k (Tip k x) ky t
-
- go Nil = Tip k x
+insertWithKey f k x t = k `seq`
+ case t of
+ Bin p m l r
+ | nomatch k p m -> join k (Tip k x) p t
+ | zero k m -> Bin p m (insertWithKey f k x l) r
+ | otherwise -> Bin p m l (insertWithKey f k x r)
+ Tip ky y
+ | k==ky -> Tip k (f k x y)
+ | otherwise -> join k (Tip k x) ky t
+ Nil -> Tip k x
+-- | Same as 'insertWithKey', but the combining function is applied strictly.
+insertWithKey' :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
+insertWithKey' f k x t = k `seq`
+ case t of
+ Bin p m l r
+ | nomatch k p m -> join k (Tip k x) p t
+ | zero k m -> Bin p m (insertWithKey' f k x l) r
+ | otherwise -> Bin p m l (insertWithKey' f k x r)
+ Tip ky y
+ | k==ky -> let x' = f k x y in seq x' (Tip k x')
+ | otherwise -> join k (Tip k x) ky t
+ Nil -> Tip k x
-- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)
-- is a pair where the first element is equal to (@'lookup' k map@)
@@ -466,18 +488,16 @@
-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])
insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)
-insertLookupWithKey f k x = k `seq` go
- where
- go t@(Bin p m l r)
- | nomatch k p m = (Nothing,join k (Tip k x) p t)
- | zero k m = case go l of (found, l') -> (found,Bin p m l' r)
- | otherwise = case go r of (found, r') -> (found,Bin p m l r')
-
- go t@(Tip ky y)
- | k==ky = (Just y,Tip k (f k x y))
- | otherwise = (Nothing,join k (Tip k x) ky t)
-
- go Nil = (Nothing,Tip k x)
+insertLookupWithKey f k x t = k `seq`
+ case t of
+ Bin p m l r
+ | nomatch k p m -> (Nothing,join k (Tip k x) p t)
+ | zero k m -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)
+ | otherwise -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')
+ Tip ky y
+ | k==ky -> (Just y,Tip k (f k x y))
+ | otherwise -> (Nothing,join k (Tip k x) ky t)
+ Nil -> (Nothing,Tip k x)
{--------------------------------------------------------------------
@@ -492,18 +512,16 @@
-- > delete 5 empty == empty
delete :: Key -> IntMap a -> IntMap a
-delete k = go
- where
- go t@(Bin p m l r)
- | nomatch k p m = t
- | zero k m = bin p m (go l) r
- | otherwise = bin p m l (go r)
-
- go t@(Tip ky _)
- | k==ky = Nil
- | otherwise = t
-
- go Nil = Nil
+delete k t = k `seq`
+ case t of
+ Bin p m l r
+ | nomatch k p m -> t
+ | zero k m -> bin p m (delete k l) r
+ | otherwise -> bin p m l (delete k r)
+ Tip ky _
+ | k==ky -> Nil
+ | otherwise -> t
+ Nil -> Nil
-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not
-- a member of the map, the original map is returned.
@@ -551,20 +569,18 @@
-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a
-updateWithKey f k = go
- where
- go t@(Bin p m l r)
- | nomatch k p m = t
- | zero k m = bin p m (go l) r
- | otherwise = bin p m l (go r)
-
- go t@(Tip ky y)
- | k==ky = case f k y of
- Just y' -> Tip ky y'
- Nothing -> Nil
- | otherwise = t
-
- go Nil = Nil
+updateWithKey f k t = k `seq`
+ case t of
+ Bin p m l r
+ | nomatch k p m -> t
+ | zero k m -> bin p m (updateWithKey f k l) r
+ | otherwise -> bin p m l (updateWithKey f k r)
+ Tip ky y
+ | k==ky -> case (f k y) of
+ Just y' -> Tip ky y'
+ Nothing -> Nil
+ | otherwise -> t
+ Nil -> Nil
-- | /O(min(n,W))/. Lookup and update.
-- The function returns original value, if it is updated.
@@ -577,46 +593,43 @@
-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")
updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)
-updateLookupWithKey f k = go
- where
- go t@(Bin p m l r)
- | nomatch k p m = (Nothing,t)
- | zero k m = case updateLookupWithKey f k l of (found, l') -> (found,bin p m l' r)
- | otherwise = case updateLookupWithKey f k r of (found, r') -> (found,bin p m l r')
+updateLookupWithKey f k t = k `seq`
+ case t of
+ Bin p m l r
+ | nomatch k p m -> (Nothing,t)
+ | zero k m -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)
+ | otherwise -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')
+ Tip ky y
+ | k==ky -> case (f k y) of
+ Just y' -> (Just y,Tip ky y')
+ Nothing -> (Just y,Nil)
+ | otherwise -> (Nothing,t)
+ Nil -> (Nothing,Nil)
- go t@(Tip ky y)
- | k==ky = case f k y of
- Just y' -> (Just y,Tip ky y')
- Nothing -> (Just y,Nil)
- | otherwise = (Nothing,t)
- go Nil = (Nothing,Nil)
-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
-- 'alter' can be used to insert, delete, or update a value in an 'IntMap'.
-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.
-alter :: (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
-alter f k = k `seq` go
- where
- go t@(Bin p m l r)
- | nomatch k p m = case f Nothing of
- Nothing -> t
- Just x -> join k (Tip k x) p t
- | zero k m = bin p m (go l) r
- | otherwise = bin p m l (go r)
-
- go t@(Tip ky y)
- | k==ky = case f (Just y) of
- Just x -> Tip ky x
- Nothing -> Nil
-
- | otherwise = case f Nothing of
- Just x -> join k (Tip k x) ky t
- Nothing -> Tip ky y
-
- go Nil = case f Nothing of
- Just x -> Tip k x
- Nothing -> Nil
+alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a
+alter f k t = k `seq`
+ case t of
+ Bin p m l r
+ | nomatch k p m -> case f Nothing of
+ Nothing -> t
+ Just x -> join k (Tip k x) p t
+ | zero k m -> bin p m (alter f k l) r
+ | otherwise -> bin p m l (alter f k r)
+ Tip ky y
+ | k==ky -> case f (Just y) of
+ Just x -> Tip ky x
+ Nothing -> Nil
+ | otherwise -> case f Nothing of
+ Just x -> join k (Tip k x) ky t
+ Nothing -> Tip ky y
+ Nil -> case f Nothing of
+ Just x -> Tip k x
+ Nothing -> Nil
{--------------------------------------------------------------------
@@ -859,19 +872,19 @@
-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
updateMinWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a
-updateMinWithKey f = go
- where
- go (Bin p m l r) | m < 0 = let t' = updateMinWithKeyUnsigned f r in Bin p m l t'
- go (Bin p m l r) = let t' = updateMinWithKeyUnsigned f l in Bin p m t' r
- go (Tip k y) = Tip k (f k y)
- go Nil = error "maxView: empty map has no maximal element"
+updateMinWithKey f t
+ = case t of
+ Bin p m l r | m < 0 -> let t' = updateMinWithKeyUnsigned f r in Bin p m l t'
+ Bin p m l r -> let t' = updateMinWithKeyUnsigned f l in Bin p m t' r
+ Tip k y -> Tip k (f k y)
+ Nil -> error "maxView: empty map has no maximal element"
updateMinWithKeyUnsigned :: (Key -> a -> a) -> IntMap a -> IntMap a
-updateMinWithKeyUnsigned f = go
- where
- go (Bin p m l r) = let t' = go l in Bin p m t' r
- go (Tip k y) = Tip k (f k y)
- go Nil = error "updateMinWithKeyUnsigned Nil"
+updateMinWithKeyUnsigned f t
+ = case t of
+ Bin p m l r -> let t' = updateMinWithKeyUnsigned f l in Bin p m t' r
+ Tip k y -> Tip k (f k y)
+ Nil -> error "updateMinWithKeyUnsigned Nil"
-- | /O(log n)/. Update the value at the maximal key.
--
@@ -879,19 +892,19 @@
-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
updateMaxWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a
-updateMaxWithKey f = go
- where
- go (Bin p m l r) | m < 0 = let t' = updateMaxWithKeyUnsigned f l in Bin p m t' r
- go (Bin p m l r) = let t' = updateMaxWithKeyUnsigned f r in Bin p m l t'
- go (Tip k y) = Tip k (f k y)
- go Nil = error "maxView: empty map has no maximal element"
+updateMaxWithKey f t
+ = case t of
+ Bin p m l r | m < 0 -> let t' = updateMaxWithKeyUnsigned f l in Bin p m t' r
+ Bin p m l r -> let t' = updateMaxWithKeyUnsigned f r in Bin p m l t'
+ Tip k y -> Tip k (f k y)
+ Nil -> error "maxView: empty map has no maximal element"
updateMaxWithKeyUnsigned :: (Key -> a -> a) -> IntMap a -> IntMap a
-updateMaxWithKeyUnsigned f = go
- where
- go (Bin p m l r) = let t' = go r in Bin p m l t'
- go (Tip k y) = Tip k (f k y)
- go Nil = error "updateMaxWithKeyUnsigned Nil"
+updateMaxWithKeyUnsigned f t
+ = case t of
+ Bin p m l r -> let t' = updateMaxWithKeyUnsigned f r in Bin p m l t'
+ Tip k y -> Tip k (f k y)
+ Nil -> error "updateMaxWithKeyUnsigned Nil"
-- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and
@@ -909,7 +922,7 @@
Nil -> Nothing
maxViewUnsigned :: IntMap a -> ((Key, a), IntMap a)
-maxViewUnsigned t
+maxViewUnsigned t
= case t of
Bin p m l r -> let (result,t') = maxViewUnsigned r in (result,bin p m l t')
Tip k y -> ((k,y), Nil)
@@ -930,7 +943,7 @@
Nil -> Nothing
minViewUnsigned :: IntMap a -> ((Key, a), IntMap a)
-minViewUnsigned t
+minViewUnsigned t
= case t of
Bin p m l r -> let (result,t') = minViewUnsigned l in (result,bin p m t' r)
Tip k y -> ((k,y),Nil)
@@ -976,26 +989,26 @@
deleteFindMin = fromMaybe (error "deleteFindMin: empty map has no minimal element") . minView
-- | /O(log n)/. The minimal key of the map.
-findMin :: IntMap a -> (Int,a)
+findMin :: IntMap a -> (Key, a)
findMin Nil = error $ "findMin: empty map has no minimal element"
findMin (Tip k v) = (k,v)
findMin (Bin _ m l r)
- | m < 0 = find r
- | otherwise = find l
- where find (Tip k v) = (k,v)
- find (Bin _ _ l' _) = find l'
- find Nil = error "findMax Nil"
+ | m < 0 = go r
+ | otherwise = go l
+ where go (Tip k v) = (k,v)
+ go (Bin _ _ l' _) = go l'
+ go Nil = error "findMax Nil"
-- | /O(log n)/. The maximal key of the map.
-findMax :: IntMap a -> (Int,a)
+findMax :: IntMap a -> (Key, a)
findMax Nil = error $ "findMax: empty map has no maximal element"
findMax (Tip k v) = (k,v)
-findMax (Bin _ m l r)
- | m < 0 = find l
- | otherwise = find r
- where find (Tip k v) = (k,v)
- find (Bin _ _ _ r') = find r'
- find Nil = error "findMax Nil"
+findMax (Bin _ m l r)
+ | m < 0 = go l
+ | otherwise = go r
+ where go (Tip k v) = (k,v)
+ go (Bin _ _ _ r') = go r'
+ go Nil = error "findMax Nil"
-- | /O(log n)/. Delete the minimal key. An error is thrown if the IntMap is already empty.
-- Note, this is not the same behavior Map.
@@ -1116,11 +1129,11 @@
-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]
mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b
-mapWithKey f = go
- where
- go (Bin p m l r) = Bin p m (go l) (go r)
- go (Tip k x) = Tip k (f k x)
- go Nil = Nil
+mapWithKey f t
+ = case t of
+ Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)
+ Tip k x -> Tip k (f k x)
+ Nil -> Nil
-- | /O(n)/. The function @'mapAccum'@ threads an accumulating
-- argument through the map in ascending order of keys.
@@ -1181,13 +1194,14 @@
-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a
-filterWithKey p = go
- where
- go (Bin pr m l r) = bin pr m (go l) (go r)
- go t@(Tip k x)
- | p k x = t
- | otherwise = Nil
- go Nil = Nil
+filterWithKey predicate t
+ = case t of
+ Bin p m l r
+ -> bin p m (filterWithKey predicate l) (filterWithKey predicate r)
+ Tip k x
+ | predicate k x -> t
+ | otherwise -> Nil
+ Nil -> Nil
-- | /O(n)/. Partition the map according to some predicate. The first
-- map contains all elements that satisfy the predicate, the second all
@@ -1235,13 +1249,12 @@
-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"
mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b
-mapMaybeWithKey f = go
- where
- go (Bin p m l r) = bin p m (go l) (go r)
- go (Tip k x) = case f k x of
- Just y -> Tip k y
- Nothing -> Nil
- go Nil = Nil
+mapMaybeWithKey f (Bin p m l r)
+ = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)
+mapMaybeWithKey f (Tip k x) = case f k x of
+ Just y -> Tip k y
+ Nothing -> Nil
+mapMaybeWithKey _ Nil = Nil
-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
--
@@ -1363,6 +1376,7 @@
fold :: (a -> b -> b) -> b -> IntMap a -> b
fold f = foldWithKey (\_ x y -> f x y)
+{-# INLINE fold #-}
-- | /O(n)/. Fold the keys and values in the map, such that
-- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
@@ -1376,22 +1390,22 @@
foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b
foldWithKey
= foldr
+{-# INLINE foldWithKey #-}
foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b
foldr f z t
= case t of
- Bin 0 m l r | m < 0 -> foldr' f (foldr' f z l) r -- put negative numbers before.
- Bin _ _ _ _ -> foldr' f z t
+ Bin 0 m l r | m < 0 -> go (go z l) r -- put negative numbers before.
+ Bin _ _ _ _ -> go z t
Tip k x -> f k x z
Nil -> z
-
-foldr' :: (Key -> a -> b -> b) -> b -> IntMap a -> b
-foldr' f = go
where
- go z (Bin _ _ l r) = go (go z r) l
- go z (Tip k x) = f k x z
- go z Nil = z
+ go z' (Bin _ _ l r) = go (go z' r) l
+ go z' (Tip k x) = f k x z'
+ go z' Nil = z'
+{-# INLINE foldr #-}
+
{--------------------------------------------------------------------
List variations
--------------------------------------------------------------------}
@@ -1726,6 +1740,7 @@
where
m = branchMask p1 p2
p = mask p1 m
+{-# INLINE join #-}
{--------------------------------------------------------------------
@bin@ assures that we never have empty trees within a tree.
@@ -1734,6 +1749,7 @@
bin _ _ l Nil = l
bin _ _ Nil r = r
bin p m l r = Bin p m l r
+{-# INLINE bin #-}
{--------------------------------------------------------------------
@@ -1742,37 +1758,41 @@
zero :: Key -> Mask -> Bool
zero i m
= (natFromInt i) .&. (natFromInt m) == 0
+{-# INLINE zero #-}
nomatch,match :: Key -> Prefix -> Mask -> Bool
nomatch i p m
= (mask i m) /= p
+{-# INLINE nomatch #-}
match i p m
= (mask i m) == p
+{-# INLINE match #-}
mask :: Key -> Mask -> Prefix
mask i m
= maskW (natFromInt i) (natFromInt m)
+{-# INLINE mask #-}
-zeroN :: Nat -> Nat -> Bool
-zeroN i m = (i .&. m) == 0
-
{--------------------------------------------------------------------
Big endian operations
--------------------------------------------------------------------}
maskW :: Nat -> Nat -> Prefix
maskW i m
= intFromNat (i .&. (complement (m-1) `xor` m))
+{-# INLINE maskW #-}
shorter :: Mask -> Mask -> Bool
shorter m1 m2
= (natFromInt m1) > (natFromInt m2)
+{-# INLINE shorter #-}
branchMask :: Prefix -> Prefix -> Mask
branchMask p1 p2
= intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
-
+{-# INLINE branchMask #-}
+
{----------------------------------------------------------------------
Finding the highest bit (mask) in a word [x] can be done efficiently in
three ways:
@@ -1824,6 +1844,7 @@
x4 -> case (x4 .|. shiftRL x4 16) of
x5 -> case (x5 .|. shiftRL x5 32) of -- for 64 bit platforms
x6 -> (x6 `xor` (shiftRL x6 1))
+{-# INLINE highestBitMask #-}
{--------------------------------------------------------------------
@@ -1834,4 +1855,5 @@
foldlStrict f = go
where
go z [] = z
- go z (x:xs) = z `seq` go (f z x) xs
+ go z (x:xs) = let z' = f z x in z' `seq` go z' xs
+{-# INLINE foldlStrict #-}
diff --git a/Data/IntSet.hs b/Data/IntSet.hs
--- a/Data/IntSet.hs
+++ b/Data/IntSet.hs
@@ -1,5 +1,4 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE CPP, MagicHash #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.IntSet
@@ -37,9 +36,18 @@
-- (32 or 64).
-----------------------------------------------------------------------------
-module Data.IntSet (
+-- It is essential that the bit fiddling functions like mask, zero, branchMask
+-- etc are inlined. If they do not, the memory allocation skyrockets. The GHC
+-- usually gets it right, but it is disastrous if it does not. Therefore we
+-- explicitly mark these functions INLINE.
+
+module Data.IntSet (
-- * Set type
+#if !defined(TESTING)
IntSet -- instance Eq,Show
+#else
+ IntSet(..) -- instance Eq,Show
+#endif
-- * Operators
, (\\)
@@ -51,26 +59,33 @@
, notMember
, isSubsetOf
, isProperSubsetOf
-
+
-- * Construction
, empty
, singleton
, insert
, delete
-
+
-- * Combine
- , union, unions
+ , union
+ , unions
, difference
, intersection
-
+
-- * Filter
, filter
, partition
, split
, splitMember
+ -- * Map
+ , map
+
+ -- * Fold
+ , fold
+
-- * Min\/Max
- , findMin
+ , findMin
, findMax
, deleteMin
, deleteMax
@@ -79,26 +94,26 @@
, maxView
, minView
- -- * Map
- , map
-
- -- * Fold
- , fold
-
-- * Conversion
+
-- ** List
, elems
, toList
, fromList
-
+
-- ** Ordered list
, toAscList
, fromAscList
, fromDistinctAscList
-
+
-- * Debugging
, showTree
, showTreeWith
+
+#if defined(TESTING)
+ -- * Internals
+ , match
+#endif
) where
@@ -110,14 +125,6 @@
import Data.Maybe (fromMaybe)
import Data.Typeable
-{-
--- just for testing
-import Test.QuickCheck
-import List (nub,sort)
-import qualified List
-import qualified Data.Set as Set
--}
-
#if __GLASGOW_HASKELL__
import Text.Read
import Data.Data (Data(..), mkNoRepType)
@@ -139,9 +146,11 @@
natFromInt :: Int -> Nat
natFromInt i = fromIntegral i
+{-# INLINE natFromInt #-}
intFromNat :: Nat -> Int
intFromNat w = fromIntegral w
+{-# INLINE intFromNat #-}
shiftRL :: Nat -> Int -> Nat
#if __GLASGOW_HASKELL__
@@ -152,6 +161,7 @@
= W# (shiftRL# x i)
#else
shiftRL x i = shiftR x i
+{-# INLINE shiftRL #-}
#endif
{--------------------------------------------------------------------
@@ -218,36 +228,45 @@
Tip _ -> 1
Nil -> 0
+-- The 'go' function in the member and lookup causes 10% speedup, but also an
+-- increased memory allocation. It does not cause speedup with other methods
+-- like insert and delete, so it is present only in member and lookup.
+
+-- Also mind the 'nomatch' line in member definition, which is not present in
+-- lookup and not present in IntMap.hs. That condition stops the search if the
+-- prefix of current vertex is different that the element looked for. The
+-- member is correct both with and without this condition. With this condition,
+-- elements not present are rejected sooner, but a little bit more work is done
+-- for the elements in the set (we are talking about 3-5% slowdown). Any of
+-- the solutions is better than the other, because we do not know the
+-- distribution of input data. Current state is historic.
+
-- | /O(min(n,W))/. Is the value a member of the set?
member :: Int -> IntSet -> Bool
-member x t
- = case t of
- Bin p m l r
- | nomatch x p m -> False
- | zero x m -> member x l
- | otherwise -> member x r
- Tip y -> (x==y)
- Nil -> False
-
+member x = x `seq` go
+ where
+ go (Bin p m l r)
+ | nomatch x p m = False
+ | zero x m = go l
+ | otherwise = go r
+ go (Tip y) = x == y
+ go Nil = False
+
-- | /O(min(n,W))/. Is the element not in the set?
notMember :: Int -> IntSet -> Bool
notMember k = not . member k
-- 'lookup' is used by 'intersection' for left-biasing
lookup :: Int -> IntSet -> Maybe Int
-lookup k t
- = let nk = natFromInt k in seq nk (lookupN nk t)
-
-lookupN :: Nat -> IntSet -> Maybe Int
-lookupN k t
- = case t of
- Bin _ m l r
- | zeroN k (natFromInt m) -> lookupN k l
- | otherwise -> lookupN k r
- Tip kx
- | (k == natFromInt kx) -> Just kx
- | otherwise -> Nothing
- Nil -> Nothing
+lookup k = k `seq` go
+ where
+ go (Bin _ m l r)
+ | zero k m = go l
+ | otherwise = go r
+ go (Tip kx)
+ | k == kx = Just kx
+ | otherwise = Nothing
+ go Nil = Nothing
{--------------------------------------------------------------------
Construction
@@ -269,43 +288,43 @@
-- an element of the set, it is replaced by the new one, ie. 'insert'
-- is left-biased.
insert :: Int -> IntSet -> IntSet
-insert x t
- = case t of
- Bin p m l r
- | nomatch x p m -> join x (Tip x) p t
- | zero x m -> Bin p m (insert x l) r
- | otherwise -> Bin p m l (insert x r)
- Tip y
- | x==y -> Tip x
- | otherwise -> join x (Tip x) y t
- Nil -> Tip x
+insert x t = x `seq`
+ case t of
+ Bin p m l r
+ | nomatch x p m -> join x (Tip x) p t
+ | zero x m -> Bin p m (insert x l) r
+ | otherwise -> Bin p m l (insert x r)
+ Tip y
+ | x==y -> Tip x
+ | otherwise -> join x (Tip x) y t
+ Nil -> Tip x
-- right-biased insertion, used by 'union'
insertR :: Int -> IntSet -> IntSet
-insertR x t
- = case t of
- Bin p m l r
- | nomatch x p m -> join x (Tip x) p t
- | zero x m -> Bin p m (insert x l) r
- | otherwise -> Bin p m l (insert x r)
- Tip y
- | x==y -> t
- | otherwise -> join x (Tip x) y t
- Nil -> Tip x
+insertR x t = x `seq`
+ case t of
+ Bin p m l r
+ | nomatch x p m -> join x (Tip x) p t
+ | zero x m -> Bin p m (insert x l) r
+ | otherwise -> Bin p m l (insert x r)
+ Tip y
+ | x==y -> t
+ | otherwise -> join x (Tip x) y t
+ Nil -> Tip x
-- | /O(min(n,W))/. Delete a value in the set. Returns the
-- original set when the value was not present.
delete :: Int -> IntSet -> IntSet
-delete x t
- = case t of
- Bin p m l r
- | nomatch x p m -> t
- | zero x m -> bin p m (delete x l) r
- | otherwise -> bin p m l (delete x r)
- Tip y
- | x==y -> Nil
- | otherwise -> t
- Nil -> Nil
+delete x t = x `seq`
+ case t of
+ Bin p m l r
+ | nomatch x p m -> t
+ | zero x m -> bin p m (delete x l) r
+ | otherwise -> bin p m l (delete x r)
+ Tip y
+ | x==y -> Nil
+ | otherwise -> t
+ Nil -> Nil
{--------------------------------------------------------------------
@@ -647,19 +666,16 @@
fold :: (Int -> b -> b) -> b -> IntSet -> b
fold f z t
= case t of
- Bin 0 m l r | m < 0 -> foldr f (foldr f z l) r
- -- put negative numbers before.
- Bin _ _ _ _ -> foldr f z t
+ Bin 0 m l r | m < 0 -> go (go z l) r -- put negative numbers before.
+ Bin _ _ _ _ -> go z t
Tip x -> f x z
Nil -> z
+ where
+ go z' (Bin _ _ l r) = go (go z' r) l
+ go z' (Tip x) = f x z'
+ go z' Nil = z'
+{-# INLINE fold #-}
-foldr :: (Int -> b -> b) -> b -> IntSet -> b
-foldr f z t
- = case t of
- Bin _ _ l r -> foldr f (foldr f z r) l
- Tip x -> f x z
- Nil -> z
-
{--------------------------------------------------------------------
List variations
--------------------------------------------------------------------}
@@ -880,6 +896,7 @@
where
m = branchMask p1 p2
p = mask p1 m
+{-# INLINE join #-}
{--------------------------------------------------------------------
@bin@ assures that we never have empty trees within a tree.
@@ -888,6 +905,7 @@
bin _ _ l Nil = l
bin _ _ Nil r = r
bin p m l r = Bin p m l r
+{-# INLINE bin #-}
{--------------------------------------------------------------------
@@ -896,22 +914,23 @@
zero :: Int -> Mask -> Bool
zero i m
= (natFromInt i) .&. (natFromInt m) == 0
+{-# INLINE zero #-}
nomatch,match :: Int -> Prefix -> Mask -> Bool
nomatch i p m
= (mask i m) /= p
+{-# INLINE nomatch #-}
match i p m
= (mask i m) == p
+{-# INLINE match #-}
-- Suppose a is largest such that 2^a divides 2*m.
-- Then mask i m is i with the low a bits zeroed out.
mask :: Int -> Mask -> Prefix
mask i m
= maskW (natFromInt i) (natFromInt m)
-
-zeroN :: Nat -> Nat -> Bool
-zeroN i m = (i .&. m) == 0
+{-# INLINE mask #-}
{--------------------------------------------------------------------
Big endian operations
@@ -919,15 +938,18 @@
maskW :: Nat -> Nat -> Prefix
maskW i m
= intFromNat (i .&. (complement (m-1) `xor` m))
+{-# INLINE maskW #-}
shorter :: Mask -> Mask -> Bool
shorter m1 m2
= (natFromInt m1) > (natFromInt m2)
+{-# INLINE shorter #-}
branchMask :: Prefix -> Prefix -> Mask
branchMask p1 p2
= intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
-
+{-# INLINE branchMask #-}
+
{----------------------------------------------------------------------
Finding the highest bit (mask) in a word [x] can be done efficiently in
three ways:
@@ -979,136 +1001,15 @@
x4 -> case (x4 .|. shiftRL x4 16) of
x5 -> case (x5 .|. shiftRL x5 32) of -- for 64 bit platforms
x6 -> (x6 `xor` (shiftRL x6 1))
+{-# INLINE highestBitMask #-}
{--------------------------------------------------------------------
Utilities
--------------------------------------------------------------------}
foldlStrict :: (a -> b -> a) -> a -> [b] -> a
-foldlStrict f z xs
- = case xs of
- [] -> z
- (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
-
-
-{-
-{--------------------------------------------------------------------
- Testing
---------------------------------------------------------------------}
-testTree :: [Int] -> IntSet
-testTree xs = fromList xs
-test1 = testTree [1..20]
-test2 = testTree [30,29..10]
-test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
-
-{--------------------------------------------------------------------
- QuickCheck
---------------------------------------------------------------------}
-qcheck prop
- = check config prop
+foldlStrict f = go
where
- config = Config
- { configMaxTest = 500
- , configMaxFail = 5000
- , configSize = \n -> (div n 2 + 3)
- , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
- }
-
-
-{--------------------------------------------------------------------
- Arbitrary, reasonably balanced trees
---------------------------------------------------------------------}
-instance Arbitrary IntSet where
- arbitrary = do{ xs <- arbitrary
- ; return (fromList xs)
- }
-
-
-{--------------------------------------------------------------------
- Single, Insert, Delete
---------------------------------------------------------------------}
-prop_Single :: Int -> Bool
-prop_Single x
- = (insert x empty == singleton x)
-
-prop_InsertDelete :: Int -> IntSet -> Property
-prop_InsertDelete k t
- = not (member k t) ==> delete k (insert k t) == t
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
-prop_UnionInsert :: Int -> IntSet -> Bool
-prop_UnionInsert x t
- = union t (singleton x) == insert x t
-
-prop_UnionAssoc :: IntSet -> IntSet -> IntSet -> Bool
-prop_UnionAssoc t1 t2 t3
- = union t1 (union t2 t3) == union (union t1 t2) t3
-
-prop_UnionComm :: IntSet -> IntSet -> Bool
-prop_UnionComm t1 t2
- = (union t1 t2 == union t2 t1)
-
-prop_Diff :: [Int] -> [Int] -> Bool
-prop_Diff xs ys
- = toAscList (difference (fromList xs) (fromList ys))
- == List.sort ((List.\\) (nub xs) (nub ys))
-
-prop_Int :: [Int] -> [Int] -> Bool
-prop_Int xs ys
- = toAscList (intersection (fromList xs) (fromList ys))
- == List.sort (nub ((List.intersect) (xs) (ys)))
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
-prop_Ordered
- = forAll (choose (5,100)) $ \n ->
- let xs = concat [[i-n,i-n]|i<-[0..2*n :: Int]]
- in fromAscList xs == fromList xs
-
-prop_List :: [Int] -> Bool
-prop_List xs
- = (sort (nub xs) == toAscList (fromList xs))
-
-{--------------------------------------------------------------------
- Bin invariants
---------------------------------------------------------------------}
-powersOf2 :: IntSet
-powersOf2 = fromList [2^i | i <- [0..63]]
-
--- Check the invariant that the mask is a power of 2.
-prop_MaskPow2 :: IntSet -> Bool
-prop_MaskPow2 (Bin _ msk left right) = member msk powersOf2 && prop_MaskPow2 left && prop_MaskPow2 right
-prop_MaskPow2 _ = True
-
--- Check that the prefix satisfies its invariant.
-prop_Prefix :: IntSet -> Bool
-prop_Prefix s@(Bin prefix msk left right) = all (\elem -> match elem prefix msk) (toList s) && prop_Prefix left && prop_Prefix right
-prop_Prefix _ = True
-
--- Check that the left elements don't have the mask bit set, and the right
--- ones do.
-prop_LeftRight :: IntSet -> Bool
-prop_LeftRight (Bin _ msk left right) = and [x .&. msk == 0 | x <- toList left] && and [x .&. msk == msk | x <- toList right]
-prop_LeftRight _ = True
-
-{--------------------------------------------------------------------
- IntSet operations are like Set operations
---------------------------------------------------------------------}
-toSet :: IntSet -> Set.Set Int
-toSet = Set.fromList . toList
-
--- Check that IntSet.isProperSubsetOf is the same as Set.isProperSubsetOf.
-prop_isProperSubsetOf :: IntSet -> IntSet -> Bool
-prop_isProperSubsetOf a b = isProperSubsetOf a b == Set.isProperSubsetOf (toSet a) (toSet b)
-
--- In the above test, isProperSubsetOf almost always returns False (since a
--- random set is almost never a subset of another random set). So this second
--- test checks the True case.
-prop_isProperSubsetOf2 :: IntSet -> IntSet -> Bool
-prop_isProperSubsetOf2 a b = isProperSubsetOf a c == (a /= c) where
- c = union a b
--}
+ go z [] = z
+ go z (x:xs) = let z' = f z x in z' `seq` go z' xs
+{-# INLINE foldlStrict #-}
diff --git a/Data/Map.hs b/Data/Map.hs
--- a/Data/Map.hs
+++ b/Data/Map.hs
@@ -1,2137 +1,2569 @@
-{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -XNoBangPatterns #-}
-
------------------------------------------------------------------------------
--- |
--- Module : Data.Map
--- Copyright : (c) Daan Leijen 2002
--- (c) Andriy Palamarchuk 2008
--- License : BSD-style
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- An efficient implementation of maps from keys to values (dictionaries).
---
--- Since many function names (but not the type name) clash with
--- "Prelude" names, this module is usually imported @qualified@, e.g.
---
--- > import Data.Map (Map)
--- > import qualified Data.Map as Map
---
--- The implementation of 'Map' is based on /size balanced/ binary trees (or
--- trees of /bounded balance/) as described by:
---
--- * Stephen Adams, \"/Efficient sets: a balancing act/\",
--- Journal of Functional Programming 3(4):553-562, October 1993,
--- .
---
--- * J. Nievergelt and E.M. Reingold,
--- \"/Binary search trees of bounded balance/\",
--- SIAM journal of computing 2(1), March 1973.
---
--- Note that the implementation is /left-biased/ -- the elements of a
--- first argument are always preferred to the second, for example in
--- 'union' or 'insert'.
---
--- Operation comments contain the operation time complexity in
--- the Big-O notation .
------------------------------------------------------------------------------
-
-module Data.Map (
- -- * Map type
-#if !defined(TESTING)
- Map -- instance Eq,Show,Read
-#else
- Map(..) -- instance Eq,Show,Read
-#endif
-
- -- * Operators
- , (!), (\\)
-
- -- * Query
- , null
- , size
- , member
- , notMember
- , lookup
- , findWithDefault
-
- -- * Construction
- , empty
- , singleton
-
- -- ** Insertion
- , insert
- , insertWith
- , insertWith'
- , insertWithKey
- , insertWithKey'
- , insertLookupWithKey
- , insertLookupWithKey'
-
- -- ** Delete\/Update
- , delete
- , adjust
- , adjustWithKey
- , update
- , updateWithKey
- , updateLookupWithKey
- , alter
-
- -- * Combine
-
- -- ** Union
- , union
- , unionWith
- , unionWithKey
- , unions
- , unionsWith
-
- -- ** Difference
- , difference
- , differenceWith
- , differenceWithKey
-
- -- ** Intersection
- , intersection
- , intersectionWith
- , intersectionWithKey
-
- -- * Traversal
- -- ** Map
- , map
- , mapWithKey
- , mapAccum
- , mapAccumWithKey
- , mapAccumRWithKey
- , mapKeys
- , mapKeysWith
- , mapKeysMonotonic
-
- -- ** Fold
- , fold
- , foldWithKey
- , foldrWithKey
- , foldlWithKey
- -- , foldlWithKey'
-
- -- * Conversion
- , elems
- , keys
- , keysSet
- , assocs
-
- -- ** Lists
- , toList
- , fromList
- , fromListWith
- , fromListWithKey
-
- -- ** Ordered lists
- , toAscList
- , toDescList
- , fromAscList
- , fromAscListWith
- , fromAscListWithKey
- , fromDistinctAscList
-
- -- * Filter
- , filter
- , filterWithKey
- , partition
- , partitionWithKey
-
- , mapMaybe
- , mapMaybeWithKey
- , mapEither
- , mapEitherWithKey
-
- , split
- , splitLookup
-
- -- * Submap
- , isSubmapOf, isSubmapOfBy
- , isProperSubmapOf, isProperSubmapOfBy
-
- -- * Indexed
- , lookupIndex
- , findIndex
- , elemAt
- , updateAt
- , deleteAt
-
- -- * Min\/Max
- , findMin
- , findMax
- , deleteMin
- , deleteMax
- , deleteFindMin
- , deleteFindMax
- , updateMin
- , updateMax
- , updateMinWithKey
- , updateMaxWithKey
- , minView
- , maxView
- , minViewWithKey
- , maxViewWithKey
-
- -- * Debugging
- , showTree
- , showTreeWith
- , valid
-
-#if defined(TESTING)
- -- * Internals
- , bin
- , balanced
- , join
- , merge
-#endif
-
- ) where
-
-import Prelude hiding (lookup,map,filter,null)
-import qualified Data.Set as Set
-import qualified Data.List as List
-import Data.Monoid (Monoid(..))
-import Control.Applicative (Applicative(..), (<$>))
-import Data.Traversable (Traversable(traverse))
-import Data.Foldable (Foldable(foldMap))
-#ifndef __GLASGOW_HASKELL__
-import Data.Typeable ( Typeable, typeOf, typeOfDefault
- , Typeable1, typeOf1, typeOf1Default)
-#endif
-import Data.Typeable (Typeable2(..), TyCon, mkTyCon, mkTyConApp)
-
-#if __GLASGOW_HASKELL__
-import Text.Read
-import Data.Data (Data(..), mkNoRepType, gcast2)
-#endif
-
-{--------------------------------------------------------------------
- Operators
---------------------------------------------------------------------}
-infixl 9 !,\\ --
-
--- | /O(log n)/. Find the value at a key.
--- Calls 'error' when the element can not be found.
---
--- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map
--- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'
-
-(!) :: Ord k => Map k a -> k -> a
-m ! k = find k m
-
--- | Same as 'difference'.
-(\\) :: Ord k => Map k a -> Map k b -> Map k a
-m1 \\ m2 = difference m1 m2
-
-{--------------------------------------------------------------------
- Size balanced trees.
---------------------------------------------------------------------}
--- | A Map from keys @k@ to values @a@.
-data Map k a = Tip
- | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
-
-type Size = Int
-
-instance (Ord k) => Monoid (Map k v) where
- mempty = empty
- mappend = union
- mconcat = unions
-
-#if __GLASGOW_HASKELL__
-
-{--------------------------------------------------------------------
- A Data instance
---------------------------------------------------------------------}
-
--- This instance preserves data abstraction at the cost of inefficiency.
--- We omit reflection services for the sake of data abstraction.
-
-instance (Data k, Data a, Ord k) => Data (Map k a) where
- gfoldl f z m = z fromList `f` toList m
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNoRepType "Data.Map.Map"
- dataCast2 f = gcast2 f
-
-#endif
-
-{--------------------------------------------------------------------
- Query
---------------------------------------------------------------------}
--- | /O(1)/. Is the map empty?
---
--- > Data.Map.null (empty) == True
--- > Data.Map.null (singleton 1 'a') == False
-
-null :: Map k a -> Bool
-null Tip = True
-null (Bin {}) = False
-
--- | /O(1)/. The number of elements in the map.
---
--- > size empty == 0
--- > size (singleton 1 'a') == 1
--- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3
-
-size :: Map k a -> Int
-size Tip = 0
-size (Bin sz _ _ _ _) = sz
-
-
--- | /O(log n)/. Lookup the value at a key in the map.
---
--- The function will return the corresponding value as @('Just' value)@,
--- or 'Nothing' if the key isn't in the map.
---
--- An example of using @lookup@:
---
--- > import Prelude hiding (lookup)
--- > import Data.Map
--- >
--- > employeeDept = fromList([("John","Sales"), ("Bob","IT")])
--- > deptCountry = fromList([("IT","USA"), ("Sales","France")])
--- > countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")])
--- >
--- > employeeCurrency :: String -> Maybe String
--- > employeeCurrency name = do
--- > dept <- lookup name employeeDept
--- > country <- lookup dept deptCountry
--- > lookup country countryCurrency
--- >
--- > main = do
--- > putStrLn $ "John's currency: " ++ (show (employeeCurrency "John"))
--- > putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete"))
---
--- The output of this program:
---
--- > John's currency: Just "Euro"
--- > Pete's currency: Nothing
-
-lookup :: Ord k => k -> Map k a -> Maybe a
-lookup k = k `seq` go
- where
- go Tip = Nothing
- go (Bin _ kx x l r) =
- case compare k kx of
- LT -> go l
- GT -> go r
- EQ -> Just x
-
-lookupAssoc :: Ord k => k -> Map k a -> Maybe (k,a)
-lookupAssoc k = k `seq` go
- where
- go Tip = Nothing
- go (Bin _ kx x l r) =
- case compare k kx of
- LT -> go l
- GT -> go r
- EQ -> Just (kx,x)
-
--- | /O(log n)/. Is the key a member of the map? See also 'notMember'.
---
--- > member 5 (fromList [(5,'a'), (3,'b')]) == True
--- > member 1 (fromList [(5,'a'), (3,'b')]) == False
-
-member :: Ord k => k -> Map k a -> Bool
-member k m = case lookup k m of
- Nothing -> False
- Just _ -> True
-
--- | /O(log n)/. Is the key not a member of the map? See also 'member'.
---
--- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False
--- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True
-
-notMember :: Ord k => k -> Map k a -> Bool
-notMember k m = not $ member k m
-
--- | /O(log n)/. Find the value at a key.
--- Calls 'error' when the element can not be found.
--- Consider using 'lookup' when elements may not be present.
-find :: Ord k => k -> Map k a -> a
-find k m = case lookup k m of
- Nothing -> error "Map.find: element not in the map"
- Just x -> x
-
--- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns
--- the value at key @k@ or returns default value @def@
--- when the key is not in the map.
---
--- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'
--- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'
-
-findWithDefault :: Ord k => a -> k -> Map k a -> a
-findWithDefault def k m = case lookup k m of
- Nothing -> def
- Just x -> x
-
-{--------------------------------------------------------------------
- Construction
---------------------------------------------------------------------}
--- | /O(1)/. The empty map.
---
--- > empty == fromList []
--- > size empty == 0
-
-empty :: Map k a
-empty = Tip
-
--- | /O(1)/. A map with a single element.
---
--- > singleton 1 'a' == fromList [(1, 'a')]
--- > size (singleton 1 'a') == 1
-
-singleton :: k -> a -> Map k a
-singleton k x = Bin 1 k x Tip Tip
-
-{--------------------------------------------------------------------
- Insertion
---------------------------------------------------------------------}
--- | /O(log n)/. Insert a new key and value in the map.
--- If the key is already present in the map, the associated value is
--- replaced with the supplied value. 'insert' is equivalent to
--- @'insertWith' 'const'@.
---
--- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]
--- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]
--- > insert 5 'x' empty == singleton 5 'x'
-
-insert :: Ord k => k -> a -> Map k a -> Map k a
-insert kx x = kx `seq` go
- where
- go Tip = singleton kx x
- go (Bin sz ky y l r) =
- case compare kx ky of
- LT -> balance ky y (go l) r
- GT -> balance ky y l (go r)
- EQ -> Bin sz kx x l r
-
--- | /O(log n)/. Insert with a function, combining new value and old value.
--- @'insertWith' f key value mp@
--- will insert the pair (key, value) into @mp@ if key does
--- not exist in the map. If the key does exist, the function will
--- insert the pair @(key, f new_value old_value)@.
---
--- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]
--- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
--- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"
-
-insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
-insertWith f = insertWithKey (\_ x' y' -> f x' y')
-
--- | Same as 'insertWith', but the combining function is applied strictly.
--- This is often the most desirable behavior.
---
--- For example, to update a counter:
---
--- > insertWith' (+) k 1 m
---
-insertWith' :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
-insertWith' f = insertWithKey' (\_ x' y' -> f x' y')
-
--- | /O(log n)/. Insert with a function, combining key, new value and old value.
--- @'insertWithKey' f key value mp@
--- will insert the pair (key, value) into @mp@ if key does
--- not exist in the map. If the key does exist, the function will
--- insert the pair @(key,f key new_value old_value)@.
--- Note that the key passed to f is the same key passed to 'insertWithKey'.
---
--- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
--- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]
--- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
--- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"
-
-insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
-insertWithKey f kx x = kx `seq` go
- where
- go Tip = singleton kx x
- go (Bin sy ky y l r) =
- case compare kx ky of
- LT -> balance ky y (go l) r
- GT -> balance ky y l (go r)
- EQ -> Bin sy kx (f kx x y) l r
-
--- | Same as 'insertWithKey', but the combining function is applied strictly.
-insertWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
-insertWithKey' f kx x = kx `seq` go
- where
- go Tip = singleton kx $! x
- go (Bin sy ky y l r) =
- case compare kx ky of
- LT -> balance ky y (go l) r
- GT -> balance ky y l (go r)
- EQ -> let x' = f kx x y in seq x' (Bin sy kx x' l r)
-
--- | /O(log n)/. Combines insert operation with old value retrieval.
--- The expression (@'insertLookupWithKey' f k x map@)
--- is a pair where the first element is equal to (@'lookup' k map@)
--- and the second element equal to (@'insertWithKey' f k x map@).
---
--- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
--- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])
--- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])
--- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx")
---
--- This is how to define @insertLookup@ using @insertLookupWithKey@:
---
--- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t
--- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])
--- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])
-
-insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a
- -> (Maybe a, Map k a)
-insertLookupWithKey f kx x = kx `seq` go
- where
- go Tip = (Nothing, singleton kx x)
- go (Bin sy ky y l r) =
- case compare kx ky of
- LT -> let (found, l') = go l
- in (found, balance ky y l' r)
- GT -> let (found, r') = go r
- in (found, balance ky y l r')
- EQ -> (Just y, Bin sy kx (f kx x y) l r)
-
--- | /O(log n)/. A strict version of 'insertLookupWithKey'.
-insertLookupWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a
- -> (Maybe a, Map k a)
-insertLookupWithKey' f kx x = kx `seq` go
- where
- go Tip = x `seq` (Nothing, singleton kx x)
- go (Bin sy ky y l r) =
- case compare kx ky of
- LT -> let (found, l') = go l
- in (found, balance ky y l' r)
- GT -> let (found, r') = go r
- in (found, balance ky y l r')
- EQ -> let x' = f kx x y in x' `seq` (Just y, Bin sy kx x' l r)
-
-{--------------------------------------------------------------------
- Deletion
- [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
---------------------------------------------------------------------}
--- | /O(log n)/. Delete a key and its value from the map. When the key is not
--- a member of the map, the original map is returned.
---
--- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
--- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
--- > delete 5 empty == empty
-
-delete :: Ord k => k -> Map k a -> Map k a
-delete k = k `seq` go
- where
- go Tip = Tip
- go (Bin _ kx x l r) =
- case compare k kx of
- LT -> balance kx x (go l) r
- GT -> balance kx x l (go r)
- EQ -> glue l r
-
--- | /O(log n)/. Update a value at a specific key with the result of the provided function.
--- When the key is not
--- a member of the map, the original map is returned.
---
--- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
--- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
--- > adjust ("new " ++) 7 empty == empty
-
-adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
-adjust f = adjustWithKey (\_ x -> f x)
-
--- | /O(log n)/. Adjust a value at a specific key. When the key is not
--- a member of the map, the original map is returned.
---
--- > let f key x = (show key) ++ ":new " ++ x
--- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
--- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
--- > adjustWithKey f 7 empty == empty
-
-adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
-adjustWithKey f = updateWithKey (\k' x' -> Just (f k' x'))
-
--- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@
--- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
---
--- > let f x = if x == "a" then Just "new a" else Nothing
--- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
--- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
--- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-
-update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
-update f = updateWithKey (\_ x -> f x)
-
--- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
--- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
--- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
--- to the new value @y@.
---
--- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
--- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
--- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
--- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-
-updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
-updateWithKey f k = k `seq` go
- where
- go Tip = Tip
- go (Bin sx kx x l r) =
- case compare k kx of
- LT -> balance kx x (go l) r
- GT -> balance kx x l (go r)
- EQ -> case f kx x of
- Just x' -> Bin sx kx x' l r
- Nothing -> glue l r
-
--- | /O(log n)/. Lookup and update. See also 'updateWithKey'.
--- The function returns changed value, if it is updated.
--- Returns the original key value if the map entry is deleted.
---
--- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
--- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])
--- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])
--- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")
-
-updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
-updateLookupWithKey f k = k `seq` go
- where
- go Tip = (Nothing,Tip)
- go (Bin sx kx x l r) =
- case compare k kx of
- LT -> let (found,l') = go l in (found,balance kx x l' r)
- GT -> let (found,r') = go r in (found,balance kx x l r')
- EQ -> case f kx x of
- Just x' -> (Just x',Bin sx kx x' l r)
- Nothing -> (Just x,glue l r)
-
--- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
--- 'alter' can be used to insert, delete, or update a value in a 'Map'.
--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.
---
--- > let f _ = Nothing
--- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
--- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
--- >
--- > let f _ = Just "c"
--- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]
--- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]
-
-alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a
-alter f k = k `seq` go
- where
- go Tip = case f Nothing of
- Nothing -> Tip
- Just x -> singleton k x
-
- go (Bin sx kx x l r) = case compare k kx of
- LT -> balance kx x (go l) r
- GT -> balance kx x l (go r)
- EQ -> case f (Just x) of
- Just x' -> Bin sx kx x' l r
- Nothing -> glue l r
-
-{--------------------------------------------------------------------
- Indexing
---------------------------------------------------------------------}
--- | /O(log n)/. Return the /index/ of a key. The index is a number from
--- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
--- the key is not a 'member' of the map.
---
--- > findIndex 2 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map
--- > findIndex 3 (fromList [(5,"a"), (3,"b")]) == 0
--- > findIndex 5 (fromList [(5,"a"), (3,"b")]) == 1
--- > findIndex 6 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map
-
-findIndex :: Ord k => k -> Map k a -> Int
-findIndex k t
- = case lookupIndex k t of
- Nothing -> error "Map.findIndex: element is not in the map"
- Just idx -> idx
-
--- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
--- /0/ up to, but not including, the 'size' of the map.
---
--- > isJust (lookupIndex 2 (fromList [(5,"a"), (3,"b")])) == False
--- > fromJust (lookupIndex 3 (fromList [(5,"a"), (3,"b")])) == 0
--- > fromJust (lookupIndex 5 (fromList [(5,"a"), (3,"b")])) == 1
--- > isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")])) == False
-
-lookupIndex :: Ord k => k -> Map k a -> Maybe Int
-lookupIndex k = k `seq` go 0
- where
- go idx Tip = idx `seq` Nothing
- go idx (Bin _ kx _ l r)
- = idx `seq` case compare k kx of
- LT -> go idx l
- GT -> go (idx + size l + 1) r
- EQ -> Just (idx + size l)
-
--- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
--- invalid index is used.
---
--- > elemAt 0 (fromList [(5,"a"), (3,"b")]) == (3,"b")
--- > elemAt 1 (fromList [(5,"a"), (3,"b")]) == (5, "a")
--- > elemAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
-
-elemAt :: Int -> Map k a -> (k,a)
-elemAt _ Tip = error "Map.elemAt: index out of range"
-elemAt i (Bin _ kx x l r)
- = case compare i sizeL of
- LT -> elemAt i l
- GT -> elemAt (i-sizeL-1) r
- EQ -> (kx,x)
- where
- sizeL = size l
-
--- | /O(log n)/. Update the element at /index/. Calls 'error' when an
--- invalid index is used.
---
--- > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]
--- > updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")]
--- > updateAt (\ _ _ -> Just "x") 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
--- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range
--- > updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
--- > updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
--- > updateAt (\_ _ -> Nothing) 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
--- > updateAt (\_ _ -> Nothing) (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range
-
-updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
-updateAt f i0 t = i0 `seq` go i0 t
- where
- go _ Tip = error "Map.updateAt: index out of range"
- go i (Bin sx kx x l r) = case compare i sizeL of
- LT -> balance kx x (go i l) r
- GT -> balance kx x l (go (i-sizeL-1) r)
- EQ -> case f kx x of
- Just x' -> Bin sx kx x' l r
- Nothing -> glue l r
- where
- sizeL = size l
-
--- | /O(log n)/. Delete the element at /index/.
--- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).
---
--- > deleteAt 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
--- > deleteAt 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
--- > deleteAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
--- > deleteAt (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range
-
-deleteAt :: Int -> Map k a -> Map k a
-deleteAt i m
- = updateAt (\_ _ -> Nothing) i m
-
-
-{--------------------------------------------------------------------
- Minimal, Maximal
---------------------------------------------------------------------}
--- | /O(log n)/. The minimal key of the map. Calls 'error' is the map is empty.
---
--- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")
--- > findMin empty Error: empty map has no minimal element
-
-findMin :: Map k a -> (k,a)
-findMin (Bin _ kx x Tip _) = (kx,x)
-findMin (Bin _ _ _ l _) = findMin l
-findMin Tip = error "Map.findMin: empty map has no minimal element"
-
--- | /O(log n)/. The maximal key of the map. Calls 'error' is the map is empty.
---
--- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")
--- > findMax empty Error: empty map has no maximal element
-
-findMax :: Map k a -> (k,a)
-findMax (Bin _ kx x _ Tip) = (kx,x)
-findMax (Bin _ _ _ _ r) = findMax r
-findMax Tip = error "Map.findMax: empty map has no maximal element"
-
--- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty.
---
--- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]
--- > deleteMin empty == empty
-
-deleteMin :: Map k a -> Map k a
-deleteMin (Bin _ _ _ Tip r) = r
-deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r
-deleteMin Tip = Tip
-
--- | /O(log n)/. Delete the maximal key. Returns an empty map if the map is empty.
---
--- > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]
--- > deleteMax empty == empty
-
-deleteMax :: Map k a -> Map k a
-deleteMax (Bin _ _ _ l Tip) = l
-deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r)
-deleteMax Tip = Tip
-
--- | /O(log n)/. Update the value at the minimal key.
---
--- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]
--- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-
-updateMin :: (a -> Maybe a) -> Map k a -> Map k a
-updateMin f m
- = updateMinWithKey (\_ x -> f x) m
-
--- | /O(log n)/. Update the value at the maximal key.
---
--- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]
--- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
-
-updateMax :: (a -> Maybe a) -> Map k a -> Map k a
-updateMax f m
- = updateMaxWithKey (\_ x -> f x) m
-
-
--- | /O(log n)/. Update the value at the minimal key.
---
--- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]
--- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-
-updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
-updateMinWithKey f = go
- where
- go (Bin sx kx x Tip r) = case f kx x of
- Nothing -> r
- Just x' -> Bin sx kx x' Tip r
- go (Bin _ kx x l r) = balance kx x (go l) r
- go Tip = Tip
-
--- | /O(log n)/. Update the value at the maximal key.
---
--- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]
--- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
-
-updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
-updateMaxWithKey f = go
- where
- go (Bin sx kx x l Tip) = case f kx x of
- Nothing -> l
- Just x' -> Bin sx kx x' l Tip
- go (Bin _ kx x l r) = balance kx x l (go r)
- go Tip = Tip
-
--- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and
--- the map stripped of that element, or 'Nothing' if passed an empty map.
---
--- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")
--- > minViewWithKey empty == Nothing
-
-minViewWithKey :: Map k a -> Maybe ((k,a), Map k a)
-minViewWithKey Tip = Nothing
-minViewWithKey x = Just (deleteFindMin x)
-
--- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and
--- the map stripped of that element, or 'Nothing' if passed an empty map.
---
--- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")
--- > maxViewWithKey empty == Nothing
-
-maxViewWithKey :: Map k a -> Maybe ((k,a), Map k a)
-maxViewWithKey Tip = Nothing
-maxViewWithKey x = Just (deleteFindMax x)
-
--- | /O(log n)/. Retrieves the value associated with minimal key of the
--- map, and the map stripped of that element, or 'Nothing' if passed an
--- empty map.
---
--- > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a")
--- > minView empty == Nothing
-
-minView :: Map k a -> Maybe (a, Map k a)
-minView Tip = Nothing
-minView x = Just (first snd $ deleteFindMin x)
-
--- | /O(log n)/. Retrieves the value associated with maximal key of the
--- map, and the map stripped of that element, or 'Nothing' if passed an
---
--- > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b")
--- > maxView empty == Nothing
-
-maxView :: Map k a -> Maybe (a, Map k a)
-maxView Tip = Nothing
-maxView x = Just (first snd $ deleteFindMax x)
-
--- Update the 1st component of a tuple (special case of Control.Arrow.first)
-first :: (a -> b) -> (a,c) -> (b,c)
-first f (x,y) = (f x, y)
-
-{--------------------------------------------------------------------
- Union.
---------------------------------------------------------------------}
--- | The union of a list of maps:
--- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).
---
--- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
--- > == fromList [(3, "b"), (5, "a"), (7, "C")]
--- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]
--- > == fromList [(3, "B3"), (5, "A3"), (7, "C")]
-
-unions :: Ord k => [Map k a] -> Map k a
-unions ts
- = foldlStrict union empty ts
-
--- | The union of a list of maps, with a combining operation:
--- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
---
--- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
--- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]
-
-unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
-unionsWith f ts
- = foldlStrict (unionWith f) empty ts
-
--- | /O(n+m)/.
--- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
--- It prefers @t1@ when duplicate keys are encountered,
--- i.e. (@'union' == 'unionWith' 'const'@).
--- The implementation uses the efficient /hedge-union/ algorithm.
--- Hedge-union is more efficient on (bigset \``union`\` smallset).
---
--- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]
-
-union :: Ord k => Map k a -> Map k a -> Map k a
-union Tip t2 = t2
-union t1 Tip = t1
-union t1 t2 = hedgeUnionL (const LT) (const GT) t1 t2
-
--- left-biased hedge union
-hedgeUnionL :: Ord a
- => (a -> Ordering) -> (a -> Ordering) -> Map a b -> Map a b
- -> Map a b
-hedgeUnionL _ _ t1 Tip
- = t1
-hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)
- = join kx x (filterGt cmplo l) (filterLt cmphi r)
-hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2
- = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2))
- (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))
- where
- cmpkx k = compare kx k
-
-{--------------------------------------------------------------------
- Union with a combining function
---------------------------------------------------------------------}
--- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
---
--- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]
-
-unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
-unionWith f m1 m2
- = unionWithKey (\_ x y -> f x y) m1 m2
-
--- | /O(n+m)/.
--- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
--- Hedge-union is more efficient on (bigset \``union`\` smallset).
---
--- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value
--- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]
-
-unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
-unionWithKey _ Tip t2 = t2
-unionWithKey _ t1 Tip = t1
-unionWithKey f t1 t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2
-
-hedgeUnionWithKey :: Ord a
- => (a -> b -> b -> b)
- -> (a -> Ordering) -> (a -> Ordering)
- -> Map a b -> Map a b
- -> Map a b
-hedgeUnionWithKey _ _ _ t1 Tip
- = t1
-hedgeUnionWithKey _ cmplo cmphi Tip (Bin _ kx x l r)
- = join kx x (filterGt cmplo l) (filterLt cmphi r)
-hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2
- = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt)
- (hedgeUnionWithKey f cmpkx cmphi r gt)
- where
- cmpkx k = compare kx k
- lt = trim cmplo cmpkx t2
- (found,gt) = trimLookupLo kx cmphi t2
- newx = case found of
- Nothing -> x
- Just (_,y) -> f kx x y
-
-{--------------------------------------------------------------------
- Difference
---------------------------------------------------------------------}
--- | /O(n+m)/. Difference of two maps.
--- Return elements of the first map not existing in the second map.
--- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
---
--- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"
-
-difference :: Ord k => Map k a -> Map k b -> Map k a
-difference Tip _ = Tip
-difference t1 Tip = t1
-difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
-
-hedgeDiff :: Ord a
- => (a -> Ordering) -> (a -> Ordering) -> Map a b -> Map a c
- -> Map a b
-hedgeDiff _ _ Tip _
- = Tip
-hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip
- = join kx x (filterGt cmplo l) (filterLt cmphi r)
-hedgeDiff cmplo cmphi t (Bin _ kx _ l r)
- = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l)
- (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)
- where
- cmpkx k = compare kx k
-
--- | /O(n+m)/. Difference with a combining function.
--- When two equal keys are
--- encountered, the combining function is applied to the values of these keys.
--- If it returns 'Nothing', the element is discarded (proper set difference). If
--- it returns (@'Just' y@), the element is updated with a new value @y@.
--- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
---
--- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing
--- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])
--- > == singleton 3 "b:B"
-
-differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
-differenceWith f m1 m2
- = differenceWithKey (\_ x y -> f x y) m1 m2
-
--- | /O(n+m)/. Difference with a combining function. When two equal keys are
--- encountered, the combining function is applied to the key and both values.
--- If it returns 'Nothing', the element is discarded (proper set difference). If
--- it returns (@'Just' y@), the element is updated with a new value @y@.
--- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
---
--- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing
--- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])
--- > == singleton 3 "3:b|B"
-
-differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
-differenceWithKey _ Tip _ = Tip
-differenceWithKey _ t1 Tip = t1
-differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2
-
-hedgeDiffWithKey :: Ord a
- => (a -> b -> c -> Maybe b)
- -> (a -> Ordering) -> (a -> Ordering)
- -> Map a b -> Map a c
- -> Map a b
-hedgeDiffWithKey _ _ _ Tip _
- = Tip
-hedgeDiffWithKey _ cmplo cmphi (Bin _ kx x l r) Tip
- = join kx x (filterGt cmplo l) (filterLt cmphi r)
-hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r)
- = case found of
- Nothing -> merge tl tr
- Just (ky,y) ->
- case f ky y x of
- Nothing -> merge tl tr
- Just z -> join ky z tl tr
- where
- cmpkx k = compare kx k
- lt = trim cmplo cmpkx t
- (found,gt) = trimLookupLo kx cmphi t
- tl = hedgeDiffWithKey f cmplo cmpkx lt l
- tr = hedgeDiffWithKey f cmpkx cmphi gt r
-
-
-
-{--------------------------------------------------------------------
- Intersection
---------------------------------------------------------------------}
--- | /O(n+m)/. Intersection of two maps.
--- Return data in the first map for the keys existing in both maps.
--- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
---
--- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"
-
-intersection :: Ord k => Map k a -> Map k b -> Map k a
-intersection m1 m2
- = intersectionWithKey (\_ x _ -> x) m1 m2
-
--- | /O(n+m)/. Intersection with a combining function.
---
--- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"
-
-intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c
-intersectionWith f m1 m2
- = intersectionWithKey (\_ x y -> f x y) m1 m2
-
--- | /O(n+m)/. Intersection with a combining function.
--- Intersection is more efficient on (bigset \``intersection`\` smallset).
---
--- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar
--- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"
-
---intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
---intersectionWithKey f Tip t = Tip
---intersectionWithKey f t Tip = Tip
---intersectionWithKey f t1 t2 = intersectWithKey f t1 t2
---
---intersectWithKey f Tip t = Tip
---intersectWithKey f t Tip = Tip
---intersectWithKey f t (Bin _ kx x l r)
--- = case found of
--- Nothing -> merge tl tr
--- Just y -> join kx (f kx y x) tl tr
--- where
--- (lt,found,gt) = splitLookup kx t
--- tl = intersectWithKey f lt l
--- tr = intersectWithKey f gt r
-
-intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
-intersectionWithKey _ Tip _ = Tip
-intersectionWithKey _ _ Tip = Tip
-intersectionWithKey f t1@(Bin s1 k1 x1 l1 r1) t2@(Bin s2 k2 x2 l2 r2) =
- if s1 >= s2 then
- let (lt,found,gt) = splitLookupWithKey k2 t1
- tl = intersectionWithKey f lt l2
- tr = intersectionWithKey f gt r2
- in case found of
- Just (k,x) -> join k (f k x x2) tl tr
- Nothing -> merge tl tr
- else let (lt,found,gt) = splitLookup k1 t2
- tl = intersectionWithKey f l1 lt
- tr = intersectionWithKey f r1 gt
- in case found of
- Just x -> join k1 (f k1 x1 x) tl tr
- Nothing -> merge tl tr
-
-
-
-{--------------------------------------------------------------------
- Submap
---------------------------------------------------------------------}
--- | /O(n+m)/.
--- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
---
-isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
-isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2
-
-{- | /O(n+m)/.
- The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
- all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when
- applied to their respective values. For example, the following
- expressions are all 'True':
-
- > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
- > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
- > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
-
- But the following are all 'False':
-
- > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
- > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
- > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
-
-
--}
-isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
-isSubmapOfBy f t1 t2
- = (size t1 <= size t2) && (submap' f t1 t2)
-
-submap' :: Ord a => (b -> c -> Bool) -> Map a b -> Map a c -> Bool
-submap' _ Tip _ = True
-submap' _ _ Tip = False
-submap' f (Bin _ kx x l r) t
- = case found of
- Nothing -> False
- Just y -> f x y && submap' f l lt && submap' f r gt
- where
- (lt,found,gt) = splitLookup kx t
-
--- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
--- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
-isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
-isProperSubmapOf m1 m2
- = isProperSubmapOfBy (==) m1 m2
-
-{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
- The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
- @m1@ and @m2@ are not equal,
- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
- applied to their respective values. For example, the following
- expressions are all 'True':
-
- > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
- > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
-
- But the following are all 'False':
-
- > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
- > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
- > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
-
-
--}
-isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
-isProperSubmapOfBy f t1 t2
- = (size t1 < size t2) && (submap' f t1 t2)
-
-{--------------------------------------------------------------------
- Filter and partition
---------------------------------------------------------------------}
--- | /O(n)/. Filter all values that satisfy the predicate.
---
--- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
--- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty
--- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty
-
-filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
-filter p m
- = filterWithKey (\_ x -> p x) m
-
--- | /O(n)/. Filter all keys\/values that satisfy the predicate.
---
--- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-
-filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
-filterWithKey p = go
- where
- go Tip = Tip
- go (Bin _ kx x l r)
- | p kx x = join kx x (go l) (go r)
- | otherwise = merge (go l) (go r)
-
--- | /O(n)/. Partition the map according to a predicate. The first
--- map contains all elements that satisfy the predicate, the second all
--- elements that fail the predicate. See also 'split'.
---
--- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
--- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
--- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
-
-partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
-partition p m
- = partitionWithKey (\_ x -> p x) m
-
--- | /O(n)/. Partition the map according to a predicate. The first
--- map contains all elements that satisfy the predicate, the second all
--- elements that fail the predicate. See also 'split'.
---
--- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")
--- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
--- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
-
-partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
-partitionWithKey _ Tip = (Tip,Tip)
-partitionWithKey p (Bin _ kx x l r)
- | p kx x = (join kx x l1 r1,merge l2 r2)
- | otherwise = (merge l1 r1,join kx x l2 r2)
- where
- (l1,l2) = partitionWithKey p l
- (r1,r2) = partitionWithKey p r
-
--- | /O(n)/. Map values and collect the 'Just' results.
---
--- > let f x = if x == "a" then Just "new a" else Nothing
--- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"
-
-mapMaybe :: Ord k => (a -> Maybe b) -> Map k a -> Map k b
-mapMaybe f = mapMaybeWithKey (\_ x -> f x)
-
--- | /O(n)/. Map keys\/values and collect the 'Just' results.
---
--- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing
--- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"
-
-mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> Map k a -> Map k b
-mapMaybeWithKey f = go
- where
- go Tip = Tip
- go (Bin _ kx x l r) = case f kx x of
- Just y -> join kx y (go l) (go r)
- Nothing -> merge (go l) (go r)
-
--- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
---
--- > let f a = if a < "c" then Left a else Right a
--- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
--- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])
--- >
--- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
--- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
-
-mapEither :: Ord k => (a -> Either b c) -> Map k a -> (Map k b, Map k c)
-mapEither f m
- = mapEitherWithKey (\_ x -> f x) m
-
--- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
---
--- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)
--- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
--- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])
--- >
--- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
--- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
-
-mapEitherWithKey :: Ord k =>
- (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)
-mapEitherWithKey _ Tip = (Tip, Tip)
-mapEitherWithKey f (Bin _ kx x l r) = case f kx x of
- Left y -> (join kx y l1 r1, merge l2 r2)
- Right z -> (merge l1 r1, join kx z l2 r2)
- where
- (l1,l2) = mapEitherWithKey f l
- (r1,r2) = mapEitherWithKey f r
-
-{--------------------------------------------------------------------
- Mapping
---------------------------------------------------------------------}
--- | /O(n)/. Map a function over all values in the map.
---
--- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]
-
-map :: (a -> b) -> Map k a -> Map k b
-map f = mapWithKey (\_ x -> f x)
-
--- | /O(n)/. Map a function over all values in the map.
---
--- > let f key x = (show key) ++ ":" ++ x
--- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]
-
-mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
-mapWithKey f = go
- where
- go Tip = Tip
- go (Bin sx kx x l r) = Bin sx kx (f kx x) (go l) (go r)
-
--- | /O(n)/. The function 'mapAccum' threads an accumulating
--- argument through the map in ascending order of keys.
---
--- > let f a b = (a ++ b, b ++ "X")
--- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])
-
-mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
-mapAccum f a m
- = mapAccumWithKey (\a' _ x' -> f a' x') a m
-
--- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
--- argument through the map in ascending order of keys.
---
--- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")
--- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])
-
-mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
-mapAccumWithKey f a t
- = mapAccumL f a t
-
--- | /O(n)/. The function 'mapAccumL' threads an accumulating
--- argument throught the map in ascending order of keys.
-mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
-mapAccumL f = go
- where
- go a Tip = (a,Tip)
- go a (Bin sx kx x l r) =
- let (a1,l') = go a l
- (a2,x') = f a1 kx x
- (a3,r') = go a2 r
- in (a3,Bin sx kx x' l' r')
-
--- | /O(n)/. The function 'mapAccumR' threads an accumulating
--- argument through the map in descending order of keys.
-mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
-mapAccumRWithKey f = go
- where
- go a Tip = (a,Tip)
- go a (Bin sx kx x l r) =
- let (a1,r') = go a r
- (a2,x') = f a1 kx x
- (a3,l') = go a2 l
- in (a3,Bin sx kx x' l' r')
-
--- | /O(n*log n)/.
--- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
---
--- The size of the result may be smaller if @f@ maps two or more distinct
--- keys to the same new key. In this case the value at the smallest of
--- these keys is retained.
---
--- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")]
--- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"
--- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"
-
-mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
-mapKeys = mapKeysWith (\x _ -> x)
-
--- | /O(n*log n)/.
--- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
---
--- The size of the result may be smaller if @f@ maps two or more distinct
--- keys to the same new key. In this case the associated values will be
--- combined using @c@.
---
--- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"
--- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"
-
-mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
-mapKeysWith c f = fromListWith c . List.map fFirst . toList
- where fFirst (x,y) = (f x, y)
-
-
--- | /O(n)/.
--- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
--- is strictly monotonic.
--- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.
--- /The precondition is not checked./
--- Semi-formally, we have:
---
--- > and [x < y ==> f x < f y | x <- ls, y <- ls]
--- > ==> mapKeysMonotonic f s == mapKeys f s
--- > where ls = keys s
---
--- This means that @f@ maps distinct original keys to distinct resulting keys.
--- This function has better performance than 'mapKeys'.
---
--- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]
--- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True
--- > valid (mapKeysMonotonic (\ _ -> 1) (fromList [(5,"a"), (3,"b")])) == False
-
-mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
-mapKeysMonotonic _ Tip = Tip
-mapKeysMonotonic f (Bin sz k x l r) =
- Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
-
-{--------------------------------------------------------------------
- Folds
---------------------------------------------------------------------}
-
--- | /O(n)/. Fold the values in the map, such that
--- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
--- For example,
---
--- > elems map = fold (:) [] map
---
--- > let f a len = len + (length a)
--- > fold f 0 (fromList [(5,"a"), (3,"bbb")]) == 4
-fold :: (a -> b -> b) -> b -> Map k a -> b
-fold f = foldWithKey (\_ x' z' -> f x' z')
-
--- | /O(n)/. Fold the keys and values in the map, such that
--- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
--- For example,
---
--- > keys map = foldWithKey (\k x ks -> k:ks) [] map
---
--- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
--- > foldWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"
---
--- This is identical to 'foldrWithKey', and you should use that one instead of
--- this one. This name is kept for backward compatibility.
-foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
-foldWithKey = foldrWithKey
-{-# DEPRECATED foldWithKey "Use foldrWithKey instead" #-}
-
--- | /O(n)/. Post-order fold. The function will be applied from the lowest
--- value to the highest.
-foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
-foldrWithKey f = go
- where
- go z Tip = z
- go z (Bin _ kx x l r) = go (f kx x (go z r)) l
-
--- | /O(n)/. Pre-order fold. The function will be applied from the highest
--- value to the lowest.
-foldlWithKey :: (b -> k -> a -> b) -> b -> Map k a -> b
-foldlWithKey f = go
- where
- go z Tip = z
- go z (Bin _ kx x l r) = go (f (go z l) kx x) r
-
-{-
--- | /O(n)/. A strict version of 'foldlWithKey'.
-foldlWithKey' :: (b -> k -> a -> b) -> b -> Map k a -> b
-foldlWithKey' f = go
- where
- go z Tip = z
- go z (Bin _ kx x l r) = z `seq` go (f (go z l) kx x) r
--}
-
-{--------------------------------------------------------------------
- List variations
---------------------------------------------------------------------}
--- | /O(n)/.
--- Return all elements of the map in the ascending order of their keys.
---
--- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]
--- > elems empty == []
-
-elems :: Map k a -> [a]
-elems m
- = [x | (_,x) <- assocs m]
-
--- | /O(n)/. Return all keys of the map in ascending order.
---
--- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]
--- > keys empty == []
-
-keys :: Map k a -> [k]
-keys m
- = [k | (k,_) <- assocs m]
-
--- | /O(n)/. The set of all keys of the map.
---
--- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5]
--- > keysSet empty == Data.Set.empty
-
-keysSet :: Map k a -> Set.Set k
-keysSet m = Set.fromDistinctAscList (keys m)
-
--- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
---
--- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
--- > assocs empty == []
-
-assocs :: Map k a -> [(k,a)]
-assocs m
- = toList m
-
-{--------------------------------------------------------------------
- Lists
- use [foldlStrict] to reduce demand on the control-stack
---------------------------------------------------------------------}
--- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
--- If the list contains more than one value for the same key, the last value
--- for the key is retained.
---
--- > fromList [] == empty
--- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
--- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]
-
-fromList :: Ord k => [(k,a)] -> Map k a
-fromList xs
- = foldlStrict ins empty xs
- where
- ins t (k,x) = insert k x t
-
--- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
---
--- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]
--- > fromListWith (++) [] == empty
-
-fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
-fromListWith f xs
- = fromListWithKey (\_ x y -> f x y) xs
-
--- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
---
--- > let f k a1 a2 = (show k) ++ a1 ++ a2
--- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]
--- > fromListWithKey f [] == empty
-
-fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
-fromListWithKey f xs
- = foldlStrict ins empty xs
- where
- ins t (k,x) = insertWithKey f k x t
-
--- | /O(n)/. Convert to a list of key\/value pairs.
---
--- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
--- > toList empty == []
-
-toList :: Map k a -> [(k,a)]
-toList t = toAscList t
-
--- | /O(n)/. Convert to an ascending list.
---
--- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
-
-toAscList :: Map k a -> [(k,a)]
-toAscList t = foldrWithKey (\k x xs -> (k,x):xs) [] t
-
--- | /O(n)/. Convert to a descending list.
-toDescList :: Map k a -> [(k,a)]
-toDescList t = foldlWithKey (\xs k x -> (k,x):xs) [] t
-
-{--------------------------------------------------------------------
- Building trees from ascending/descending lists can be done in linear time.
-
- Note that if [xs] is ascending that:
- fromAscList xs == fromList xs
- fromAscListWith f xs == fromListWith f xs
---------------------------------------------------------------------}
--- | /O(n)/. Build a map from an ascending list in linear time.
--- /The precondition (input list is ascending) is not checked./
---
--- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
--- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]
--- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True
--- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False
-
-fromAscList :: Eq k => [(k,a)] -> Map k a
-fromAscList xs
- = fromAscListWithKey (\_ x _ -> x) xs
-
--- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
--- /The precondition (input list is ascending) is not checked./
---
--- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]
--- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True
--- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False
-
-fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
-fromAscListWith f xs
- = fromAscListWithKey (\_ x y -> f x y) xs
-
--- | /O(n)/. Build a map from an ascending list in linear time with a
--- combining function for equal keys.
--- /The precondition (input list is ascending) is not checked./
---
--- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2
--- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]
--- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True
--- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False
-
-fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
-fromAscListWithKey f xs
- = fromDistinctAscList (combineEq f xs)
- where
- -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
- combineEq _ xs'
- = case xs' of
- [] -> []
- [x] -> [x]
- (x:xx) -> combineEq' x xx
-
- combineEq' z [] = [z]
- combineEq' z@(kz,zz) (x@(kx,xx):xs')
- | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs'
- | otherwise = z:combineEq' x xs'
-
-
--- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
--- /The precondition is not checked./
---
--- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
--- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True
--- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False
-
-fromDistinctAscList :: [(k,a)] -> Map k a
-fromDistinctAscList xs
- = build const (length xs) xs
- where
- -- 1) use continutations so that we use heap space instead of stack space.
- -- 2) special case for n==5 to build bushier trees.
- build c 0 xs' = c Tip xs'
- build c 5 xs' = case xs' of
- ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
- -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
- _ -> error "fromDistinctAscList build"
- build c n xs' = seq nr $ build (buildR nr c) nl xs'
- where
- nl = n `div` 2
- nr = n - nl - 1
-
- buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
- buildR _ _ _ [] = error "fromDistinctAscList buildR []"
- buildB l k x c r zs = c (bin k x l r) zs
-
-
-
-{--------------------------------------------------------------------
- Utility functions that return sub-ranges of the original
- tree. Some functions take a comparison function as argument to
- allow comparisons against infinite values. A function [cmplo k]
- should be read as [compare lo k].
-
- [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT]
- and [cmphi k == GT] for the key [k] of the root.
- [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT]
- [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT]
-
- [split k t] Returns two trees [l] and [r] where all keys
- in [l] are <[k] and all keys in [r] are >[k].
- [splitLookup k t] Just like [split] but also returns whether [k]
- was found in the tree.
---------------------------------------------------------------------}
-
-{--------------------------------------------------------------------
- [trim lo hi t] trims away all subtrees that surely contain no
- values between the range [lo] to [hi]. The returned tree is either
- empty or the key of the root is between @lo@ and @hi@.
---------------------------------------------------------------------}
-trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a
-trim _ _ Tip = Tip
-trim cmplo cmphi t@(Bin _ kx _ l r)
- = case cmplo kx of
- LT -> case cmphi kx of
- GT -> t
- _ -> trim cmplo cmphi l
- _ -> trim cmplo cmphi r
-
-trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe (k,a), Map k a)
-trimLookupLo _ _ Tip = (Nothing,Tip)
-trimLookupLo lo cmphi t@(Bin _ kx x l r)
- = case compare lo kx of
- LT -> case cmphi kx of
- GT -> (lookupAssoc lo t, t)
- _ -> trimLookupLo lo cmphi l
- GT -> trimLookupLo lo cmphi r
- EQ -> (Just (kx,x),trim (compare lo) cmphi r)
-
-
-{--------------------------------------------------------------------
- [filterGt k t] filter all keys >[k] from tree [t]
- [filterLt k t] filter all keys <[k] from tree [t]
---------------------------------------------------------------------}
-filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
-filterGt cmp = go
- where
- go Tip = Tip
- go (Bin _ kx x l r) = case cmp kx of
- LT -> join kx x (go l) r
- GT -> go r
- EQ -> r
-
-filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
-filterLt cmp = go
- where
- go Tip = Tip
- go (Bin _ kx x l r) = case cmp kx of
- LT -> go l
- GT -> join kx x l (go r)
- EQ -> l
-
-{--------------------------------------------------------------------
- Split
---------------------------------------------------------------------}
--- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where
--- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.
--- Any key equal to @k@ is found in neither @map1@ nor @map2@.
---
--- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])
--- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")
--- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
--- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)
--- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)
-
-split :: Ord k => k -> Map k a -> (Map k a,Map k a)
-split k = go
- where
- go Tip = (Tip, Tip)
- go (Bin _ kx x l r) = case compare k kx of
- LT -> let (lt,gt) = go l in (lt,join kx x gt r)
- GT -> let (lt,gt) = go r in (join kx x l lt,gt)
- EQ -> (l,r)
-
--- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just
--- like 'split' but also returns @'lookup' k map@.
---
--- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])
--- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")
--- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")
--- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)
--- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)
-
-splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)
-splitLookup k = go
- where
- go Tip = (Tip,Nothing,Tip)
- go (Bin _ kx x l r) = case compare k kx of
- LT -> let (lt,z,gt) = go l in (lt,z,join kx x gt r)
- GT -> let (lt,z,gt) = go r in (join kx x l lt,z,gt)
- EQ -> (l,Just x,r)
-
--- | /O(log n)/.
-splitLookupWithKey :: Ord k => k -> Map k a -> (Map k a,Maybe (k,a),Map k a)
-splitLookupWithKey k = go
- where
- go Tip = (Tip,Nothing,Tip)
- go (Bin _ kx x l r) = case compare k kx of
- LT -> let (lt,z,gt) = go l in (lt,z,join kx x gt r)
- GT -> let (lt,z,gt) = go r in (join kx x l lt,z,gt)
- EQ -> (l,Just (kx, x),r)
-
-{--------------------------------------------------------------------
- Utility functions that maintain the balance properties of the tree.
- All constructors assume that all values in [l] < [k] and all values
- in [r] > [k], and that [l] and [r] are valid trees.
-
- In order of sophistication:
- [Bin sz k x l r] The type constructor.
- [bin k x l r] Maintains the correct size, assumes that both [l]
- and [r] are balanced with respect to each other.
- [balance k x l r] Restores the balance and size.
- Assumes that the original tree was balanced and
- that [l] or [r] has changed by at most one element.
- [join k x l r] Restores balance and size.
-
- Furthermore, we can construct a new tree from two trees. Both operations
- assume that all values in [l] < all values in [r] and that [l] and [r]
- are valid:
- [glue l r] Glues [l] and [r] together. Assumes that [l] and
- [r] are already balanced with respect to each other.
- [merge l r] Merges two trees and restores balance.
-
- Note: in contrast to Adam's paper, we use (<=) comparisons instead
- of (<) comparisons in [join], [merge] and [balance].
- Quickcheck (on [difference]) showed that this was necessary in order
- to maintain the invariants. It is quite unsatisfactory that I haven't
- been able to find out why this is actually the case! Fortunately, it
- doesn't hurt to be a bit more conservative.
---------------------------------------------------------------------}
-
-{--------------------------------------------------------------------
- Join
---------------------------------------------------------------------}
-join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
-join kx x Tip r = insertMin kx x r
-join kx x l Tip = insertMax kx x l
-join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
- | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz
- | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r)
- | otherwise = bin kx x l r
-
-
--- insertMin and insertMax don't perform potentially expensive comparisons.
-insertMax,insertMin :: k -> a -> Map k a -> Map k a
-insertMax kx x t
- = case t of
- Tip -> singleton kx x
- Bin _ ky y l r
- -> balance ky y l (insertMax kx x r)
-
-insertMin kx x t
- = case t of
- Tip -> singleton kx x
- Bin _ ky y l r
- -> balance ky y (insertMin kx x l) r
-
-{--------------------------------------------------------------------
- [merge l r]: merges two trees.
---------------------------------------------------------------------}
-merge :: Map k a -> Map k a -> Map k a
-merge Tip r = r
-merge l Tip = l
-merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
- | delta*sizeL <= sizeR = balance ky y (merge l ly) ry
- | delta*sizeR <= sizeL = balance kx x lx (merge rx r)
- | otherwise = glue l r
-
-{--------------------------------------------------------------------
- [glue l r]: glues two trees together.
- Assumes that [l] and [r] are already balanced with respect to each other.
---------------------------------------------------------------------}
-glue :: Map k a -> Map k a -> Map k a
-glue Tip r = r
-glue l Tip = l
-glue l r
- | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r
- | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r'
-
-
--- | /O(log n)/. Delete and find the minimal element.
---
--- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")])
--- > deleteFindMin Error: can not return the minimal element of an empty map
-
-deleteFindMin :: Map k a -> ((k,a),Map k a)
-deleteFindMin t
- = case t of
- Bin _ k x Tip r -> ((k,x),r)
- Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)
- Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
-
--- | /O(log n)/. Delete and find the maximal element.
---
--- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")])
--- > deleteFindMax empty Error: can not return the maximal element of an empty map
-
-deleteFindMax :: Map k a -> ((k,a),Map k a)
-deleteFindMax t
- = case t of
- Bin _ k x l Tip -> ((k,x),l)
- Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r')
- Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
-
-
-{--------------------------------------------------------------------
- [balance l x r] balances two trees with value x.
- The sizes of the trees should balance after decreasing the
- size of one of them. (a rotation).
-
- [delta] is the maximal relative difference between the sizes of
- two trees, it corresponds with the [w] in Adams' paper.
- [ratio] is the ratio between an outer and inner sibling of the
- heavier subtree in an unbalanced setting. It determines
- whether a double or single rotation should be performed
- to restore balance. It is correspondes with the inverse
- of $\alpha$ in Adam's article.
-
- Note that:
- - [delta] should be larger than 4.646 with a [ratio] of 2.
- - [delta] should be larger than 3.745 with a [ratio] of 1.534.
-
- - A lower [delta] leads to a more 'perfectly' balanced tree.
- - A higher [delta] performs less rebalancing.
-
- - Balancing is automatic for random data and a balancing
- scheme is only necessary to avoid pathological worst cases.
- Almost any choice will do, and in practice, a rather large
- [delta] may perform better than smaller one.
-
- Note: in contrast to Adam's paper, we use a ratio of (at least) [2]
- to decide whether a single or double rotation is needed. Allthough
- he actually proves that this ratio is needed to maintain the
- invariants, his implementation uses an invalid ratio of [1].
---------------------------------------------------------------------}
-delta,ratio :: Int
-delta = 4
-ratio = 2
-
-balance :: k -> a -> Map k a -> Map k a -> Map k a
-balance k x l r
- | sizeL + sizeR <= 1 = Bin sizeX k x l r
- | sizeR >= delta*sizeL = rotateL k x l r
- | sizeL >= delta*sizeR = rotateR k x l r
- | otherwise = Bin sizeX k x l r
- where
- sizeL = size l
- sizeR = size r
- sizeX = sizeL + sizeR + 1
-
--- rotate
-rotateL :: a -> b -> Map a b -> Map a b -> Map a b
-rotateL k x l r@(Bin _ _ _ ly ry)
- | size ly < ratio*size ry = singleL k x l r
- | otherwise = doubleL k x l r
-rotateL _ _ _ Tip = error "rotateL Tip"
-
-rotateR :: a -> b -> Map a b -> Map a b -> Map a b
-rotateR k x l@(Bin _ _ _ ly ry) r
- | size ry < ratio*size ly = singleR k x l r
- | otherwise = doubleR k x l r
-rotateR _ _ Tip _ = error "rotateR Tip"
-
--- basic rotations
-singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b
-singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
-singleL _ _ _ Tip = error "singleL Tip"
-singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)
-singleR _ _ Tip _ = error "singleR Tip"
-
-doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b
-doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)
-doubleL _ _ _ _ = error "doubleL"
-doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)
-doubleR _ _ _ _ = error "doubleR"
-
-
-{--------------------------------------------------------------------
- The bin constructor maintains the size of the tree
---------------------------------------------------------------------}
-bin :: k -> a -> Map k a -> Map k a -> Map k a
-bin k x l r
- = Bin (size l + size r + 1) k x l r
-
-
-{--------------------------------------------------------------------
- Eq converts the tree to a list. In a lazy setting, this
- actually seems one of the faster methods to compare two trees
- and it is certainly the simplest :-)
---------------------------------------------------------------------}
-instance (Eq k,Eq a) => Eq (Map k a) where
- t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
-
-{--------------------------------------------------------------------
- Ord
---------------------------------------------------------------------}
-
-instance (Ord k, Ord v) => Ord (Map k v) where
- compare m1 m2 = compare (toAscList m1) (toAscList m2)
-
-{--------------------------------------------------------------------
- Functor
---------------------------------------------------------------------}
-instance Functor (Map k) where
- fmap f m = map f m
-
-instance Traversable (Map k) where
- traverse _ Tip = pure Tip
- traverse f (Bin s k v l r)
- = flip (Bin s k) <$> traverse f l <*> f v <*> traverse f r
-
-instance Foldable (Map k) where
- foldMap _f Tip = mempty
- foldMap f (Bin _s _k v l r)
- = foldMap f l `mappend` f v `mappend` foldMap f r
-
-{--------------------------------------------------------------------
- Read
---------------------------------------------------------------------}
-instance (Ord k, Read k, Read e) => Read (Map k e) where
-#ifdef __GLASGOW_HASKELL__
- readPrec = parens $ prec 10 $ do
- Ident "fromList" <- lexP
- xs <- readPrec
- return (fromList xs)
-
- readListPrec = readListPrecDefault
-#else
- readsPrec p = readParen (p > 10) $ \ r -> do
- ("fromList",s) <- lex r
- (xs,t) <- reads s
- return (fromList xs,t)
-#endif
-
-{--------------------------------------------------------------------
- Show
---------------------------------------------------------------------}
-instance (Show k, Show a) => Show (Map k a) where
- showsPrec d m = showParen (d > 10) $
- showString "fromList " . shows (toList m)
-
--- | /O(n)/. Show the tree that implements the map. The tree is shown
--- in a compressed, hanging format. See 'showTreeWith'.
-showTree :: (Show k,Show a) => Map k a -> String
-showTree m
- = showTreeWith showElem True False m
- where
- showElem k x = show k ++ ":=" ++ show x
-
-
-{- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows
- the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
- @wide@ is 'True', an extra wide version is shown.
-
-> Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
-> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
-> (4,())
-> +--(2,())
-> | +--(1,())
-> | +--(3,())
-> +--(5,())
->
-> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
-> (4,())
-> |
-> +--(2,())
-> | |
-> | +--(1,())
-> | |
-> | +--(3,())
-> |
-> +--(5,())
->
-> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
-> +--(5,())
-> |
-> (4,())
-> |
-> | +--(3,())
-> | |
-> +--(2,())
-> |
-> +--(1,())
-
--}
-showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
-showTreeWith showelem hang wide t
- | hang = (showsTreeHang showelem wide [] t) ""
- | otherwise = (showsTree showelem wide [] [] t) ""
-
-showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
-showsTree showelem wide lbars rbars t
- = case t of
- Tip -> showsBars lbars . showString "|\n"
- Bin _ kx x Tip Tip
- -> showsBars lbars . showString (showelem kx x) . showString "\n"
- Bin _ kx x l r
- -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
- showWide wide rbars .
- showsBars lbars . showString (showelem kx x) . showString "\n" .
- showWide wide lbars .
- showsTree showelem wide (withEmpty lbars) (withBar lbars) l
-
-showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
-showsTreeHang showelem wide bars t
- = case t of
- Tip -> showsBars bars . showString "|\n"
- Bin _ kx x Tip Tip
- -> showsBars bars . showString (showelem kx x) . showString "\n"
- Bin _ kx x l r
- -> showsBars bars . showString (showelem kx x) . showString "\n" .
- showWide wide bars .
- showsTreeHang showelem wide (withBar bars) l .
- showWide wide bars .
- showsTreeHang showelem wide (withEmpty bars) r
-
-showWide :: Bool -> [String] -> String -> String
-showWide wide bars
- | wide = showString (concat (reverse bars)) . showString "|\n"
- | otherwise = id
-
-showsBars :: [String] -> ShowS
-showsBars bars
- = case bars of
- [] -> id
- _ -> showString (concat (reverse (tail bars))) . showString node
-
-node :: String
-node = "+--"
-
-withBar, withEmpty :: [String] -> [String]
-withBar bars = "| ":bars
-withEmpty bars = " ":bars
-
-{--------------------------------------------------------------------
- Typeable
---------------------------------------------------------------------}
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE2(Map,mapTc,"Map")
-
-{--------------------------------------------------------------------
- Assertions
---------------------------------------------------------------------}
--- | /O(n)/. Test if the internal map structure is valid.
---
--- > valid (fromAscList [(3,"b"), (5,"a")]) == True
--- > valid (fromAscList [(5,"a"), (3,"b")]) == False
-
-valid :: Ord k => Map k a -> Bool
-valid t
- = balanced t && ordered t && validsize t
-
-ordered :: Ord a => Map a b -> Bool
-ordered t
- = bounded (const True) (const True) t
- where
- bounded lo hi t'
- = case t' of
- Tip -> True
- Bin _ kx _ l r -> (lo kx) && (hi kx) && bounded lo (kx) hi r
-
--- | Exported only for "Debug.QuickCheck"
-balanced :: Map k a -> Bool
-balanced t
- = case t of
- Tip -> True
- Bin _ _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
- balanced l && balanced r
-
-validsize :: Map a b -> Bool
-validsize t
- = (realsize t == Just (size t))
- where
- realsize t'
- = case t' of
- Tip -> Just 0
- Bin sz _ _ l r -> case (realsize l,realsize r) of
- (Just n,Just m) | n+m+1 == sz -> Just sz
- _ -> Nothing
-
-{--------------------------------------------------------------------
- Utilities
---------------------------------------------------------------------}
-foldlStrict :: (a -> b -> a) -> a -> [b] -> a
-foldlStrict f = go
- where
- go z [] = z
- go z (x:xs) = z `seq` go (f z x) xs
-
-
+{-# LANGUAGE CPP, NoBangPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Map
+-- Copyright : (c) Daan Leijen 2002
+-- (c) Andriy Palamarchuk 2008
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- An efficient implementation of maps from keys to values (dictionaries).
+--
+-- Since many function names (but not the type name) clash with
+-- "Prelude" names, this module is usually imported @qualified@, e.g.
+--
+-- > import Data.Map (Map)
+-- > import qualified Data.Map as Map
+--
+-- The implementation of 'Map' is based on /size balanced/ binary trees (or
+-- trees of /bounded balance/) as described by:
+--
+-- * Stephen Adams, \"/Efficient sets: a balancing act/\",
+-- Journal of Functional Programming 3(4):553-562, October 1993,
+-- .
+--
+-- * J. Nievergelt and E.M. Reingold,
+-- \"/Binary search trees of bounded balance/\",
+-- SIAM journal of computing 2(1), March 1973.
+--
+-- Note that the implementation is /left-biased/ -- the elements of a
+-- first argument are always preferred to the second, for example in
+-- 'union' or 'insert'.
+--
+-- Operation comments contain the operation time complexity in
+-- the Big-O notation .
+-----------------------------------------------------------------------------
+
+-- It is crucial to the performance that the functions specialize on the Ord
+-- type when possible. GHC 7.0 and higher does this by itself when it sees th
+-- unfolding of a function -- that is why all public functions are marked
+-- INLINABLE (that exposes the unfolding).
+--
+-- For other compilers and GHC pre 7.0, we mark some of the functions INLINE.
+-- We mark the functions that just navigate down the tree (lookup, insert,
+-- delete and similar). That navigation code gets inlined and thus specialized
+-- when possible. There is a price to pay -- code growth. The code INLINED is
+-- therefore only the tree navigation, all the real work (rebalancing) is not
+-- INLINED by using a NOINLINE.
+--
+-- All methods that can be INLINE are not recursive -- a 'go' function doing
+-- the real work is provided.
+
+module Data.Map (
+ -- * Map type
+#if !defined(TESTING)
+ Map -- instance Eq,Show,Read
+#else
+ Map(..) -- instance Eq,Show,Read
+#endif
+
+ -- * Operators
+ , (!), (\\)
+
+ -- * Query
+ , null
+ , size
+ , member
+ , notMember
+ , lookup
+ , findWithDefault
+
+ -- * Construction
+ , empty
+ , singleton
+
+ -- ** Insertion
+ , insert
+ , insertWith
+ , insertWith'
+ , insertWithKey
+ , insertWithKey'
+ , insertLookupWithKey
+ , insertLookupWithKey'
+
+ -- ** Delete\/Update
+ , delete
+ , adjust
+ , adjustWithKey
+ , update
+ , updateWithKey
+ , updateLookupWithKey
+ , alter
+
+ -- * Combine
+
+ -- ** Union
+ , union
+ , unionWith
+ , unionWithKey
+ , unions
+ , unionsWith
+
+ -- ** Difference
+ , difference
+ , differenceWith
+ , differenceWithKey
+
+ -- ** Intersection
+ , intersection
+ , intersectionWith
+ , intersectionWithKey
+
+ -- * Traversal
+ -- ** Map
+ , map
+ , mapWithKey
+ , mapAccum
+ , mapAccumWithKey
+ , mapAccumRWithKey
+ , mapKeys
+ , mapKeysWith
+ , mapKeysMonotonic
+
+ -- ** Fold
+ , fold
+ , foldWithKey
+ , foldrWithKey
+ , foldrWithKey'
+ , foldlWithKey
+ , foldlWithKey'
+
+ -- * Conversion
+ , elems
+ , keys
+ , keysSet
+ , assocs
+
+ -- ** Lists
+ , toList
+ , fromList
+ , fromListWith
+ , fromListWithKey
+
+ -- ** Ordered lists
+ , toAscList
+ , toDescList
+ , fromAscList
+ , fromAscListWith
+ , fromAscListWithKey
+ , fromDistinctAscList
+
+ -- * Filter
+ , filter
+ , filterWithKey
+ , partition
+ , partitionWithKey
+
+ , mapMaybe
+ , mapMaybeWithKey
+ , mapEither
+ , mapEitherWithKey
+
+ , split
+ , splitLookup
+
+ -- * Submap
+ , isSubmapOf, isSubmapOfBy
+ , isProperSubmapOf, isProperSubmapOfBy
+
+ -- * Indexed
+ , lookupIndex
+ , findIndex
+ , elemAt
+ , updateAt
+ , deleteAt
+
+ -- * Min\/Max
+ , findMin
+ , findMax
+ , deleteMin
+ , deleteMax
+ , deleteFindMin
+ , deleteFindMax
+ , updateMin
+ , updateMax
+ , updateMinWithKey
+ , updateMaxWithKey
+ , minView
+ , maxView
+ , minViewWithKey
+ , maxViewWithKey
+
+ -- * Debugging
+ , showTree
+ , showTreeWith
+ , valid
+
+#if defined(TESTING)
+ -- * Internals
+ , bin
+ , balanced
+ , join
+ , merge
+#endif
+
+ ) where
+
+import Prelude hiding (lookup,map,filter,null)
+import qualified Data.Set as Set
+import qualified Data.List as List
+import Data.Monoid (Monoid(..))
+import Control.Applicative (Applicative(..), (<$>))
+import Data.Traversable (Traversable(traverse))
+import Data.Foldable (Foldable(foldMap))
+import Data.Typeable
+
+#if __GLASGOW_HASKELL__
+import Text.Read
+import Data.Data
+#endif
+
+-- Use macros to define strictness of functions.
+-- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.
+-- We do not use BangPatterns, because they are not in any standard and we
+-- want the compilers to be compiled by as many compilers as possible.
+#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined
+#define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined
+#define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefined
+#define STRICT_2_OF_4(fn) fn _ arg _ _ | arg `seq` False = undefined
+
+{--------------------------------------------------------------------
+ Operators
+--------------------------------------------------------------------}
+infixl 9 !,\\ --
+
+-- | /O(log n)/. Find the value at a key.
+-- Calls 'error' when the element can not be found.
+--
+-- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map
+-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'
+
+(!) :: Ord k => Map k a -> k -> a
+m ! k = find k m
+{-# INLINE (!) #-}
+
+-- | Same as 'difference'.
+(\\) :: Ord k => Map k a -> Map k b -> Map k a
+m1 \\ m2 = difference m1 m2
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE (\\) #-}
+#endif
+
+{--------------------------------------------------------------------
+ Size balanced trees.
+--------------------------------------------------------------------}
+-- | A Map from keys @k@ to values @a@.
+data Map k a = Tip
+ | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
+
+type Size = Int
+
+instance (Ord k) => Monoid (Map k v) where
+ mempty = empty
+ mappend = union
+ mconcat = unions
+
+#if __GLASGOW_HASKELL__
+
+{--------------------------------------------------------------------
+ A Data instance
+--------------------------------------------------------------------}
+
+-- This instance preserves data abstraction at the cost of inefficiency.
+-- We omit reflection services for the sake of data abstraction.
+
+instance (Data k, Data a, Ord k) => Data (Map k a) where
+ gfoldl f z m = z fromList `f` toList m
+ toConstr _ = error "toConstr"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "Data.Map.Map"
+ dataCast2 f = gcast2 f
+
+#endif
+
+{--------------------------------------------------------------------
+ Query
+--------------------------------------------------------------------}
+-- | /O(1)/. Is the map empty?
+--
+-- > Data.Map.null (empty) == True
+-- > Data.Map.null (singleton 1 'a') == False
+
+null :: Map k a -> Bool
+null Tip = True
+null (Bin {}) = False
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE null #-}
+#endif
+
+-- | /O(1)/. The number of elements in the map.
+--
+-- > size empty == 0
+-- > size (singleton 1 'a') == 1
+-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3
+
+size :: Map k a -> Int
+size Tip = 0
+size (Bin sz _ _ _ _) = sz
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE size #-}
+#endif
+
+
+-- | /O(log n)/. Lookup the value at a key in the map.
+--
+-- The function will return the corresponding value as @('Just' value)@,
+-- or 'Nothing' if the key isn't in the map.
+--
+-- An example of using @lookup@:
+--
+-- > import Prelude hiding (lookup)
+-- > import Data.Map
+-- >
+-- > employeeDept = fromList([("John","Sales"), ("Bob","IT")])
+-- > deptCountry = fromList([("IT","USA"), ("Sales","France")])
+-- > countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")])
+-- >
+-- > employeeCurrency :: String -> Maybe String
+-- > employeeCurrency name = do
+-- > dept <- lookup name employeeDept
+-- > country <- lookup dept deptCountry
+-- > lookup country countryCurrency
+-- >
+-- > main = do
+-- > putStrLn $ "John's currency: " ++ (show (employeeCurrency "John"))
+-- > putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete"))
+--
+-- The output of this program:
+--
+-- > John's currency: Just "Euro"
+-- > Pete's currency: Nothing
+
+lookup :: Ord k => k -> Map k a -> Maybe a
+lookup = go
+ where
+ STRICT_1_OF_2(go)
+ go _ Tip = Nothing
+ go k (Bin _ kx x l r) =
+ case compare k kx of
+ LT -> go k l
+ GT -> go k r
+ EQ -> Just x
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE lookup #-}
+#else
+{-# INLINE lookup #-}
+#endif
+
+lookupAssoc :: Ord k => k -> Map k a -> Maybe (k,a)
+lookupAssoc = go
+ where
+ STRICT_1_OF_2(go)
+ go _ Tip = Nothing
+ go k (Bin _ kx x l r) =
+ case compare k kx of
+ LT -> go k l
+ GT -> go k r
+ EQ -> Just (kx,x)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINEABLE lookupAssoc #-}
+#else
+{-# INLINE lookupAssoc #-}
+#endif
+
+-- | /O(log n)/. Is the key a member of the map? See also 'notMember'.
+--
+-- > member 5 (fromList [(5,'a'), (3,'b')]) == True
+-- > member 1 (fromList [(5,'a'), (3,'b')]) == False
+
+member :: Ord k => k -> Map k a -> Bool
+member k m = case lookup k m of
+ Nothing -> False
+ Just _ -> True
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINEABLE member #-}
+#else
+{-# INLINE member #-}
+#endif
+
+-- | /O(log n)/. Is the key not a member of the map? See also 'member'.
+--
+-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False
+-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True
+
+notMember :: Ord k => k -> Map k a -> Bool
+notMember k m = not $ member k m
+{-# INLINE notMember #-}
+
+-- | /O(log n)/. Find the value at a key.
+-- Calls 'error' when the element can not be found.
+-- Consider using 'lookup' when elements may not be present.
+find :: Ord k => k -> Map k a -> a
+find k m = case lookup k m of
+ Nothing -> error "Map.find: element not in the map"
+ Just x -> x
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE find #-}
+#else
+{-# INLINE find #-}
+#endif
+
+-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns
+-- the value at key @k@ or returns default value @def@
+-- when the key is not in the map.
+--
+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'
+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'
+
+findWithDefault :: Ord k => a -> k -> Map k a -> a
+findWithDefault def k m = case lookup k m of
+ Nothing -> def
+ Just x -> x
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE findWithDefault #-}
+#else
+{-# INLINE findWithDefault #-}
+#endif
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+-- | /O(1)/. The empty map.
+--
+-- > empty == fromList []
+-- > size empty == 0
+
+empty :: Map k a
+empty = Tip
+
+-- | /O(1)/. A map with a single element.
+--
+-- > singleton 1 'a' == fromList [(1, 'a')]
+-- > size (singleton 1 'a') == 1
+
+singleton :: k -> a -> Map k a
+singleton k x = Bin 1 k x Tip Tip
+
+{--------------------------------------------------------------------
+ Insertion
+--------------------------------------------------------------------}
+-- | /O(log n)/. Insert a new key and value in the map.
+-- If the key is already present in the map, the associated value is
+-- replaced with the supplied value. 'insert' is equivalent to
+-- @'insertWith' 'const'@.
+--
+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]
+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]
+-- > insert 5 'x' empty == singleton 5 'x'
+
+insert :: Ord k => k -> a -> Map k a -> Map k a
+insert = go
+ where
+ STRICT_1_OF_3(go)
+ go kx x Tip = singleton kx x
+ go kx x (Bin sz ky y l r) =
+ case compare kx ky of
+ LT -> balanceL ky y (go kx x l) r
+ GT -> balanceR ky y l (go kx x r)
+ EQ -> Bin sz kx x l r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINEABLE insert #-}
+#else
+{-# INLINE insert #-}
+#endif
+
+-- | /O(log n)/. Insert with a function, combining new value and old value.
+-- @'insertWith' f key value mp@
+-- will insert the pair (key, value) into @mp@ if key does
+-- not exist in the map. If the key does exist, the function will
+-- insert the pair @(key, f new_value old_value)@.
+--
+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]
+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
+-- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"
+
+insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
+insertWith f = insertWithKey (\_ x' y' -> f x' y')
+{-# INLINE insertWith #-}
+
+-- | Same as 'insertWith', but the combining function is applied strictly.
+-- This is often the most desirable behavior.
+--
+-- For example, to update a counter:
+--
+-- > insertWith' (+) k 1 m
+--
+insertWith' :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
+insertWith' f = insertWithKey' (\_ x' y' -> f x' y')
+{-# INLINE insertWith' #-}
+
+-- | /O(log n)/. Insert with a function, combining key, new value and old value.
+-- @'insertWithKey' f key value mp@
+-- will insert the pair (key, value) into @mp@ if key does
+-- not exist in the map. If the key does exist, the function will
+-- insert the pair @(key,f key new_value old_value)@.
+-- Note that the key passed to f is the same key passed to 'insertWithKey'.
+--
+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]
+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
+-- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"
+
+insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
+insertWithKey = go
+ where
+ STRICT_2_OF_4(go)
+ go _ kx x Tip = singleton kx x
+ go f kx x (Bin sy ky y l r) =
+ case compare kx ky of
+ LT -> balanceL ky y (go f kx x l) r
+ GT -> balanceR ky y l (go f kx x r)
+ EQ -> Bin sy kx (f kx x y) l r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINEABLE insertWithKey #-}
+#else
+{-# INLINE insertWithKey #-}
+#endif
+
+-- | Same as 'insertWithKey', but the combining function is applied strictly.
+insertWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
+insertWithKey' = go
+ where
+ STRICT_2_OF_4(go)
+ go _ kx x Tip = x `seq` singleton kx x
+ go f kx x (Bin sy ky y l r) =
+ case compare kx ky of
+ LT -> balanceL ky y (go f kx x l) r
+ GT -> balanceR ky y l (go f kx x r)
+ EQ -> let x' = f kx x y in x' `seq` (Bin sy kx x' l r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINEABLE insertWithKey' #-}
+#else
+{-# INLINE insertWithKey' #-}
+#endif
+
+-- | /O(log n)/. Combines insert operation with old value retrieval.
+-- The expression (@'insertLookupWithKey' f k x map@)
+-- is a pair where the first element is equal to (@'lookup' k map@)
+-- and the second element equal to (@'insertWithKey' f k x map@).
+--
+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])
+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])
+-- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx")
+--
+-- This is how to define @insertLookup@ using @insertLookupWithKey@:
+--
+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t
+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])
+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])
+
+insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a
+ -> (Maybe a, Map k a)
+insertLookupWithKey = go
+ where
+ STRICT_2_OF_4(go)
+ go _ kx x Tip = (Nothing, singleton kx x)
+ go f kx x (Bin sy ky y l r) =
+ case compare kx ky of
+ LT -> let (found, l') = go f kx x l
+ in (found, balanceL ky y l' r)
+ GT -> let (found, r') = go f kx x r
+ in (found, balanceR ky y l r')
+ EQ -> (Just y, Bin sy kx (f kx x y) l r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINEABLE insertLookupWithKey #-}
+#else
+{-# INLINE insertLookupWithKey #-}
+#endif
+
+-- | /O(log n)/. A strict version of 'insertLookupWithKey'.
+insertLookupWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a
+ -> (Maybe a, Map k a)
+insertLookupWithKey' = go
+ where
+ STRICT_2_OF_4(go)
+ go _ kx x Tip = x `seq` (Nothing, singleton kx x)
+ go f kx x (Bin sy ky y l r) =
+ case compare kx ky of
+ LT -> let (found, l') = go f kx x l
+ in (found, balanceL ky y l' r)
+ GT -> let (found, r') = go f kx x r
+ in (found, balanceR ky y l r')
+ EQ -> let x' = f kx x y in x' `seq` (Just y, Bin sy kx x' l r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINEABLE insertLookupWithKey' #-}
+#else
+{-# INLINE insertLookupWithKey' #-}
+#endif
+
+{--------------------------------------------------------------------
+ Deletion
+ [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
+--------------------------------------------------------------------}
+-- | /O(log n)/. Delete a key and its value from the map. When the key is not
+-- a member of the map, the original map is returned.
+--
+-- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
+-- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
+-- > delete 5 empty == empty
+
+delete :: Ord k => k -> Map k a -> Map k a
+delete = go
+ where
+ STRICT_1_OF_2(go)
+ go _ Tip = Tip
+ go k (Bin _ kx x l r) =
+ case compare k kx of
+ LT -> balanceR kx x (go k l) r
+ GT -> balanceL kx x l (go k r)
+ EQ -> glue l r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINEABLE delete #-}
+#else
+{-# INLINE delete #-}
+#endif
+
+-- | /O(log n)/. Update a value at a specific key with the result of the provided function.
+-- When the key is not
+-- a member of the map, the original map is returned.
+--
+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
+-- > adjust ("new " ++) 7 empty == empty
+
+adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
+adjust f = adjustWithKey (\_ x -> f x)
+{-# INLINE adjust #-}
+
+-- | /O(log n)/. Adjust a value at a specific key. When the key is not
+-- a member of the map, the original map is returned.
+--
+-- > let f key x = (show key) ++ ":new " ++ x
+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
+-- > adjustWithKey f 7 empty == empty
+
+adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
+adjustWithKey f = updateWithKey (\k' x' -> Just (f k' x'))
+{-# INLINE adjustWithKey #-}
+
+-- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@
+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
+--
+-- > let f x = if x == "a" then Just "new a" else Nothing
+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
+-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
+
+update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
+update f = updateWithKey (\_ x -> f x)
+{-# INLINE update #-}
+
+-- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
+-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
+-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
+-- to the new value @y@.
+--
+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
+-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
+
+updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
+updateWithKey = go
+ where
+ STRICT_2_OF_3(go)
+ go _ _ Tip = Tip
+ go f k(Bin sx kx x l r) =
+ case compare k kx of
+ LT -> balanceR kx x (go f k l) r
+ GT -> balanceL kx x l (go f k r)
+ EQ -> case f kx x of
+ Just x' -> Bin sx kx x' l r
+ Nothing -> glue l r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINEABLE updateWithKey #-}
+#else
+{-# INLINE updateWithKey #-}
+#endif
+
+-- | /O(log n)/. Lookup and update. See also 'updateWithKey'.
+-- The function returns changed value, if it is updated.
+-- Returns the original key value if the map entry is deleted.
+--
+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])
+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])
+-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")
+
+updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
+updateLookupWithKey = go
+ where
+ STRICT_2_OF_3(go)
+ go _ _ Tip = (Nothing,Tip)
+ go f k (Bin sx kx x l r) =
+ case compare k kx of
+ LT -> let (found,l') = go f k l in (found,balanceR kx x l' r)
+ GT -> let (found,r') = go f k r in (found,balanceL kx x l r')
+ EQ -> case f kx x of
+ Just x' -> (Just x',Bin sx kx x' l r)
+ Nothing -> (Just x,glue l r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINEABLE updateLookupWithKey #-}
+#else
+{-# INLINE updateLookupWithKey #-}
+#endif
+
+-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
+-- 'alter' can be used to insert, delete, or update a value in a 'Map'.
+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.
+--
+-- > let f _ = Nothing
+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
+-- >
+-- > let f _ = Just "c"
+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]
+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]
+
+alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a
+alter = go
+ where
+ STRICT_2_OF_3(go)
+ go f k Tip = case f Nothing of
+ Nothing -> Tip
+ Just x -> singleton k x
+
+ go f k (Bin sx kx x l r) = case compare k kx of
+ LT -> balance kx x (go f k l) r
+ GT -> balance kx x l (go f k r)
+ EQ -> case f (Just x) of
+ Just x' -> Bin sx kx x' l r
+ Nothing -> glue l r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINEABLE alter #-}
+#else
+{-# INLINE alter #-}
+#endif
+
+{--------------------------------------------------------------------
+ Indexing
+--------------------------------------------------------------------}
+-- | /O(log n)/. Return the /index/ of a key. The index is a number from
+-- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
+-- the key is not a 'member' of the map.
+--
+-- > findIndex 2 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map
+-- > findIndex 3 (fromList [(5,"a"), (3,"b")]) == 0
+-- > findIndex 5 (fromList [(5,"a"), (3,"b")]) == 1
+-- > findIndex 6 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map
+
+findIndex :: Ord k => k -> Map k a -> Int
+findIndex k t
+ = case lookupIndex k t of
+ Nothing -> error "Map.findIndex: element is not in the map"
+ Just idx -> idx
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE findIndex #-}
+#endif
+
+-- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
+-- /0/ up to, but not including, the 'size' of the map.
+--
+-- > isJust (lookupIndex 2 (fromList [(5,"a"), (3,"b")])) == False
+-- > fromJust (lookupIndex 3 (fromList [(5,"a"), (3,"b")])) == 0
+-- > fromJust (lookupIndex 5 (fromList [(5,"a"), (3,"b")])) == 1
+-- > isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")])) == False
+
+lookupIndex :: Ord k => k -> Map k a -> Maybe Int
+lookupIndex k = lkp k 0
+ where
+ STRICT_1_OF_3(lkp)
+ STRICT_2_OF_3(lkp)
+ lkp _ _ Tip = Nothing
+ lkp key idx (Bin _ kx _ l r)
+ = case compare key kx of
+ LT -> lkp key idx l
+ GT -> lkp key (idx + size l + 1) r
+ EQ -> let idx' = idx + size l in idx' `seq` Just idx'
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE lookupIndex #-}
+#endif
+
+-- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
+-- invalid index is used.
+--
+-- > elemAt 0 (fromList [(5,"a"), (3,"b")]) == (3,"b")
+-- > elemAt 1 (fromList [(5,"a"), (3,"b")]) == (5, "a")
+-- > elemAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
+
+elemAt :: Int -> Map k a -> (k,a)
+STRICT_1_OF_2(elemAt)
+elemAt _ Tip = error "Map.elemAt: index out of range"
+elemAt i (Bin _ kx x l r)
+ = case compare i sizeL of
+ LT -> elemAt i l
+ GT -> elemAt (i-sizeL-1) r
+ EQ -> (kx,x)
+ where
+ sizeL = size l
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE elemAt #-}
+#endif
+
+-- | /O(log n)/. Update the element at /index/. Calls 'error' when an
+-- invalid index is used.
+--
+-- > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]
+-- > updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")]
+-- > updateAt (\ _ _ -> Just "x") 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
+-- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range
+-- > updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
+-- > updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
+-- > updateAt (\_ _ -> Nothing) 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
+-- > updateAt (\_ _ -> Nothing) (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range
+
+updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
+updateAt f i t = i `seq`
+ case t of
+ Tip -> error "Map.updateAt: index out of range"
+ Bin sx kx x l r -> case compare i sizeL of
+ LT -> balanceR kx x (updateAt f i l) r
+ GT -> balanceL kx x l (updateAt f (i-sizeL-1) r)
+ EQ -> case f kx x of
+ Just x' -> Bin sx kx x' l r
+ Nothing -> glue l r
+ where
+ sizeL = size l
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE updateAt #-}
+#endif
+
+-- | /O(log n)/. Delete the element at /index/.
+-- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).
+--
+-- > deleteAt 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
+-- > deleteAt 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
+-- > deleteAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
+-- > deleteAt (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range
+
+deleteAt :: Int -> Map k a -> Map k a
+deleteAt i m
+ = updateAt (\_ _ -> Nothing) i m
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE deleteAt #-}
+#endif
+
+
+{--------------------------------------------------------------------
+ Minimal, Maximal
+--------------------------------------------------------------------}
+-- | /O(log n)/. The minimal key of the map. Calls 'error' if the map is empty.
+--
+-- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")
+-- > findMin empty Error: empty map has no minimal element
+
+findMin :: Map k a -> (k,a)
+findMin (Bin _ kx x Tip _) = (kx,x)
+findMin (Bin _ _ _ l _) = findMin l
+findMin Tip = error "Map.findMin: empty map has no minimal element"
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE findMin #-}
+#endif
+
+-- | /O(log n)/. The maximal key of the map. Calls 'error' if the map is empty.
+--
+-- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")
+-- > findMax empty Error: empty map has no maximal element
+
+findMax :: Map k a -> (k,a)
+findMax (Bin _ kx x _ Tip) = (kx,x)
+findMax (Bin _ _ _ _ r) = findMax r
+findMax Tip = error "Map.findMax: empty map has no maximal element"
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE findMax #-}
+#endif
+
+-- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty.
+--
+-- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]
+-- > deleteMin empty == empty
+
+deleteMin :: Map k a -> Map k a
+deleteMin (Bin _ _ _ Tip r) = r
+deleteMin (Bin _ kx x l r) = balanceR kx x (deleteMin l) r
+deleteMin Tip = Tip
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE deleteMin #-}
+#endif
+
+-- | /O(log n)/. Delete the maximal key. Returns an empty map if the map is empty.
+--
+-- > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]
+-- > deleteMax empty == empty
+
+deleteMax :: Map k a -> Map k a
+deleteMax (Bin _ _ _ l Tip) = l
+deleteMax (Bin _ kx x l r) = balanceL kx x l (deleteMax r)
+deleteMax Tip = Tip
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE deleteMax #-}
+#endif
+
+-- | /O(log n)/. Update the value at the minimal key.
+--
+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]
+-- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
+
+updateMin :: (a -> Maybe a) -> Map k a -> Map k a
+updateMin f m
+ = updateMinWithKey (\_ x -> f x) m
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE updateMin #-}
+#endif
+
+-- | /O(log n)/. Update the value at the maximal key.
+--
+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]
+-- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
+
+updateMax :: (a -> Maybe a) -> Map k a -> Map k a
+updateMax f m
+ = updateMaxWithKey (\_ x -> f x) m
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE updateMax #-}
+#endif
+
+
+-- | /O(log n)/. Update the value at the minimal key.
+--
+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]
+-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
+
+updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
+updateMinWithKey _ Tip = Tip
+updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of
+ Nothing -> r
+ Just x' -> Bin sx kx x' Tip r
+updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE updateMinWithKey #-}
+#endif
+
+-- | /O(log n)/. Update the value at the maximal key.
+--
+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]
+-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
+
+updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
+updateMaxWithKey _ Tip = Tip
+updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of
+ Nothing -> l
+ Just x' -> Bin sx kx x' l Tip
+updateMaxWithKey f (Bin _ kx x l r) = balanceL kx x l (updateMaxWithKey f r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE updateMaxWithKey #-}
+#endif
+
+-- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and
+-- the map stripped of that element, or 'Nothing' if passed an empty map.
+--
+-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")
+-- > minViewWithKey empty == Nothing
+
+minViewWithKey :: Map k a -> Maybe ((k,a), Map k a)
+minViewWithKey Tip = Nothing
+minViewWithKey x = Just (deleteFindMin x)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE minViewWithKey #-}
+#endif
+
+-- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and
+-- the map stripped of that element, or 'Nothing' if passed an empty map.
+--
+-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")
+-- > maxViewWithKey empty == Nothing
+
+maxViewWithKey :: Map k a -> Maybe ((k,a), Map k a)
+maxViewWithKey Tip = Nothing
+maxViewWithKey x = Just (deleteFindMax x)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE maxViewWithKey #-}
+#endif
+
+-- | /O(log n)/. Retrieves the value associated with minimal key of the
+-- map, and the map stripped of that element, or 'Nothing' if passed an
+-- empty map.
+--
+-- > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a")
+-- > minView empty == Nothing
+
+minView :: Map k a -> Maybe (a, Map k a)
+minView Tip = Nothing
+minView x = Just (first snd $ deleteFindMin x)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE minView #-}
+#endif
+
+-- | /O(log n)/. Retrieves the value associated with maximal key of the
+-- map, and the map stripped of that element, or 'Nothing' if passed an
+--
+-- > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b")
+-- > maxView empty == Nothing
+
+maxView :: Map k a -> Maybe (a, Map k a)
+maxView Tip = Nothing
+maxView x = Just (first snd $ deleteFindMax x)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE maxView #-}
+#endif
+
+-- Update the 1st component of a tuple (special case of Control.Arrow.first)
+first :: (a -> b) -> (a,c) -> (b,c)
+first f (x,y) = (f x, y)
+
+{--------------------------------------------------------------------
+ Union.
+--------------------------------------------------------------------}
+-- | The union of a list of maps:
+-- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).
+--
+-- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
+-- > == fromList [(3, "b"), (5, "a"), (7, "C")]
+-- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]
+-- > == fromList [(3, "B3"), (5, "A3"), (7, "C")]
+
+unions :: Ord k => [Map k a] -> Map k a
+unions ts
+ = foldlStrict union empty ts
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE unions #-}
+#endif
+
+-- | The union of a list of maps, with a combining operation:
+-- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
+--
+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
+-- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]
+
+unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
+unionsWith f ts
+ = foldlStrict (unionWith f) empty ts
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE unionsWith #-}
+#endif
+
+-- | /O(n+m)/.
+-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
+-- It prefers @t1@ when duplicate keys are encountered,
+-- i.e. (@'union' == 'unionWith' 'const'@).
+-- The implementation uses the efficient /hedge-union/ algorithm.
+-- Hedge-union is more efficient on (bigset \``union`\` smallset).
+--
+-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]
+
+union :: Ord k => Map k a -> Map k a -> Map k a
+union Tip t2 = t2
+union t1 Tip = t1
+union (Bin _ k x Tip Tip) t = insert k x t
+union t (Bin _ k x Tip Tip) = insertWith (\_ y->y) k x t
+union t1 t2 = hedgeUnionL NothingS NothingS t1 t2
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE union #-}
+#endif
+
+-- left-biased hedge union
+hedgeUnionL :: Ord a
+ => MaybeS a -> MaybeS a -> Map a b -> Map a b
+ -> Map a b
+hedgeUnionL _ _ t1 Tip
+ = t1
+hedgeUnionL blo bhi Tip (Bin _ kx x l r)
+ = join kx x (filterGt blo l) (filterLt bhi r)
+hedgeUnionL blo bhi (Bin _ kx x l r) t2
+ = join kx x (hedgeUnionL blo bmi l (trim blo bmi t2))
+ (hedgeUnionL bmi bhi r (trim bmi bhi t2))
+ where
+ bmi = JustS kx
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE hedgeUnionL #-}
+#endif
+
+{--------------------------------------------------------------------
+ Union with a combining function
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
+--
+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]
+
+unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
+unionWith f m1 m2
+ = unionWithKey (\_ x y -> f x y) m1 m2
+{-# INLINE unionWith #-}
+
+-- | /O(n+m)/.
+-- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
+-- Hedge-union is more efficient on (bigset \``union`\` smallset).
+--
+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value
+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]
+
+unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
+unionWithKey _ Tip t2 = t2
+unionWithKey _ t1 Tip = t1
+unionWithKey f t1 t2 = hedgeUnionWithKey f NothingS NothingS t1 t2
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE unionWithKey #-}
+#endif
+
+hedgeUnionWithKey :: Ord a
+ => (a -> b -> b -> b)
+ -> MaybeS a -> MaybeS a
+ -> Map a b -> Map a b
+ -> Map a b
+hedgeUnionWithKey _ _ _ t1 Tip
+ = t1
+hedgeUnionWithKey _ blo bhi Tip (Bin _ kx x l r)
+ = join kx x (filterGt blo l) (filterLt bhi r)
+hedgeUnionWithKey f blo bhi (Bin _ kx x l r) t2
+ = join kx newx (hedgeUnionWithKey f blo bmi l lt)
+ (hedgeUnionWithKey f bmi bhi r gt)
+ where
+ bmi = JustS kx
+ lt = trim blo bmi t2
+ (found,gt) = trimLookupLo kx bhi t2
+ newx = case found of
+ Nothing -> x
+ Just (_,y) -> f kx x y
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE hedgeUnionWithKey #-}
+#endif
+
+{--------------------------------------------------------------------
+ Difference
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Difference of two maps.
+-- Return elements of the first map not existing in the second map.
+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
+--
+-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"
+
+difference :: Ord k => Map k a -> Map k b -> Map k a
+difference Tip _ = Tip
+difference t1 Tip = t1
+difference t1 t2 = hedgeDiff NothingS NothingS t1 t2
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE difference #-}
+#endif
+
+hedgeDiff :: Ord a
+ => MaybeS a -> MaybeS a -> Map a b -> Map a c
+ -> Map a b
+hedgeDiff _ _ Tip _
+ = Tip
+hedgeDiff blo bhi (Bin _ kx x l r) Tip
+ = join kx x (filterGt blo l) (filterLt bhi r)
+hedgeDiff blo bhi t (Bin _ kx _ l r)
+ = merge (hedgeDiff blo bmi (trim blo bmi t) l)
+ (hedgeDiff bmi bhi (trim bmi bhi t) r)
+ where
+ bmi = JustS kx
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE hedgeDiff #-}
+#endif
+
+-- | /O(n+m)/. Difference with a combining function.
+-- When two equal keys are
+-- encountered, the combining function is applied to the values of these keys.
+-- If it returns 'Nothing', the element is discarded (proper set difference). If
+-- it returns (@'Just' y@), the element is updated with a new value @y@.
+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
+--
+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing
+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])
+-- > == singleton 3 "b:B"
+
+differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
+differenceWith f m1 m2
+ = differenceWithKey (\_ x y -> f x y) m1 m2
+{-# INLINE differenceWith #-}
+
+-- | /O(n+m)/. Difference with a combining function. When two equal keys are
+-- encountered, the combining function is applied to the key and both values.
+-- If it returns 'Nothing', the element is discarded (proper set difference). If
+-- it returns (@'Just' y@), the element is updated with a new value @y@.
+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
+--
+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing
+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])
+-- > == singleton 3 "3:b|B"
+
+differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
+differenceWithKey _ Tip _ = Tip
+differenceWithKey _ t1 Tip = t1
+differenceWithKey f t1 t2 = hedgeDiffWithKey f NothingS NothingS t1 t2
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE differenceWithKey #-}
+#endif
+
+hedgeDiffWithKey :: Ord a
+ => (a -> b -> c -> Maybe b)
+ -> MaybeS a -> MaybeS a
+ -> Map a b -> Map a c
+ -> Map a b
+hedgeDiffWithKey _ _ _ Tip _
+ = Tip
+hedgeDiffWithKey _ blo bhi (Bin _ kx x l r) Tip
+ = join kx x (filterGt blo l) (filterLt bhi r)
+hedgeDiffWithKey f blo bhi t (Bin _ kx x l r)
+ = case found of
+ Nothing -> merge tl tr
+ Just (ky,y) ->
+ case f ky y x of
+ Nothing -> merge tl tr
+ Just z -> join ky z tl tr
+ where
+ bmi = JustS kx
+ lt = trim blo bmi t
+ (found,gt) = trimLookupLo kx bhi t
+ tl = hedgeDiffWithKey f blo bmi lt l
+ tr = hedgeDiffWithKey f bmi bhi gt r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE hedgeDiffWithKey #-}
+#endif
+
+
+
+{--------------------------------------------------------------------
+ Intersection
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Intersection of two maps.
+-- Return data in the first map for the keys existing in both maps.
+-- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
+--
+-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"
+
+intersection :: Ord k => Map k a -> Map k b -> Map k a
+intersection m1 m2
+ = intersectionWithKey (\_ x _ -> x) m1 m2
+{-# INLINE intersection #-}
+
+-- | /O(n+m)/. Intersection with a combining function.
+--
+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"
+
+intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c
+intersectionWith f m1 m2
+ = intersectionWithKey (\_ x y -> f x y) m1 m2
+{-# INLINE intersectionWith #-}
+
+-- | /O(n+m)/. Intersection with a combining function.
+-- Intersection is more efficient on (bigset \``intersection`\` smallset).
+--
+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar
+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"
+
+
+intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
+intersectionWithKey _ Tip _ = Tip
+intersectionWithKey _ _ Tip = Tip
+intersectionWithKey f t1@(Bin s1 k1 x1 l1 r1) t2@(Bin s2 k2 x2 l2 r2) =
+ if s1 >= s2 then
+ let (lt,found,gt) = splitLookupWithKey k2 t1
+ tl = intersectionWithKey f lt l2
+ tr = intersectionWithKey f gt r2
+ in case found of
+ Just (k,x) -> join k (f k x x2) tl tr
+ Nothing -> merge tl tr
+ else let (lt,found,gt) = splitLookup k1 t2
+ tl = intersectionWithKey f l1 lt
+ tr = intersectionWithKey f r1 gt
+ in case found of
+ Just x -> join k1 (f k1 x1 x) tl tr
+ Nothing -> merge tl tr
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE intersectionWithKey #-}
+#endif
+
+
+
+{--------------------------------------------------------------------
+ Submap
+--------------------------------------------------------------------}
+-- | /O(n+m)/.
+-- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
+--
+isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
+isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE isSubmapOf #-}
+#endif
+
+{- | /O(n+m)/.
+ The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
+ all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when
+ applied to their respective values. For example, the following
+ expressions are all 'True':
+
+ > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
+ > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
+ > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
+
+ But the following are all 'False':
+
+ > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
+ > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
+ > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
+
+
+-}
+isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
+isSubmapOfBy f t1 t2
+ = (size t1 <= size t2) && (submap' f t1 t2)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE isSubmapOfBy #-}
+#endif
+
+submap' :: Ord a => (b -> c -> Bool) -> Map a b -> Map a c -> Bool
+submap' _ Tip _ = True
+submap' _ _ Tip = False
+submap' f (Bin _ kx x l r) t
+ = case found of
+ Nothing -> False
+ Just y -> f x y && submap' f l lt && submap' f r gt
+ where
+ (lt,found,gt) = splitLookup kx t
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE submap' #-}
+#endif
+
+-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
+isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
+isProperSubmapOf m1 m2
+ = isProperSubmapOfBy (==) m1 m2
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE isProperSubmapOf #-}
+#endif
+
+{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
+ @m1@ and @m2@ are not equal,
+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
+ applied to their respective values. For example, the following
+ expressions are all 'True':
+
+ > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+ > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+
+ But the following are all 'False':
+
+ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
+ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
+ > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+
+
+-}
+isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
+isProperSubmapOfBy f t1 t2
+ = (size t1 < size t2) && (submap' f t1 t2)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE isProperSubmapOfBy #-}
+#endif
+
+{--------------------------------------------------------------------
+ Filter and partition
+--------------------------------------------------------------------}
+-- | /O(n)/. Filter all values that satisfy the predicate.
+--
+-- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
+-- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty
+-- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty
+
+filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
+filter p m
+ = filterWithKey (\_ x -> p x) m
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE filter #-}
+#endif
+
+-- | /O(n)/. Filter all keys\/values that satisfy the predicate.
+--
+-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
+
+filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
+filterWithKey _ Tip = Tip
+filterWithKey p (Bin _ kx x l r)
+ | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)
+ | otherwise = merge (filterWithKey p l) (filterWithKey p r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE filterWithKey #-}
+#endif
+
+-- | /O(n)/. Partition the map according to a predicate. The first
+-- map contains all elements that satisfy the predicate, the second all
+-- elements that fail the predicate. See also 'split'.
+--
+-- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
+-- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
+-- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
+
+partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
+partition p m
+ = partitionWithKey (\_ x -> p x) m
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE partition #-}
+#endif
+
+-- | /O(n)/. Partition the map according to a predicate. The first
+-- map contains all elements that satisfy the predicate, the second all
+-- elements that fail the predicate. See also 'split'.
+--
+-- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")
+-- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
+-- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
+
+partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
+partitionWithKey _ Tip = (Tip,Tip)
+partitionWithKey p (Bin _ kx x l r)
+ | p kx x = (join kx x l1 r1,merge l2 r2)
+ | otherwise = (merge l1 r1,join kx x l2 r2)
+ where
+ (l1,l2) = partitionWithKey p l
+ (r1,r2) = partitionWithKey p r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE partitionWithKey #-}
+#endif
+
+-- | /O(n)/. Map values and collect the 'Just' results.
+--
+-- > let f x = if x == "a" then Just "new a" else Nothing
+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"
+
+mapMaybe :: Ord k => (a -> Maybe b) -> Map k a -> Map k b
+mapMaybe f = mapMaybeWithKey (\_ x -> f x)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE mapMaybe #-}
+#endif
+
+-- | /O(n)/. Map keys\/values and collect the 'Just' results.
+--
+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing
+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"
+
+mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> Map k a -> Map k b
+mapMaybeWithKey _ Tip = Tip
+mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of
+ Just y -> join kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)
+ Nothing -> merge (mapMaybeWithKey f l) (mapMaybeWithKey f r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE mapMaybeWithKey #-}
+#endif
+
+-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
+--
+-- > let f a = if a < "c" then Left a else Right a
+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
+-- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])
+-- >
+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
+-- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
+
+mapEither :: Ord k => (a -> Either b c) -> Map k a -> (Map k b, Map k c)
+mapEither f m
+ = mapEitherWithKey (\_ x -> f x) m
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE mapEither #-}
+#endif
+
+-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
+--
+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)
+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
+-- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])
+-- >
+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
+-- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
+
+mapEitherWithKey :: Ord k =>
+ (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)
+mapEitherWithKey _ Tip = (Tip, Tip)
+mapEitherWithKey f (Bin _ kx x l r) = case f kx x of
+ Left y -> (join kx y l1 r1, merge l2 r2)
+ Right z -> (merge l1 r1, join kx z l2 r2)
+ where
+ (l1,l2) = mapEitherWithKey f l
+ (r1,r2) = mapEitherWithKey f r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE mapEitherWithKey #-}
+#endif
+
+{--------------------------------------------------------------------
+ Mapping
+--------------------------------------------------------------------}
+-- | /O(n)/. Map a function over all values in the map.
+--
+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]
+
+map :: (a -> b) -> Map k a -> Map k b
+map f = mapWithKey (\_ x -> f x)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE map #-}
+#endif
+
+-- | /O(n)/. Map a function over all values in the map.
+--
+-- > let f key x = (show key) ++ ":" ++ x
+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]
+
+mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
+mapWithKey _ Tip = Tip
+mapWithKey f (Bin sx kx x l r) = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE mapWithKey #-}
+#endif
+
+-- | /O(n)/. The function 'mapAccum' threads an accumulating
+-- argument through the map in ascending order of keys.
+--
+-- > let f a b = (a ++ b, b ++ "X")
+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])
+
+mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
+mapAccum f a m
+ = mapAccumWithKey (\a' _ x' -> f a' x') a m
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE mapAccum #-}
+#endif
+
+-- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
+-- argument through the map in ascending order of keys.
+--
+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")
+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])
+
+mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
+mapAccumWithKey f a t
+ = mapAccumL f a t
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE mapAccumWithKey #-}
+#endif
+
+-- | /O(n)/. The function 'mapAccumL' threads an accumulating
+-- argument through the map in ascending order of keys.
+mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
+mapAccumL _ a Tip = (a,Tip)
+mapAccumL f a (Bin sx kx x l r) =
+ let (a1,l') = mapAccumL f a l
+ (a2,x') = f a1 kx x
+ (a3,r') = mapAccumL f a2 r
+ in (a3,Bin sx kx x' l' r')
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE mapAccumL #-}
+#endif
+
+-- | /O(n)/. The function 'mapAccumR' threads an accumulating
+-- argument through the map in descending order of keys.
+mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
+mapAccumRWithKey _ a Tip = (a,Tip)
+mapAccumRWithKey f a (Bin sx kx x l r) =
+ let (a1,r') = mapAccumRWithKey f a r
+ (a2,x') = f a1 kx x
+ (a3,l') = mapAccumRWithKey f a2 l
+ in (a3,Bin sx kx x' l' r')
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE mapAccumRWithKey #-}
+#endif
+
+-- | /O(n*log n)/.
+-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
+--
+-- The size of the result may be smaller if @f@ maps two or more distinct
+-- keys to the same new key. In this case the value at the smallest of
+-- these keys is retained.
+--
+-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")]
+-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"
+-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"
+
+mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
+mapKeys = mapKeysWith (\x _ -> x)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE mapKeys #-}
+#endif
+
+-- | /O(n*log n)/.
+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
+--
+-- The size of the result may be smaller if @f@ maps two or more distinct
+-- keys to the same new key. In this case the associated values will be
+-- combined using @c@.
+--
+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"
+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"
+
+mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
+mapKeysWith c f = fromListWith c . List.map fFirst . toList
+ where fFirst (x,y) = (f x, y)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE mapKeysWith #-}
+#endif
+
+
+-- | /O(n)/.
+-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
+-- is strictly monotonic.
+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.
+-- /The precondition is not checked./
+-- Semi-formally, we have:
+--
+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]
+-- > ==> mapKeysMonotonic f s == mapKeys f s
+-- > where ls = keys s
+--
+-- This means that @f@ maps distinct original keys to distinct resulting keys.
+-- This function has better performance than 'mapKeys'.
+--
+-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]
+-- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True
+-- > valid (mapKeysMonotonic (\ _ -> 1) (fromList [(5,"a"), (3,"b")])) == False
+
+mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
+mapKeysMonotonic _ Tip = Tip
+mapKeysMonotonic f (Bin sz k x l r) =
+ Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE mapKeysMonotonic #-}
+#endif
+
+{--------------------------------------------------------------------
+ Folds
+--------------------------------------------------------------------}
+
+-- | /O(n)/. Fold the values in the map, such that
+-- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
+-- For example,
+--
+-- > elems map = fold (:) [] map
+--
+-- > let f a len = len + (length a)
+-- > fold f 0 (fromList [(5,"a"), (3,"bbb")]) == 4
+fold :: (a -> b -> b) -> b -> Map k a -> b
+fold f = foldWithKey (\_ x' z' -> f x' z')
+{-# INLINE fold #-}
+
+-- | /O(n)/. Fold the keys and values in the map, such that
+-- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
+-- For example,
+--
+-- > keys map = foldWithKey (\k x ks -> k:ks) [] map
+--
+-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
+-- > foldWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"
+--
+-- This is identical to 'foldrWithKey', and you should use that one instead of
+-- this one. This name is kept for backward compatibility.
+foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
+foldWithKey = foldrWithKey
+{-# DEPRECATED foldWithKey "Use foldrWithKey instead" #-}
+{-# INLINE foldWithKey #-}
+
+-- | /O(n)/. Post-order fold. The function will be applied from the lowest
+-- value to the highest.
+foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
+foldrWithKey f = go
+ where
+ go z Tip = z
+ go z (Bin _ kx x l r) = go (f kx x (go z r)) l
+{-# INLINE foldrWithKey #-}
+
+-- | /O(n)/. A strict version of 'foldrWithKey'.
+foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b
+foldrWithKey' f = go
+ where
+ go z Tip = z
+ go z (Bin _ kx x l r) = let z' = go z r
+ in z `seq` z' `seq` go (f kx x z') l
+{-# INLINE foldrWithKey' #-}
+
+-- | /O(n)/. Pre-order fold. The function will be applied from the highest
+-- value to the lowest.
+foldlWithKey :: (b -> k -> a -> b) -> b -> Map k a -> b
+foldlWithKey f = go
+ where
+ go z Tip = z
+ go z (Bin _ kx x l r) = go (f (go z l) kx x) r
+{-# INLINE foldlWithKey #-}
+
+-- | /O(n)/. A strict version of 'foldlWithKey'.
+foldlWithKey' :: (b -> k -> a -> b) -> b -> Map k a -> b
+foldlWithKey' f = go
+ where
+ go z Tip = z
+ go z (Bin _ kx x l r) = let z' = go z l
+ in z `seq` z' `seq` go (f z' kx x) r
+{-# INLINE foldlWithKey' #-}
+
+{--------------------------------------------------------------------
+ List variations
+--------------------------------------------------------------------}
+-- | /O(n)/.
+-- Return all elements of the map in the ascending order of their keys.
+--
+-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]
+-- > elems empty == []
+
+elems :: Map k a -> [a]
+elems m
+ = [x | (_,x) <- assocs m]
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE elems #-}
+#endif
+
+-- | /O(n)/. Return all keys of the map in ascending order.
+--
+-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]
+-- > keys empty == []
+
+keys :: Map k a -> [k]
+keys m
+ = [k | (k,_) <- assocs m]
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE keys #-}
+#endif
+
+-- | /O(n)/. The set of all keys of the map.
+--
+-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5]
+-- > keysSet empty == Data.Set.empty
+
+keysSet :: Map k a -> Set.Set k
+keysSet m = Set.fromDistinctAscList (keys m)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE keysSet #-}
+#endif
+
+-- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
+--
+-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
+-- > assocs empty == []
+
+assocs :: Map k a -> [(k,a)]
+assocs m
+ = toList m
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE assocs #-}
+#endif
+
+{--------------------------------------------------------------------
+ Lists
+ use [foldlStrict] to reduce demand on the control-stack
+--------------------------------------------------------------------}
+-- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
+-- If the list contains more than one value for the same key, the last value
+-- for the key is retained.
+--
+-- > fromList [] == empty
+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]
+
+fromList :: Ord k => [(k,a)] -> Map k a
+fromList xs
+ = foldlStrict ins empty xs
+ where
+ ins t (k,x) = insert k x t
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE fromList #-}
+#endif
+
+-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
+--
+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]
+-- > fromListWith (++) [] == empty
+
+fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
+fromListWith f xs
+ = fromListWithKey (\_ x y -> f x y) xs
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE fromListWith #-}
+#endif
+
+-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
+--
+-- > let f k a1 a2 = (show k) ++ a1 ++ a2
+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]
+-- > fromListWithKey f [] == empty
+
+fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
+fromListWithKey f xs
+ = foldlStrict ins empty xs
+ where
+ ins t (k,x) = insertWithKey f k x t
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE fromListWithKey #-}
+#endif
+
+-- | /O(n)/. Convert to a list of key\/value pairs.
+--
+-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
+-- > toList empty == []
+
+toList :: Map k a -> [(k,a)]
+toList t = toAscList t
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE toList #-}
+#endif
+
+-- | /O(n)/. Convert to an ascending list.
+--
+-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
+
+toAscList :: Map k a -> [(k,a)]
+toAscList t = foldrWithKey (\k x xs -> (k,x):xs) [] t
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE toAscList #-}
+#endif
+
+-- | /O(n)/. Convert to a descending list.
+toDescList :: Map k a -> [(k,a)]
+toDescList t = foldlWithKey (\xs k x -> (k,x):xs) [] t
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE toDescList #-}
+#endif
+
+{--------------------------------------------------------------------
+ Building trees from ascending/descending lists can be done in linear time.
+
+ Note that if [xs] is ascending that:
+ fromAscList xs == fromList xs
+ fromAscListWith f xs == fromListWith f xs
+--------------------------------------------------------------------}
+-- | /O(n)/. Build a map from an ascending list in linear time.
+-- /The precondition (input list is ascending) is not checked./
+--
+-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]
+-- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True
+-- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False
+
+fromAscList :: Eq k => [(k,a)] -> Map k a
+fromAscList xs
+ = fromAscListWithKey (\_ x _ -> x) xs
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE fromAscList #-}
+#endif
+
+-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
+-- /The precondition (input list is ascending) is not checked./
+--
+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]
+-- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True
+-- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False
+
+fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
+fromAscListWith f xs
+ = fromAscListWithKey (\_ x y -> f x y) xs
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE fromAscListWith #-}
+#endif
+
+-- | /O(n)/. Build a map from an ascending list in linear time with a
+-- combining function for equal keys.
+-- /The precondition (input list is ascending) is not checked./
+--
+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2
+-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]
+-- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True
+-- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False
+
+fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
+fromAscListWithKey f xs
+ = fromDistinctAscList (combineEq f xs)
+ where
+ -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
+ combineEq _ xs'
+ = case xs' of
+ [] -> []
+ [x] -> [x]
+ (x:xx) -> combineEq' x xx
+
+ combineEq' z [] = [z]
+ combineEq' z@(kz,zz) (x@(kx,xx):xs')
+ | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs'
+ | otherwise = z:combineEq' x xs'
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE fromAscListWithKey #-}
+#endif
+
+
+-- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
+-- /The precondition is not checked./
+--
+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
+-- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True
+-- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False
+
+fromDistinctAscList :: [(k,a)] -> Map k a
+fromDistinctAscList xs
+ = build const (length xs) xs
+ where
+ -- 1) use continuations so that we use heap space instead of stack space.
+ -- 2) special case for n==5 to build bushier trees.
+ build c 0 xs' = c Tip xs'
+ build c 5 xs' = case xs' of
+ ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
+ -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
+ _ -> error "fromDistinctAscList build"
+ build c n xs' = seq nr $ build (buildR nr c) nl xs'
+ where
+ nl = n `div` 2
+ nr = n - nl - 1
+
+ buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
+ buildR _ _ _ [] = error "fromDistinctAscList buildR []"
+ buildB l k x c r zs = c (bin k x l r) zs
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE fromDistinctAscList #-}
+#endif
+
+
+{--------------------------------------------------------------------
+ Utility functions that return sub-ranges of the original
+ tree. Some functions take a `Maybe value` as an argument to
+ allow comparisons against infinite values. These are called `blow`
+ (Nothing is -\infty) and `bhigh` (here Nothing is +\infty).
+ We use MaybeS value, which is a Maybe strict in the Just case.
+
+ [trim blow bhigh t] A tree that is either empty or where [x > blow]
+ and [x < bhigh] for the value [x] of the root.
+ [filterGt blow t] A tree where for all values [k]. [k > blow]
+ [filterLt bhigh t] A tree where for all values [k]. [k < bhigh]
+
+ [split k t] Returns two trees [l] and [r] where all keys
+ in [l] are <[k] and all keys in [r] are >[k].
+ [splitLookup k t] Just like [split] but also returns whether [k]
+ was found in the tree.
+--------------------------------------------------------------------}
+
+data MaybeS a = NothingS | JustS !a
+
+{--------------------------------------------------------------------
+ [trim blo bhi t] trims away all subtrees that surely contain no
+ values between the range [blo] to [bhi]. The returned tree is either
+ empty or the key of the root is between @blo@ and @bhi@.
+--------------------------------------------------------------------}
+trim :: Ord k => MaybeS k -> MaybeS k -> Map k a -> Map k a
+trim NothingS NothingS t = t
+trim (JustS lk) NothingS t = greater lk t where greater lo (Bin _ k _ _ r) | k <= lo = greater lo r
+ greater _ t' = t'
+trim NothingS (JustS hk) t = lesser hk t where lesser hi (Bin _ k _ l _) | k >= hi = lesser hi l
+ lesser _ t' = t'
+trim (JustS lk) (JustS hk) t = middle lk hk t where middle lo hi (Bin _ k _ _ r) | k <= lo = middle lo hi r
+ middle lo hi (Bin _ k _ l _) | k >= hi = middle lo hi l
+ middle _ _ t' = t'
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE trim #-}
+#endif
+
+trimLookupLo :: Ord k => k -> MaybeS k -> Map k a -> (Maybe (k,a), Map k a)
+trimLookupLo _ _ Tip = (Nothing, Tip)
+trimLookupLo lo hi t@(Bin _ kx x l r)
+ = case compare lo kx of
+ LT -> case compare' kx hi of
+ LT -> (lookupAssoc lo t, t)
+ _ -> trimLookupLo lo hi l
+ GT -> trimLookupLo lo hi r
+ EQ -> (Just (kx,x),trim (JustS lo) hi r)
+ where compare' _ NothingS = LT
+ compare' kx' (JustS hi') = compare kx' hi'
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE trimLookupLo #-}
+#endif
+
+
+{--------------------------------------------------------------------
+ [filterGt b t] filter all keys >[b] from tree [t]
+ [filterLt b t] filter all keys <[b] from tree [t]
+--------------------------------------------------------------------}
+filterGt :: Ord k => MaybeS k -> Map k v -> Map k v
+filterGt NothingS t = t
+filterGt (JustS b) t = filter' b t
+ where filter' _ Tip = Tip
+ filter' b' (Bin _ kx x l r) =
+ case compare b' kx of LT -> join kx x (filter' b' l) r
+ EQ -> r
+ GT -> filter' b' r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE filterGt #-}
+#endif
+
+filterLt :: Ord k => MaybeS k -> Map k v -> Map k v
+filterLt NothingS t = t
+filterLt (JustS b) t = filter' b t
+ where filter' _ Tip = Tip
+ filter' b' (Bin _ kx x l r) =
+ case compare kx b' of LT -> join kx x l (filter' b' r)
+ EQ -> l
+ GT -> filter' b' l
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE filterLt #-}
+#endif
+
+{--------------------------------------------------------------------
+ Split
+--------------------------------------------------------------------}
+-- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where
+-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.
+-- Any key equal to @k@ is found in neither @map1@ nor @map2@.
+--
+-- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])
+-- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")
+-- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
+-- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)
+-- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)
+
+split :: Ord k => k -> Map k a -> (Map k a,Map k a)
+split k t = k `seq`
+ case t of
+ Tip -> (Tip, Tip)
+ Bin _ kx x l r -> case compare k kx of
+ LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
+ GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
+ EQ -> (l,r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE split #-}
+#endif
+
+-- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just
+-- like 'split' but also returns @'lookup' k map@.
+--
+-- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])
+-- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")
+-- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")
+-- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)
+-- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)
+
+splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)
+splitLookup k t = k `seq`
+ case t of
+ Tip -> (Tip,Nothing,Tip)
+ Bin _ kx x l r -> case compare k kx of
+ LT -> let (lt,z,gt) = splitLookup k l in (lt,z,join kx x gt r)
+ GT -> let (lt,z,gt) = splitLookup k r in (join kx x l lt,z,gt)
+ EQ -> (l,Just x,r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE splitLookup #-}
+#endif
+
+-- | /O(log n)/.
+splitLookupWithKey :: Ord k => k -> Map k a -> (Map k a,Maybe (k,a),Map k a)
+splitLookupWithKey k t = k `seq`
+ case t of
+ Tip -> (Tip,Nothing,Tip)
+ Bin _ kx x l r -> case compare k kx of
+ LT -> let (lt,z,gt) = splitLookupWithKey k l in (lt,z,join kx x gt r)
+ GT -> let (lt,z,gt) = splitLookupWithKey k r in (join kx x l lt,z,gt)
+ EQ -> (l,Just (kx, x),r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE splitLookupWithKey #-}
+#endif
+
+{--------------------------------------------------------------------
+ Utility functions that maintain the balance properties of the tree.
+ All constructors assume that all values in [l] < [k] and all values
+ in [r] > [k], and that [l] and [r] are valid trees.
+
+ In order of sophistication:
+ [Bin sz k x l r] The type constructor.
+ [bin k x l r] Maintains the correct size, assumes that both [l]
+ and [r] are balanced with respect to each other.
+ [balance k x l r] Restores the balance and size.
+ Assumes that the original tree was balanced and
+ that [l] or [r] has changed by at most one element.
+ [join k x l r] Restores balance and size.
+
+ Furthermore, we can construct a new tree from two trees. Both operations
+ assume that all values in [l] < all values in [r] and that [l] and [r]
+ are valid:
+ [glue l r] Glues [l] and [r] together. Assumes that [l] and
+ [r] are already balanced with respect to each other.
+ [merge l r] Merges two trees and restores balance.
+
+ Note: in contrast to Adam's paper, we use (<=) comparisons instead
+ of (<) comparisons in [join], [merge] and [balance].
+ Quickcheck (on [difference]) showed that this was necessary in order
+ to maintain the invariants. It is quite unsatisfactory that I haven't
+ been able to find out why this is actually the case! Fortunately, it
+ doesn't hurt to be a bit more conservative.
+--------------------------------------------------------------------}
+
+{--------------------------------------------------------------------
+ Join
+--------------------------------------------------------------------}
+join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
+join kx x Tip r = insertMin kx x r
+join kx x l Tip = insertMax kx x l
+join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
+ | delta*sizeL < sizeR = balanceL kz z (join kx x l lz) rz
+ | delta*sizeR < sizeL = balanceR ky y ly (join kx x ry r)
+ | otherwise = bin kx x l r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE join #-}
+#endif
+
+
+-- insertMin and insertMax don't perform potentially expensive comparisons.
+insertMax,insertMin :: k -> a -> Map k a -> Map k a
+insertMax kx x t
+ = case t of
+ Tip -> singleton kx x
+ Bin _ ky y l r
+ -> balanceR ky y l (insertMax kx x r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE insertMax #-}
+#endif
+
+insertMin kx x t
+ = case t of
+ Tip -> singleton kx x
+ Bin _ ky y l r
+ -> balanceL ky y (insertMin kx x l) r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE insertMin #-}
+#endif
+
+{--------------------------------------------------------------------
+ [merge l r]: merges two trees.
+--------------------------------------------------------------------}
+merge :: Map k a -> Map k a -> Map k a
+merge Tip r = r
+merge l Tip = l
+merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
+ | delta*sizeL < sizeR = balanceL ky y (merge l ly) ry
+ | delta*sizeR < sizeL = balanceR kx x lx (merge rx r)
+ | otherwise = glue l r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE merge #-}
+#endif
+
+{--------------------------------------------------------------------
+ [glue l r]: glues two trees together.
+ Assumes that [l] and [r] are already balanced with respect to each other.
+--------------------------------------------------------------------}
+glue :: Map k a -> Map k a -> Map k a
+glue Tip r = r
+glue l Tip = l
+glue l r
+ | size l > size r = let ((km,m),l') = deleteFindMax l in balanceR km m l' r
+ | otherwise = let ((km,m),r') = deleteFindMin r in balanceL km m l r'
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE glue #-}
+#endif
+
+
+-- | /O(log n)/. Delete and find the minimal element.
+--
+-- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")])
+-- > deleteFindMin Error: can not return the minimal element of an empty map
+
+deleteFindMin :: Map k a -> ((k,a),Map k a)
+deleteFindMin t
+ = case t of
+ Bin _ k x Tip r -> ((k,x),r)
+ Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balanceR k x l' r)
+ Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE deleteFindMin #-}
+#endif
+
+-- | /O(log n)/. Delete and find the maximal element.
+--
+-- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")])
+-- > deleteFindMax empty Error: can not return the maximal element of an empty map
+
+deleteFindMax :: Map k a -> ((k,a),Map k a)
+deleteFindMax t
+ = case t of
+ Bin _ k x l Tip -> ((k,x),l)
+ Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balanceL k x l r')
+ Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE deleteFindMax #-}
+#endif
+
+
+{--------------------------------------------------------------------
+ [balance l x r] balances two trees with value x.
+ The sizes of the trees should balance after decreasing the
+ size of one of them. (a rotation).
+
+ [delta] is the maximal relative difference between the sizes of
+ two trees, it corresponds with the [w] in Adams' paper.
+ [ratio] is the ratio between an outer and inner sibling of the
+ heavier subtree in an unbalanced setting. It determines
+ whether a double or single rotation should be performed
+ to restore balance. It is corresponds with the inverse
+ of $\alpha$ in Adam's article.
+
+ Note that according to the Adam's paper:
+ - [delta] should be larger than 4.646 with a [ratio] of 2.
+ - [delta] should be larger than 3.745 with a [ratio] of 1.534.
+
+ But the Adam's paper is erroneous:
+ - It can be proved that for delta=2 and delta>=5 there does
+ not exist any ratio that would work.
+ - Delta=4.5 and ratio=2 does not work.
+
+ That leaves two reasonable variants, delta=3 and delta=4,
+ both with ratio=2.
+
+ - A lower [delta] leads to a more 'perfectly' balanced tree.
+ - A higher [delta] performs less rebalancing.
+
+ In the benchmarks, delta=3 is faster on insert operations,
+ and delta=4 has slightly better deletes. As the insert speedup
+ is larger, we currently use delta=3.
+
+--------------------------------------------------------------------}
+delta,ratio :: Int
+delta = 3
+ratio = 2
+
+-- The balance function is equivalent to the following:
+--
+-- balance :: k -> a -> Map k a -> Map k a -> Map k a
+-- balance k x l r
+-- | sizeL + sizeR <= 1 = Bin sizeX k x l r
+-- | sizeR > delta*sizeL = rotateL k x l r
+-- | sizeL > delta*sizeR = rotateR k x l r
+-- | otherwise = Bin sizeX k x l r
+-- where
+-- sizeL = size l
+-- sizeR = size r
+-- sizeX = sizeL + sizeR + 1
+--
+-- rotateL :: a -> b -> Map a b -> Map a b -> Map a b
+-- rotateL k x l r@(Bin _ _ _ ly ry) | size ly < ratio*size ry = singleL k x l r
+-- | otherwise = doubleL k x l r
+--
+-- rotateR :: a -> b -> Map a b -> Map a b -> Map a b
+-- rotateR k x l@(Bin _ _ _ ly ry) r | size ry < ratio*size ly = singleR k x l r
+-- | otherwise = doubleR k x l r
+--
+-- singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b
+-- singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
+-- singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)
+--
+-- doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b
+-- doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)
+-- doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)
+--
+-- It is only written in such a way that every node is pattern-matched only once.
+
+balance :: k -> a -> Map k a -> Map k a -> Map k a
+balance k x l r = case l of
+ Tip -> case r of
+ Tip -> Bin 1 k x Tip Tip
+ (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r
+ (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr
+ (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)
+ (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))
+ | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr
+ | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)
+
+ (Bin ls lk lx ll lr) -> case r of
+ Tip -> case (ll, lr) of
+ (Tip, Tip) -> Bin 2 k x l Tip
+ (Tip, (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)
+ ((Bin _ _ _ _ _), Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)
+ ((Bin lls _ _ _ _), (Bin lrs lrk lrx lrl lrr))
+ | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)
+ | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)
+ (Bin rs rk rx rl rr)
+ | rs > delta*ls -> case (rl, rr) of
+ (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)
+ | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr
+ | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)
+ (_, _) -> error "Failure in Data.Map.balance"
+ | ls > delta*rs -> case (ll, lr) of
+ (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)
+ | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)
+ | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)
+ (_, _) -> error "Failure in Data.Map.balance"
+ | otherwise -> Bin (1+ls+rs) k x l r
+{-# NOINLINE balance #-}
+
+-- Functions balanceL and balanceR are specialised versions of balance.
+-- balanceL only checks whether the left subtree is too big,
+-- balanceR only checks whether the right subtree is too big.
+
+-- balanceL is called when left subtree might have been inserted to or when
+-- right subtree might have been deleted from.
+balanceL :: k -> a -> Map k a -> Map k a -> Map k a
+balanceL k x l r = case r of
+ Tip -> case l of
+ Tip -> Bin 1 k x Tip Tip
+ (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip
+ (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)
+ (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)
+ (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))
+ | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)
+ | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)
+
+ (Bin rs _ _ _ _) -> case l of
+ Tip -> Bin (1+rs) k x Tip r
+
+ (Bin ls lk lx ll lr)
+ | ls > delta*rs -> case (ll, lr) of
+ (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)
+ | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)
+ | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)
+ (_, _) -> error "Failure in Data.Map.balanceL"
+ | otherwise -> Bin (1+ls+rs) k x l r
+{-# NOINLINE balanceL #-}
+
+-- balanceR is called when right subtree might have been inserted to or when
+-- left subtree might have been deleted from.
+balanceR :: k -> a -> Map k a -> Map k a -> Map k a
+balanceR k x l r = case l of
+ Tip -> case r of
+ Tip -> Bin 1 k x Tip Tip
+ (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r
+ (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr
+ (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)
+ (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))
+ | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr
+ | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)
+
+ (Bin ls _ _ _ _) -> case r of
+ Tip -> Bin (1+ls) k x l Tip
+
+ (Bin rs rk rx rl rr)
+ | rs > delta*ls -> case (rl, rr) of
+ (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)
+ | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr
+ | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)
+ (_, _) -> error "Failure in Data.Map.balanceR"
+ | otherwise -> Bin (1+ls+rs) k x l r
+{-# NOINLINE balanceR #-}
+
+
+{--------------------------------------------------------------------
+ The bin constructor maintains the size of the tree
+--------------------------------------------------------------------}
+bin :: k -> a -> Map k a -> Map k a -> Map k a
+bin k x l r
+ = Bin (size l + size r + 1) k x l r
+{-# INLINE bin #-}
+
+
+{--------------------------------------------------------------------
+ Eq converts the tree to a list. In a lazy setting, this
+ actually seems one of the faster methods to compare two trees
+ and it is certainly the simplest :-)
+--------------------------------------------------------------------}
+instance (Eq k,Eq a) => Eq (Map k a) where
+ t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
+
+{--------------------------------------------------------------------
+ Ord
+--------------------------------------------------------------------}
+
+instance (Ord k, Ord v) => Ord (Map k v) where
+ compare m1 m2 = compare (toAscList m1) (toAscList m2)
+
+{--------------------------------------------------------------------
+ Functor
+--------------------------------------------------------------------}
+instance Functor (Map k) where
+ fmap f m = map f m
+
+instance Traversable (Map k) where
+ traverse _ Tip = pure Tip
+ traverse f (Bin s k v l r)
+ = flip (Bin s k) <$> traverse f l <*> f v <*> traverse f r
+
+instance Foldable (Map k) where
+ foldMap _f Tip = mempty
+ foldMap f (Bin _s _k v l r)
+ = foldMap f l `mappend` f v `mappend` foldMap f r
+
+{--------------------------------------------------------------------
+ Read
+--------------------------------------------------------------------}
+instance (Ord k, Read k, Read e) => Read (Map k e) where
+#ifdef __GLASGOW_HASKELL__
+ readPrec = parens $ prec 10 $ do
+ Ident "fromList" <- lexP
+ xs <- readPrec
+ return (fromList xs)
+
+ readListPrec = readListPrecDefault
+#else
+ readsPrec p = readParen (p > 10) $ \ r -> do
+ ("fromList",s) <- lex r
+ (xs,t) <- reads s
+ return (fromList xs,t)
+#endif
+
+{--------------------------------------------------------------------
+ Show
+--------------------------------------------------------------------}
+instance (Show k, Show a) => Show (Map k a) where
+ showsPrec d m = showParen (d > 10) $
+ showString "fromList " . shows (toList m)
+
+-- | /O(n)/. Show the tree that implements the map. The tree is shown
+-- in a compressed, hanging format. See 'showTreeWith'.
+showTree :: (Show k,Show a) => Map k a -> String
+showTree m
+ = showTreeWith showElem True False m
+ where
+ showElem k x = show k ++ ":=" ++ show x
+
+
+{- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows
+ the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
+ @wide@ is 'True', an extra wide version is shown.
+
+> Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
+> (4,())
+> +--(2,())
+> | +--(1,())
+> | +--(3,())
+> +--(5,())
+>
+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
+> (4,())
+> |
+> +--(2,())
+> | |
+> | +--(1,())
+> | |
+> | +--(3,())
+> |
+> +--(5,())
+>
+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
+> +--(5,())
+> |
+> (4,())
+> |
+> | +--(3,())
+> | |
+> +--(2,())
+> |
+> +--(1,())
+
+-}
+showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
+showTreeWith showelem hang wide t
+ | hang = (showsTreeHang showelem wide [] t) ""
+ | otherwise = (showsTree showelem wide [] [] t) ""
+
+showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
+showsTree showelem wide lbars rbars t
+ = case t of
+ Tip -> showsBars lbars . showString "|\n"
+ Bin _ kx x Tip Tip
+ -> showsBars lbars . showString (showelem kx x) . showString "\n"
+ Bin _ kx x l r
+ -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
+ showWide wide rbars .
+ showsBars lbars . showString (showelem kx x) . showString "\n" .
+ showWide wide lbars .
+ showsTree showelem wide (withEmpty lbars) (withBar lbars) l
+
+showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
+showsTreeHang showelem wide bars t
+ = case t of
+ Tip -> showsBars bars . showString "|\n"
+ Bin _ kx x Tip Tip
+ -> showsBars bars . showString (showelem kx x) . showString "\n"
+ Bin _ kx x l r
+ -> showsBars bars . showString (showelem kx x) . showString "\n" .
+ showWide wide bars .
+ showsTreeHang showelem wide (withBar bars) l .
+ showWide wide bars .
+ showsTreeHang showelem wide (withEmpty bars) r
+
+showWide :: Bool -> [String] -> String -> String
+showWide wide bars
+ | wide = showString (concat (reverse bars)) . showString "|\n"
+ | otherwise = id
+
+showsBars :: [String] -> ShowS
+showsBars bars
+ = case bars of
+ [] -> id
+ _ -> showString (concat (reverse (tail bars))) . showString node
+
+node :: String
+node = "+--"
+
+withBar, withEmpty :: [String] -> [String]
+withBar bars = "| ":bars
+withEmpty bars = " ":bars
+
+{--------------------------------------------------------------------
+ Typeable
+--------------------------------------------------------------------}
+
+#include "Typeable.h"
+INSTANCE_TYPEABLE2(Map,mapTc,"Map")
+
+{--------------------------------------------------------------------
+ Assertions
+--------------------------------------------------------------------}
+-- | /O(n)/. Test if the internal map structure is valid.
+--
+-- > valid (fromAscList [(3,"b"), (5,"a")]) == True
+-- > valid (fromAscList [(5,"a"), (3,"b")]) == False
+
+valid :: Ord k => Map k a -> Bool
+valid t
+ = balanced t && ordered t && validsize t
+
+ordered :: Ord a => Map a b -> Bool
+ordered t
+ = bounded (const True) (const True) t
+ where
+ bounded lo hi t'
+ = case t' of
+ Tip -> True
+ Bin _ kx _ l r -> (lo kx) && (hi kx) && bounded lo (kx) hi r
+
+-- | Exported only for "Debug.QuickCheck"
+balanced :: Map k a -> Bool
+balanced t
+ = case t of
+ Tip -> True
+ Bin _ _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
+ balanced l && balanced r
+
+validsize :: Map a b -> Bool
+validsize t
+ = (realsize t == Just (size t))
+ where
+ realsize t'
+ = case t' of
+ Tip -> Just 0
+ Bin sz _ _ l r -> case (realsize l,realsize r) of
+ (Just n,Just m) | n+m+1 == sz -> Just sz
+ _ -> Nothing
+
+{--------------------------------------------------------------------
+ Utilities
+--------------------------------------------------------------------}
+foldlStrict :: (a -> b -> a) -> a -> [b] -> a
+foldlStrict f = go
+ where
+ go z [] = z
+ go z (x:xs) = let z' = f z x in z' `seq` go z' xs
+{-# INLINE foldlStrict #-}
diff --git a/Data/Sequence.hs b/Data/Sequence.hs
--- a/Data/Sequence.hs
+++ b/Data/Sequence.hs
@@ -1,1845 +1,1853 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS -cpp #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Sequence
--- Copyright : (c) Ross Paterson 2005
--- (c) Louis Wasserman 2009
--- License : BSD-style
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- General purpose finite sequences.
--- Apart from being finite and having strict operations, sequences
--- also differ from lists in supporting a wider variety of operations
--- efficiently.
---
--- An amortized running time is given for each operation, with /n/ referring
--- to the length of the sequence and /i/ being the integral index used by
--- some operations. These bounds hold even in a persistent (shared) setting.
---
--- The implementation uses 2-3 finger trees annotated with sizes,
--- as described in section 4.2 of
---
--- * Ralf Hinze and Ross Paterson,
--- \"Finger trees: a simple general-purpose data structure\",
--- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
---
---
--- /Note/: Many of these operations have the same names as similar
--- operations on lists in the "Prelude". The ambiguity may be resolved
--- using either qualification or the @hiding@ clause.
---
------------------------------------------------------------------------------
-
-module Data.Sequence (
- Seq,
- -- * Construction
- empty, -- :: Seq a
- singleton, -- :: a -> Seq a
- (<|), -- :: a -> Seq a -> Seq a
- (|>), -- :: Seq a -> a -> Seq a
- (><), -- :: Seq a -> Seq a -> Seq a
- fromList, -- :: [a] -> Seq a
- -- ** Repetition
- replicate, -- :: Int -> a -> Seq a
- replicateA, -- :: Applicative f => Int -> f a -> f (Seq a)
- replicateM, -- :: Monad m => Int -> m a -> m (Seq a)
- -- ** Iterative construction
- iterateN, -- :: Int -> (a -> a) -> a -> Seq a
- unfoldr, -- :: (b -> Maybe (a, b)) -> b -> Seq a
- unfoldl, -- :: (b -> Maybe (b, a)) -> b -> Seq a
- -- * Deconstruction
- -- | Additional functions for deconstructing sequences are available
- -- via the 'Foldable' instance of 'Seq'.
-
- -- ** Queries
- null, -- :: Seq a -> Bool
- length, -- :: Seq a -> Int
- -- ** Views
- ViewL(..),
- viewl, -- :: Seq a -> ViewL a
- ViewR(..),
- viewr, -- :: Seq a -> ViewR a
- -- * Scans
- scanl, -- :: (a -> b -> a) -> a -> Seq b -> Seq a
- scanl1, -- :: (a -> a -> a) -> Seq a -> Seq a
- scanr, -- :: (a -> b -> b) -> b -> Seq a -> Seq b
- scanr1, -- :: (a -> a -> a) -> Seq a -> Seq a
- -- * Sublists
- tails, -- :: Seq a -> Seq (Seq a)
- inits, -- :: Seq a -> Seq (Seq a)
- -- ** Sequential searches
- takeWhileL, -- :: (a -> Bool) -> Seq a -> Seq a
- takeWhileR, -- :: (a -> Bool) -> Seq a -> Seq a
- dropWhileL, -- :: (a -> Bool) -> Seq a -> Seq a
- dropWhileR, -- :: (a -> Bool) -> Seq a -> Seq a
- spanl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
- spanr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
- breakl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
- breakr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
- partition, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
- filter, -- :: (a -> Bool) -> Seq a -> Seq a
- -- * Sorting
- sort, -- :: Ord a => Seq a -> Seq a
- sortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
- unstableSort, -- :: Ord a => Seq a -> Seq a
- unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
- -- * Indexing
- index, -- :: Seq a -> Int -> a
- adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a
- update, -- :: Int -> a -> Seq a -> Seq a
- take, -- :: Int -> Seq a -> Seq a
- drop, -- :: Int -> Seq a -> Seq a
- splitAt, -- :: Int -> Seq a -> (Seq a, Seq a)
- -- ** Indexing with predicates
- -- | These functions perform sequential searches from the left
- -- or right ends of the sequence, returning indices of matching
- -- elements.
- elemIndexL, -- :: Eq a => a -> Seq a -> Maybe Int
- elemIndicesL, -- :: Eq a => a -> Seq a -> [Int]
- elemIndexR, -- :: Eq a => a -> Seq a -> Maybe Int
- elemIndicesR, -- :: Eq a => a -> Seq a -> [Int]
- findIndexL, -- :: (a -> Bool) -> Seq a -> Maybe Int
- findIndicesL, -- :: (a -> Bool) -> Seq a -> [Int]
- findIndexR, -- :: (a -> Bool) -> Seq a -> Maybe Int
- findIndicesR, -- :: (a -> Bool) -> Seq a -> [Int]
- -- * Folds
- -- | General folds are available via the 'Foldable' instance of 'Seq'.
- foldlWithIndex, -- :: (b -> Int -> a -> b) -> b -> Seq a -> b
- foldrWithIndex, -- :: (Int -> a -> b -> b) -> b -> Seq a -> b
- -- * Transformations
- mapWithIndex, -- :: (Int -> a -> b) -> Seq a -> Seq b
- reverse, -- :: Seq a -> Seq a
- -- ** Zips
- zip, -- :: Seq a -> Seq b -> Seq (a, b)
- zipWith, -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
- zip3, -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)
- zipWith3, -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
- zip4, -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)
- zipWith4, -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
-#if TESTING
- valid,
-#endif
- ) where
-
-import Prelude hiding (
- Functor(..),
- null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
- scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,
- takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)
-import qualified Data.List (foldl', sortBy)
-import Control.Applicative (Applicative(..), (<$>), WrappedMonad(..), liftA, liftA2, liftA3)
-import Control.Monad (MonadPlus(..), ap)
-import Data.Monoid (Monoid(..))
-import Data.Functor (Functor(..))
-import Data.Foldable
-import Data.Traversable
-#ifndef __GLASGOW_HASKELL__
-import Data.Typeable (Typeable, typeOf, typeOfDefault)
-#endif
-import Data.Typeable (TyCon, Typeable1(..), mkTyCon, mkTyConApp )
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Exts (build)
-import Text.Read (Lexeme(Ident), lexP, parens, prec,
- readPrec, readListPrec, readListPrecDefault)
-import Data.Data (Data(..), DataType, Constr, Fixity(..),
- mkConstr, mkDataType, constrIndex, gcast1)
-#endif
-
-#if TESTING
-import Control.Monad (liftM, liftM2, liftM3, liftM4)
-import qualified Data.List (zipWith)
-import Test.QuickCheck hiding ((><))
-#endif
-
-infixr 5 `consTree`
-infixl 5 `snocTree`
-
-infixr 5 ><
-infixr 5 <|, :<
-infixl 5 |>, :>
-
-class Sized a where
- size :: a -> Int
-
--- | General-purpose finite sequences.
-newtype Seq a = Seq (FingerTree (Elem a))
-
-instance Functor Seq where
- fmap f (Seq xs) = Seq (fmap (fmap f) xs)
-#ifdef __GLASGOW_HASKELL__
- x <$ s = replicate (length s) x
-#endif
-
-instance Foldable Seq where
- foldr f z (Seq xs) = foldr (flip (foldr f)) z xs
- foldl f z (Seq xs) = foldl (foldl f) z xs
-
- foldr1 f (Seq xs) = getElem (foldr1 f' xs)
- where f' (Elem x) (Elem y) = Elem (f x y)
-
- foldl1 f (Seq xs) = getElem (foldl1 f' xs)
- where f' (Elem x) (Elem y) = Elem (f x y)
-
-instance Traversable Seq where
- traverse f (Seq xs) = Seq <$> traverse (traverse f) xs
-
-instance Monad Seq where
- return = singleton
- xs >>= f = foldl' add empty xs
- where add ys x = ys >< f x
-
-instance MonadPlus Seq where
- mzero = empty
- mplus = (><)
-
-instance Eq a => Eq (Seq a) where
- xs == ys = length xs == length ys && toList xs == toList ys
-
-instance Ord a => Ord (Seq a) where
- compare xs ys = compare (toList xs) (toList ys)
-
-#if TESTING
-instance Show a => Show (Seq a) where
- showsPrec p (Seq x) = showsPrec p x
-#else
-instance Show a => Show (Seq a) where
- showsPrec p xs = showParen (p > 10) $
- showString "fromList " . shows (toList xs)
-#endif
-
-instance Read a => Read (Seq a) where
-#ifdef __GLASGOW_HASKELL__
- readPrec = parens $ prec 10 $ do
- Ident "fromList" <- lexP
- xs <- readPrec
- return (fromList xs)
-
- readListPrec = readListPrecDefault
-#else
- readsPrec p = readParen (p > 10) $ \ r -> do
- ("fromList",s) <- lex r
- (xs,t) <- reads s
- return (fromList xs,t)
-#endif
-
-instance Monoid (Seq a) where
- mempty = empty
- mappend = (><)
-
-#include "Typeable.h"
-INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")
-
-#if __GLASGOW_HASKELL__
-instance Data a => Data (Seq a) where
- gfoldl f z s = case viewl s of
- EmptyL -> z empty
- x :< xs -> z (<|) `f` x `f` xs
-
- gunfold k z c = case constrIndex c of
- 1 -> z empty
- 2 -> k (k (z (<|)))
- _ -> error "gunfold"
-
- toConstr xs
- | null xs = emptyConstr
- | otherwise = consConstr
-
- dataTypeOf _ = seqDataType
-
- dataCast1 f = gcast1 f
-
-emptyConstr, consConstr :: Constr
-emptyConstr = mkConstr seqDataType "empty" [] Prefix
-consConstr = mkConstr seqDataType "<|" [] Infix
-
-seqDataType :: DataType
-seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]
-#endif
-
--- Finger trees
-
-data FingerTree a
- = Empty
- | Single a
- | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)
-#if TESTING
- deriving Show
-#endif
-
-instance Sized a => Sized (FingerTree a) where
- {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}
- {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}
- size Empty = 0
- size (Single x) = size x
- size (Deep v _ _ _) = v
-
-instance Foldable FingerTree where
- foldr _ z Empty = z
- foldr f z (Single x) = x `f` z
- foldr f z (Deep _ pr m sf) =
- foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr
-
- foldl _ z Empty = z
- foldl f z (Single x) = z `f` x
- foldl f z (Deep _ pr m sf) =
- foldl f (foldl (foldl f) (foldl f z pr) m) sf
-
- foldr1 _ Empty = error "foldr1: empty sequence"
- foldr1 _ (Single x) = x
- foldr1 f (Deep _ pr m sf) =
- foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr
-
- foldl1 _ Empty = error "foldl1: empty sequence"
- foldl1 _ (Single x) = x
- foldl1 f (Deep _ pr m sf) =
- foldl f (foldl (foldl f) (foldl1 f pr) m) sf
-
-instance Functor FingerTree where
- fmap _ Empty = Empty
- fmap f (Single x) = Single (f x)
- fmap f (Deep v pr m sf) =
- Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)
-
-instance Traversable FingerTree where
- traverse _ Empty = pure Empty
- traverse f (Single x) = Single <$> f x
- traverse f (Deep v pr m sf) =
- Deep v <$> traverse f pr <*> traverse (traverse f) m <*>
- traverse f sf
-
-{-# INLINE deep #-}
-{-# SPECIALIZE INLINE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE INLINE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
-deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
-deep pr m sf = Deep (size pr + size m + size sf) pr m sf
-
-{-# INLINE pullL #-}
-pullL :: Sized a => Int -> FingerTree (Node a) -> Digit a -> FingerTree a
-pullL s m sf = case viewLTree m of
- Nothing2 -> digitToTree' s sf
- Just2 pr m' -> Deep s (nodeToDigit pr) m' sf
-
-{-# INLINE pullR #-}
-pullR :: Sized a => Int -> Digit a -> FingerTree (Node a) -> FingerTree a
-pullR s pr m = case viewRTree m of
- Nothing2 -> digitToTree' s pr
- Just2 m' sf -> Deep s pr m' (nodeToDigit sf)
-
-{-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
-deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a
-deepL Nothing m sf = pullL (size m + size sf) m sf
-deepL (Just pr) m sf = deep pr m sf
-
-{-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}
-deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a
-deepR pr m Nothing = pullR (size m + size pr) pr m
-deepR pr m (Just sf) = deep pr m sf
-
--- Digits
-
-data Digit a
- = One a
- | Two a a
- | Three a a a
- | Four a a a a
-#if TESTING
- deriving Show
-#endif
-
-instance Foldable Digit where
- foldr f z (One a) = a `f` z
- foldr f z (Two a b) = a `f` (b `f` z)
- foldr f z (Three a b c) = a `f` (b `f` (c `f` z))
- foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
-
- foldl f z (One a) = z `f` a
- foldl f z (Two a b) = (z `f` a) `f` b
- foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c
- foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
-
- foldr1 _ (One a) = a
- foldr1 f (Two a b) = a `f` b
- foldr1 f (Three a b c) = a `f` (b `f` c)
- foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))
-
- foldl1 _ (One a) = a
- foldl1 f (Two a b) = a `f` b
- foldl1 f (Three a b c) = (a `f` b) `f` c
- foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d
-
-instance Functor Digit where
- fmap = fmapDefault
-
-instance Traversable Digit where
- {-# INLINE traverse #-}
- traverse f (One a) = One <$> f a
- traverse f (Two a b) = Two <$> f a <*> f b
- traverse f (Three a b c) = Three <$> f a <*> f b <*> f c
- traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
-
-instance Sized a => Sized (Digit a) where
- {-# INLINE size #-}
- size = foldl1 (+) . fmap size
-
-{-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
-digitToTree :: Sized a => Digit a -> FingerTree a
-digitToTree (One a) = Single a
-digitToTree (Two a b) = deep (One a) Empty (One b)
-digitToTree (Three a b c) = deep (Two a b) Empty (One c)
-digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)
-
--- | Given the size of a digit and the digit itself, efficiently converts
--- it to a FingerTree.
-digitToTree' :: Int -> Digit a -> FingerTree a
-digitToTree' n (Four a b c d) = Deep n (Two a b) Empty (Two c d)
-digitToTree' n (Three a b c) = Deep n (Two a b) Empty (One c)
-digitToTree' n (Two a b) = Deep n (One a) Empty (One b)
-digitToTree' n (One a) = n `seq` Single a
-
--- Nodes
-
-data Node a
- = Node2 {-# UNPACK #-} !Int a a
- | Node3 {-# UNPACK #-} !Int a a a
-#if TESTING
- deriving Show
-#endif
-
-instance Foldable Node where
- foldr f z (Node2 _ a b) = a `f` (b `f` z)
- foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
-
- foldl f z (Node2 _ a b) = (z `f` a) `f` b
- foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
-
-instance Functor Node where
- {-# INLINE fmap #-}
- fmap = fmapDefault
-
-instance Traversable Node where
- {-# INLINE traverse #-}
- traverse f (Node2 v a b) = Node2 v <$> f a <*> f b
- traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c
-
-instance Sized (Node a) where
- size (Node2 v _ _) = v
- size (Node3 v _ _ _) = v
-
-{-# INLINE node2 #-}
-{-# SPECIALIZE node2 :: Elem a -> Elem a -> Node (Elem a) #-}
-{-# SPECIALIZE node2 :: Node a -> Node a -> Node (Node a) #-}
-node2 :: Sized a => a -> a -> Node a
-node2 a b = Node2 (size a + size b) a b
-
-{-# INLINE node3 #-}
-{-# SPECIALIZE node3 :: Elem a -> Elem a -> Elem a -> Node (Elem a) #-}
-{-# SPECIALIZE node3 :: Node a -> Node a -> Node a -> Node (Node a) #-}
-node3 :: Sized a => a -> a -> a -> Node a
-node3 a b c = Node3 (size a + size b + size c) a b c
-
-nodeToDigit :: Node a -> Digit a
-nodeToDigit (Node2 _ a b) = Two a b
-nodeToDigit (Node3 _ a b c) = Three a b c
-
--- Elements
-
-newtype Elem a = Elem { getElem :: a }
-
-instance Sized (Elem a) where
- size _ = 1
-
-instance Functor Elem where
- fmap f (Elem x) = Elem (f x)
-
-instance Foldable Elem where
- foldr f z (Elem x) = f x z
- foldl f z (Elem x) = f z x
-
-instance Traversable Elem where
- traverse f (Elem x) = Elem <$> f x
-
-#ifdef TESTING
-instance (Show a) => Show (Elem a) where
- showsPrec p (Elem x) = showsPrec p x
-#endif
-
--------------------------------------------------------
--- Applicative construction
--------------------------------------------------------
-
-newtype Id a = Id {runId :: a}
-
-instance Functor Id where
- fmap f (Id x) = Id (f x)
-
-instance Monad Id where
- return = Id
- m >>= k = k (runId m)
-
-instance Applicative Id where
- pure = return
- (<*>) = ap
-
--- | This is essentially a clone of Control.Monad.State.Strict.
-newtype State s a = State {runState :: s -> (s, a)}
-
-instance Functor (State s) where
- fmap = liftA
-
-instance Monad (State s) where
- {-# INLINE return #-}
- {-# INLINE (>>=) #-}
- return x = State $ \ s -> (s, x)
- m >>= k = State $ \ s -> case runState m s of
- (s', x) -> runState (k x) s'
-
-instance Applicative (State s) where
- pure = return
- (<*>) = ap
-
-execState :: State s a -> s -> a
-execState m x = snd (runState m x)
-
--- | A helper method: a strict version of mapAccumL.
-mapAccumL' :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c)
-mapAccumL' f s t = runState (traverse (State . flip f) t) s
-
--- | 'applicativeTree' takes an Applicative-wrapped construction of a
--- piece of a FingerTree, assumed to always have the same size (which
--- is put in the second argument), and replicates it as many times as
--- specified. This is a generalization of 'replicateA', which itself
--- is a generalization of many Data.Sequence methods.
-{-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-}
-{-# SPECIALIZE applicativeTree :: Int -> Int -> Id a -> Id (FingerTree a) #-}
--- Special note: the Id specialization automatically does node sharing,
--- reducing memory usage of the resulting tree to /O(log n)/.
-applicativeTree :: forall f a. Applicative f => Int -> Int -> f a -> f (FingerTree a)
-applicativeTree n mSize m = mSize `seq` case n of
- 0 -> emptyTree
- 1 -> liftA Single m
- 2 -> deepA one emptyTree one
- 3 -> deepA two emptyTree one
- 4 -> deepA two emptyTree two
- 5 -> deepA three emptyTree two
- 6 -> deepA three emptyTree three
- 7 -> deepA four emptyTree three
- 8 -> deepA four emptyTree four
- _ -> let (q, r) = n `quotRem` 3 in q `seq` case r of
- 0 -> deepA three (applicativeTree (q - 2) mSize' n3) three
- 1 -> deepA four (applicativeTree (q - 2) mSize' n3) three
- _ -> deepA four (applicativeTree (q - 2) mSize' n3) four
- where
- one = liftA One m
- two = liftA2 Two m m
- three = liftA3 Three m m m
- four = liftA3 Four m m m <*> m
- deepA = liftA3 (Deep (n * mSize))
- mSize' = 3 * mSize
- n3 = liftA3 (Node3 mSize') m m m
-
- emptyTree :: forall b. f (FingerTree b)
- emptyTree = pure Empty
-
-------------------------------------------------------------------------
--- Construction
-------------------------------------------------------------------------
-
--- | /O(1)/. The empty sequence.
-empty :: Seq a
-empty = Seq Empty
-
--- | /O(1)/. A singleton sequence.
-singleton :: a -> Seq a
-singleton x = Seq (Single (Elem x))
-
--- | /O(log n)/. @replicate n x@ is a sequence consisting of @n@ copies of @x@.
-replicate :: Int -> a -> Seq a
-replicate n x
- | n >= 0 = runId (replicateA n (Id x))
- | otherwise = error "replicate takes a nonnegative integer argument"
-
--- | 'replicateA' is an 'Applicative' version of 'replicate', and makes
--- /O(log n)/ calls to '<*>' and 'pure'.
---
--- > replicateA n x = sequenceA (replicate n x)
-replicateA :: Applicative f => Int -> f a -> f (Seq a)
-replicateA n x
- | n >= 0 = Seq <$> applicativeTree n 1 (Elem <$> x)
- | otherwise = error "replicateA takes a nonnegative integer argument"
-
--- | 'replicateM' is a sequence counterpart of 'Control.Monad.replicateM'.
---
--- > replicateM n x = sequence (replicate n x)
-replicateM :: Monad m => Int -> m a -> m (Seq a)
-replicateM n x
- | n >= 0 = unwrapMonad (replicateA n (WrapMonad x))
- | otherwise = error "replicateM takes a nonnegative integer argument"
-
--- | /O(1)/. Add an element to the left end of a sequence.
--- Mnemonic: a triangle with the single element at the pointy end.
-(<|) :: a -> Seq a -> Seq a
-x <| Seq xs = Seq (Elem x `consTree` xs)
-
-{-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}
-consTree :: Sized a => a -> FingerTree a -> FingerTree a
-consTree a Empty = Single a
-consTree a (Single b) = deep (One a) Empty (One b)
-consTree a (Deep s (Four b c d e) m sf) = m `seq`
- Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf
-consTree a (Deep s (Three b c d) m sf) =
- Deep (size a + s) (Four a b c d) m sf
-consTree a (Deep s (Two b c) m sf) =
- Deep (size a + s) (Three a b c) m sf
-consTree a (Deep s (One b) m sf) =
- Deep (size a + s) (Two a b) m sf
-
--- | /O(1)/. Add an element to the right end of a sequence.
--- Mnemonic: a triangle with the single element at the pointy end.
-(|>) :: Seq a -> a -> Seq a
-Seq xs |> x = Seq (xs `snocTree` Elem x)
-
-{-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}
-{-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}
-snocTree :: Sized a => FingerTree a -> a -> FingerTree a
-snocTree Empty a = Single a
-snocTree (Single a) b = deep (One a) Empty (One b)
-snocTree (Deep s pr m (Four a b c d)) e = m `seq`
- Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)
-snocTree (Deep s pr m (Three a b c)) d =
- Deep (s + size d) pr m (Four a b c d)
-snocTree (Deep s pr m (Two a b)) c =
- Deep (s + size c) pr m (Three a b c)
-snocTree (Deep s pr m (One a)) b =
- Deep (s + size b) pr m (Two a b)
-
--- | /O(log(min(n1,n2)))/. Concatenate two sequences.
-(><) :: Seq a -> Seq a -> Seq a
-Seq xs >< Seq ys = Seq (appendTree0 xs ys)
-
--- The appendTree/addDigits gunk below is machine generated
-
-appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)
-appendTree0 Empty xs =
- xs
-appendTree0 xs Empty =
- xs
-appendTree0 (Single x) xs =
- x `consTree` xs
-appendTree0 xs (Single x) =
- xs `snocTree` x
-appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =
- Deep (s1 + s2) pr1 (addDigits0 m1 sf1 pr2 m2) sf2
-
-addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))
-addDigits0 m1 (One a) (One b) m2 =
- appendTree1 m1 (node2 a b) m2
-addDigits0 m1 (One a) (Two b c) m2 =
- appendTree1 m1 (node3 a b c) m2
-addDigits0 m1 (One a) (Three b c d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits0 m1 (One a) (Four b c d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits0 m1 (Two a b) (One c) m2 =
- appendTree1 m1 (node3 a b c) m2
-addDigits0 m1 (Two a b) (Two c d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits0 m1 (Two a b) (Three c d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits0 m1 (Two a b) (Four c d e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits0 m1 (Three a b c) (One d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits0 m1 (Three a b c) (Two d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits0 m1 (Three a b c) (Three d e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits0 m1 (Three a b c) (Four d e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits0 m1 (Four a b c d) (One e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits0 m1 (Four a b c d) (Two e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits0 m1 (Four a b c d) (Three e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-
-appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
-appendTree1 Empty a xs =
- a `consTree` xs
-appendTree1 xs a Empty =
- xs `snocTree` a
-appendTree1 (Single x) a xs =
- x `consTree` a `consTree` xs
-appendTree1 xs a (Single x) =
- xs `snocTree` a `snocTree` x
-appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
- Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
-
-addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
-addDigits1 m1 (One a) b (One c) m2 =
- appendTree1 m1 (node3 a b c) m2
-addDigits1 m1 (One a) b (Two c d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits1 m1 (One a) b (Three c d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits1 m1 (One a) b (Four c d e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits1 m1 (Two a b) c (One d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits1 m1 (Two a b) c (Two d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits1 m1 (Two a b) c (Three d e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits1 m1 (Two a b) c (Four d e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits1 m1 (Three a b c) d (One e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits1 m1 (Three a b c) d (Two e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits1 m1 (Three a b c) d (Three e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits1 m1 (Four a b c d) e (One f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits1 m1 (Four a b c d) e (Two f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-
-appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
-appendTree2 Empty a b xs =
- a `consTree` b `consTree` xs
-appendTree2 xs a b Empty =
- xs `snocTree` a `snocTree` b
-appendTree2 (Single x) a b xs =
- x `consTree` a `consTree` b `consTree` xs
-appendTree2 xs a b (Single x) =
- xs `snocTree` a `snocTree` b `snocTree` x
-appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
- Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
-
-addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
-addDigits2 m1 (One a) b c (One d) m2 =
- appendTree2 m1 (node2 a b) (node2 c d) m2
-addDigits2 m1 (One a) b c (Two d e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits2 m1 (One a) b c (Three d e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits2 m1 (One a) b c (Four d e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits2 m1 (Two a b) c d (One e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits2 m1 (Two a b) c d (Two e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits2 m1 (Two a b) c d (Three e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits2 m1 (Three a b c) d e (One f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits2 m1 (Three a b c) d e (Two f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits2 m1 (Four a b c d) e f (One g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-
-appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
-appendTree3 Empty a b c xs =
- a `consTree` b `consTree` c `consTree` xs
-appendTree3 xs a b c Empty =
- xs `snocTree` a `snocTree` b `snocTree` c
-appendTree3 (Single x) a b c xs =
- x `consTree` a `consTree` b `consTree` c `consTree` xs
-appendTree3 xs a b c (Single x) =
- xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
-appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
- Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
-
-addDigits3 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
-addDigits3 m1 (One a) b c d (One e) m2 =
- appendTree2 m1 (node3 a b c) (node2 d e) m2
-addDigits3 m1 (One a) b c d (Two e f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits3 m1 (One a) b c d (Three e f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits3 m1 (One a) b c d (Four e f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits3 m1 (Two a b) c d e (One f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits3 m1 (Two a b) c d e (Two f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits3 m1 (Three a b c) d e f (One g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-addDigits3 m1 (Four a b c d) e f g (One h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
-
-appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
-appendTree4 Empty a b c d xs =
- a `consTree` b `consTree` c `consTree` d `consTree` xs
-appendTree4 xs a b c d Empty =
- xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
-appendTree4 (Single x) a b c d xs =
- x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
-appendTree4 xs a b c d (Single x) =
- xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
-appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
- Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
-
-addDigits4 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
-addDigits4 m1 (One a) b c d e (One f) m2 =
- appendTree2 m1 (node3 a b c) (node3 d e f) m2
-addDigits4 m1 (One a) b c d e (Two f g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits4 m1 (One a) b c d e (Three f g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits4 m1 (Two a b) c d e f (One g) m2 =
- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
-addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-addDigits4 m1 (Three a b c) d e f g (One h) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
-addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
-addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
-addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
-addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
-addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
-
--- | Builds a sequence from a seed value. Takes time linear in the
--- number of generated elements. /WARNING:/ If the number of generated
--- elements is infinite, this method will not terminate.
-unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a
-unfoldr f = unfoldr' empty
- -- uses tail recursion rather than, for instance, the List implementation.
- where unfoldr' as b = maybe as (\ (a, b') -> unfoldr' (as |> a) b') (f b)
-
--- | @'unfoldl' f x@ is equivalent to @'reverse' ('unfoldr' (swap . f) x)@.
-unfoldl :: (b -> Maybe (b, a)) -> b -> Seq a
-unfoldl f = unfoldl' empty
- where unfoldl' as b = maybe as (\ (b', a) -> unfoldl' (a <| as) b') (f b)
-
--- | /O(n)/. Constructs a sequence by repeated application of a function
--- to a seed value.
---
--- > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x))
-iterateN :: Int -> (a -> a) -> a -> Seq a
-iterateN n f x
- | n >= 0 = replicateA n (State (\ y -> (f y, y))) `execState` x
- | otherwise = error "iterateN takes a nonnegative integer argument"
-
-------------------------------------------------------------------------
--- Deconstruction
-------------------------------------------------------------------------
-
--- | /O(1)/. Is this the empty sequence?
-null :: Seq a -> Bool
-null (Seq Empty) = True
-null _ = False
-
--- | /O(1)/. The number of elements in the sequence.
-length :: Seq a -> Int
-length (Seq xs) = size xs
-
--- Views
-
-data Maybe2 a b = Nothing2 | Just2 a b
-
--- | View of the left end of a sequence.
-data ViewL a
- = EmptyL -- ^ empty sequence
- | a :< Seq a -- ^ leftmost element and the rest of the sequence
-#ifndef __HADDOCK__
-# if __GLASGOW_HASKELL__
- deriving (Eq, Ord, Show, Read, Data)
-# else
- deriving (Eq, Ord, Show, Read)
-# endif
-#else
-instance Eq a => Eq (ViewL a)
-instance Ord a => Ord (ViewL a)
-instance Show a => Show (ViewL a)
-instance Read a => Read (ViewL a)
-instance Data a => Data (ViewL a)
-#endif
-
-INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")
-
-instance Functor ViewL where
- fmap = fmapDefault
-
-instance Foldable ViewL where
- foldr _ z EmptyL = z
- foldr f z (x :< xs) = f x (foldr f z xs)
-
- foldl _ z EmptyL = z
- foldl f z (x :< xs) = foldl f (f z x) xs
-
- foldl1 _ EmptyL = error "foldl1: empty view"
- foldl1 f (x :< xs) = foldl f x xs
-
-instance Traversable ViewL where
- traverse _ EmptyL = pure EmptyL
- traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs
-
--- | /O(1)/. Analyse the left end of a sequence.
-viewl :: Seq a -> ViewL a
-viewl (Seq xs) = case viewLTree xs of
- Nothing2 -> EmptyL
- Just2 (Elem x) xs' -> x :< Seq xs'
-
-{-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> Maybe2 (Elem a) (FingerTree (Elem a)) #-}
-{-# SPECIALIZE viewLTree :: FingerTree (Node a) -> Maybe2 (Node a) (FingerTree (Node a)) #-}
-viewLTree :: Sized a => FingerTree a -> Maybe2 a (FingerTree a)
-viewLTree Empty = Nothing2
-viewLTree (Single a) = Just2 a Empty
-viewLTree (Deep s (One a) m sf) = Just2 a (pullL (s - size a) m sf)
-viewLTree (Deep s (Two a b) m sf) =
- Just2 a (Deep (s - size a) (One b) m sf)
-viewLTree (Deep s (Three a b c) m sf) =
- Just2 a (Deep (s - size a) (Two b c) m sf)
-viewLTree (Deep s (Four a b c d) m sf) =
- Just2 a (Deep (s - size a) (Three b c d) m sf)
-
--- | View of the right end of a sequence.
-data ViewR a
- = EmptyR -- ^ empty sequence
- | Seq a :> a -- ^ the sequence minus the rightmost element,
- -- and the rightmost element
-#ifndef __HADDOCK__
-# if __GLASGOW_HASKELL__
- deriving (Eq, Ord, Show, Read, Data)
-# else
- deriving (Eq, Ord, Show, Read)
-# endif
-#else
-instance Eq a => Eq (ViewR a)
-instance Ord a => Ord (ViewR a)
-instance Show a => Show (ViewR a)
-instance Read a => Read (ViewR a)
-instance Data a => Data (ViewR a)
-#endif
-
-INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")
-
-instance Functor ViewR where
- fmap = fmapDefault
-
-instance Foldable ViewR where
- foldr _ z EmptyR = z
- foldr f z (xs :> x) = foldr f (f x z) xs
-
- foldl _ z EmptyR = z
- foldl f z (xs :> x) = foldl f z xs `f` x
-
- foldr1 _ EmptyR = error "foldr1: empty view"
- foldr1 f (xs :> x) = foldr f x xs
-
-instance Traversable ViewR where
- traverse _ EmptyR = pure EmptyR
- traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x
-
--- | /O(1)/. Analyse the right end of a sequence.
-viewr :: Seq a -> ViewR a
-viewr (Seq xs) = case viewRTree xs of
- Nothing2 -> EmptyR
- Just2 xs' (Elem x) -> Seq xs' :> x
-
-{-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> Maybe2 (FingerTree (Elem a)) (Elem a) #-}
-{-# SPECIALIZE viewRTree :: FingerTree (Node a) -> Maybe2 (FingerTree (Node a)) (Node a) #-}
-viewRTree :: Sized a => FingerTree a -> Maybe2 (FingerTree a) a
-viewRTree Empty = Nothing2
-viewRTree (Single z) = Just2 Empty z
-viewRTree (Deep s pr m (One z)) = Just2 (pullR (s - size z) pr m) z
-viewRTree (Deep s pr m (Two y z)) =
- Just2 (Deep (s - size z) pr m (One y)) z
-viewRTree (Deep s pr m (Three x y z)) =
- Just2 (Deep (s - size z) pr m (Two x y)) z
-viewRTree (Deep s pr m (Four w x y z)) =
- Just2 (Deep (s - size z) pr m (Three w x y)) z
-
-------------------------------------------------------------------------
--- Scans
---
--- These are not particularly complex applications of the Traversable
--- functor, though making the correspondence with Data.List exact
--- requires the use of (<|) and (|>).
---
--- Note that save for the single (<|) or (|>), we maintain the original
--- structure of the Seq, not having to do any restructuring of our own.
---
--- wasserman.louis@gmail.com, 5/23/09
-------------------------------------------------------------------------
-
--- | 'scanl' is similar to 'foldl', but returns a sequence of reduced
--- values from the left:
---
--- > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...]
-scanl :: (a -> b -> a) -> a -> Seq b -> Seq a
-scanl f z0 xs = z0 <| snd (mapAccumL (\ x z -> let x' = f x z in (x', x')) z0 xs)
-
--- | 'scanl1' is a variant of 'scanl' that has no starting value argument:
---
--- > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...]
-scanl1 :: (a -> a -> a) -> Seq a -> Seq a
-scanl1 f xs = case viewl xs of
- EmptyL -> error "scanl1 takes a nonempty sequence as an argument"
- x :< xs' -> scanl f x xs'
-
--- | 'scanr' is the right-to-left dual of 'scanl'.
-scanr :: (a -> b -> b) -> b -> Seq a -> Seq b
-scanr f z0 xs = snd (mapAccumR (\ z x -> let z' = f x z in (z', z')) z0 xs) |> z0
-
--- | 'scanr1' is a variant of 'scanr' that has no starting value argument.
-scanr1 :: (a -> a -> a) -> Seq a -> Seq a
-scanr1 f xs = case viewr xs of
- EmptyR -> error "scanr1 takes a nonempty sequence as an argument"
- xs' :> x -> scanr f x xs'
-
--- Indexing
-
--- | /O(log(min(i,n-i)))/. The element at the specified position,
--- counting from 0. The argument should thus be a non-negative
--- integer less than the size of the sequence.
--- If the position is out of range, 'index' fails with an error.
-index :: Seq a -> Int -> a
-index (Seq xs) i
- | 0 <= i && i < size xs = case lookupTree i xs of
- Place _ (Elem x) -> x
- | otherwise = error "index out of bounds"
-
-data Place a = Place {-# UNPACK #-} !Int a
-#if TESTING
- deriving Show
-#endif
-
-{-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}
-{-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}
-lookupTree :: Sized a => Int -> FingerTree a -> Place a
-lookupTree _ Empty = error "lookupTree of empty tree"
-lookupTree i (Single x) = Place i x
-lookupTree i (Deep _ pr m sf)
- | i < spr = lookupDigit i pr
- | i < spm = case lookupTree (i - spr) m of
- Place i' xs -> lookupNode i' xs
- | otherwise = lookupDigit (i - spm) sf
- where spr = size pr
- spm = spr + size m
-
-{-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}
-{-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}
-lookupNode :: Sized a => Int -> Node a -> Place a
-lookupNode i (Node2 _ a b)
- | i < sa = Place i a
- | otherwise = Place (i - sa) b
- where sa = size a
-lookupNode i (Node3 _ a b c)
- | i < sa = Place i a
- | i < sab = Place (i - sa) b
- | otherwise = Place (i - sab) c
- where sa = size a
- sab = sa + size b
-
-{-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}
-{-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}
-lookupDigit :: Sized a => Int -> Digit a -> Place a
-lookupDigit i (One a) = Place i a
-lookupDigit i (Two a b)
- | i < sa = Place i a
- | otherwise = Place (i - sa) b
- where sa = size a
-lookupDigit i (Three a b c)
- | i < sa = Place i a
- | i < sab = Place (i - sa) b
- | otherwise = Place (i - sab) c
- where sa = size a
- sab = sa + size b
-lookupDigit i (Four a b c d)
- | i < sa = Place i a
- | i < sab = Place (i - sa) b
- | i < sabc = Place (i - sab) c
- | otherwise = Place (i - sabc) d
- where sa = size a
- sab = sa + size b
- sabc = sab + size c
-
--- | /O(log(min(i,n-i)))/. Replace the element at the specified position.
--- If the position is out of range, the original sequence is returned.
-update :: Int -> a -> Seq a -> Seq a
-update i x = adjust (const x) i
-
--- | /O(log(min(i,n-i)))/. Update the element at the specified position.
--- If the position is out of range, the original sequence is returned.
-adjust :: (a -> a) -> Int -> Seq a -> Seq a
-adjust f i (Seq xs)
- | 0 <= i && i < size xs = Seq (adjustTree (const (fmap f)) i xs)
- | otherwise = Seq xs
-
-{-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
-{-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}
-adjustTree :: Sized a => (Int -> a -> a) ->
- Int -> FingerTree a -> FingerTree a
-adjustTree _ _ Empty = error "adjustTree of empty tree"
-adjustTree f i (Single x) = Single (f i x)
-adjustTree f i (Deep s pr m sf)
- | i < spr = Deep s (adjustDigit f i pr) m sf
- | i < spm = Deep s pr (adjustTree (adjustNode f) (i - spr) m) sf
- | otherwise = Deep s pr m (adjustDigit f (i - spm) sf)
- where spr = size pr
- spm = spr + size m
-
-{-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}
-{-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}
-adjustNode :: Sized a => (Int -> a -> a) -> Int -> Node a -> Node a
-adjustNode f i (Node2 s a b)
- | i < sa = Node2 s (f i a) b
- | otherwise = Node2 s a (f (i - sa) b)
- where sa = size a
-adjustNode f i (Node3 s a b c)
- | i < sa = Node3 s (f i a) b c
- | i < sab = Node3 s a (f (i - sa) b) c
- | otherwise = Node3 s a b (f (i - sab) c)
- where sa = size a
- sab = sa + size b
-
-{-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}
-{-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}
-adjustDigit :: Sized a => (Int -> a -> a) -> Int -> Digit a -> Digit a
-adjustDigit f i (One a) = One (f i a)
-adjustDigit f i (Two a b)
- | i < sa = Two (f i a) b
- | otherwise = Two a (f (i - sa) b)
- where sa = size a
-adjustDigit f i (Three a b c)
- | i < sa = Three (f i a) b c
- | i < sab = Three a (f (i - sa) b) c
- | otherwise = Three a b (f (i - sab) c)
- where sa = size a
- sab = sa + size b
-adjustDigit f i (Four a b c d)
- | i < sa = Four (f i a) b c d
- | i < sab = Four a (f (i - sa) b) c d
- | i < sabc = Four a b (f (i - sab) c) d
- | otherwise = Four a b c (f (i- sabc) d)
- where sa = size a
- sab = sa + size b
- sabc = sab + size c
-
--- | A generalization of 'fmap', 'mapWithIndex' takes a mapping function
--- that also depends on the element's index, and applies it to every
--- element in the sequence.
-mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b
-mapWithIndex f xs = snd (mapAccumL' (\ i x -> (i + 1, f i x)) 0 xs)
-
--- Splitting
-
--- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.
--- If @i@ is negative, @'take' i s@ yields the empty sequence.
--- If the sequence contains fewer than @i@ elements, the whole sequence
--- is returned.
-take :: Int -> Seq a -> Seq a
-take i = fst . splitAt i
-
--- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@.
--- If @i@ is negative, @'drop' i s@ yields the whole sequence.
--- If the sequence contains fewer than @i@ elements, the empty sequence
--- is returned.
-drop :: Int -> Seq a -> Seq a
-drop i = snd . splitAt i
-
--- | /O(log(min(i,n-i)))/. Split a sequence at a given position.
--- @'splitAt' i s = ('take' i s, 'drop' i s)@.
-splitAt :: Int -> Seq a -> (Seq a, Seq a)
-splitAt i (Seq xs) = (Seq l, Seq r)
- where (l, r) = split i xs
-
-split :: Int -> FingerTree (Elem a) ->
- (FingerTree (Elem a), FingerTree (Elem a))
-split i Empty = i `seq` (Empty, Empty)
-split i xs
- | size xs > i = (l, consTree x r)
- | otherwise = (xs, Empty)
- where Split l x r = splitTree i xs
-
-data Split t a = Split t a t
-#if TESTING
- deriving Show
-#endif
-
-{-# SPECIALIZE splitTree :: Int -> FingerTree (Elem a) -> Split (FingerTree (Elem a)) (Elem a) #-}
-{-# SPECIALIZE splitTree :: Int -> FingerTree (Node a) -> Split (FingerTree (Node a)) (Node a) #-}
-splitTree :: Sized a => Int -> FingerTree a -> Split (FingerTree a) a
-splitTree _ Empty = error "splitTree of empty tree"
-splitTree i (Single x) = i `seq` Split Empty x Empty
-splitTree i (Deep _ pr m sf)
- | i < spr = case splitDigit i pr of
- Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)
- | i < spm = case splitTree im m of
- Split ml xs mr -> case splitNode (im - size ml) xs of
- Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)
- | otherwise = case splitDigit (i - spm) sf of
- Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)
- where spr = size pr
- spm = spr + size m
- im = i - spr
-
-{-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
-{-# SPECIALIZE splitNode :: Int -> Node (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
-splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a
-splitNode i (Node2 _ a b)
- | i < sa = Split Nothing a (Just (One b))
- | otherwise = Split (Just (One a)) b Nothing
- where sa = size a
-splitNode i (Node3 _ a b c)
- | i < sa = Split Nothing a (Just (Two b c))
- | i < sab = Split (Just (One a)) b (Just (One c))
- | otherwise = Split (Just (Two a b)) c Nothing
- where sa = size a
- sab = sa + size b
-
-{-# SPECIALIZE splitDigit :: Int -> Digit (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
-{-# SPECIALIZE splitDigit :: Int -> Digit (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
-splitDigit :: Sized a => Int -> Digit a -> Split (Maybe (Digit a)) a
-splitDigit i (One a) = i `seq` Split Nothing a Nothing
-splitDigit i (Two a b)
- | i < sa = Split Nothing a (Just (One b))
- | otherwise = Split (Just (One a)) b Nothing
- where sa = size a
-splitDigit i (Three a b c)
- | i < sa = Split Nothing a (Just (Two b c))
- | i < sab = Split (Just (One a)) b (Just (One c))
- | otherwise = Split (Just (Two a b)) c Nothing
- where sa = size a
- sab = sa + size b
-splitDigit i (Four a b c d)
- | i < sa = Split Nothing a (Just (Three b c d))
- | i < sab = Split (Just (One a)) b (Just (Two c d))
- | i < sabc = Split (Just (Two a b)) c (Just (One d))
- | otherwise = Split (Just (Three a b c)) d Nothing
- where sa = size a
- sab = sa + size b
- sabc = sab + size c
-
--- | /O(n)/. Returns a sequence of all suffixes of this sequence,
--- longest first. For example,
---
--- > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""]
---
--- Evaluating the /i/th suffix takes /O(log(min(i, n-i)))/, but evaluating
--- every suffix in the sequence takes /O(n)/ due to sharing.
-tails :: Seq a -> Seq (Seq a)
-tails (Seq xs) = Seq (tailsTree (Elem . Seq) xs) |> empty
-
--- | /O(n)/. Returns a sequence of all prefixes of this sequence,
--- shortest first. For example,
---
--- > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"]
---
--- Evaluating the /i/th prefix takes /O(log(min(i, n-i)))/, but evaluating
--- every prefix in the sequence takes /O(n)/ due to sharing.
-inits :: Seq a -> Seq (Seq a)
-inits (Seq xs) = empty <| Seq (initsTree (Elem . Seq) xs)
-
--- This implementation of tails (and, analogously, inits) has the
--- following algorithmic advantages:
--- Evaluating each tail in the sequence takes linear total time,
--- which is better than we could say for
--- @fromList [drop n xs | n <- [0..length xs]]@.
--- Evaluating any individual tail takes logarithmic time, which is
--- better than we can say for either
--- @scanr (<|) empty xs@ or @iterateN (length xs + 1) (\ xs -> let _ :< xs' = viewl xs in xs') xs@.
---
--- Moreover, if we actually look at every tail in the sequence, the
--- following benchmarks demonstrate that this implementation is modestly
--- faster than any of the above:
---
--- Times (ms)
--- min mean +/-sd median max
--- Seq.tails: 21.986 24.961 10.169 22.417 86.485
--- scanr: 85.392 87.942 2.488 87.425 100.217
--- iterateN: 29.952 31.245 1.574 30.412 37.268
---
--- The algorithm for tails (and, analogously, inits) is as follows:
---
--- A Node in the FingerTree of tails is constructed by evaluating the
--- corresponding tail of the FingerTree of Nodes, considering the first
--- Node in this tail, and constructing a Node in which each tail of this
--- Node is made to be the prefix of the remaining tree. This ends up
--- working quite elegantly, as the remainder of the tail of the FingerTree
--- of Nodes becomes the middle of a new tail, the suffix of the Node is
--- the prefix, and the suffix of the original tree is retained.
---
--- In particular, evaluating the /i/th tail involves making as
--- many partial evaluations as the Node depth of the /i/th element.
--- In addition, when we evaluate the /i/th tail, and we also evaluate
--- the /j/th tail, and /m/ Nodes are on the path to both /i/ and /j/,
--- each of those /m/ evaluations are shared between the computation of
--- the /i/th and /j/th tails.
---
--- wasserman.louis@gmail.com, 7/16/09
-
-tailsDigit :: Digit a -> Digit (Digit a)
-tailsDigit (One a) = One (One a)
-tailsDigit (Two a b) = Two (Two a b) (One b)
-tailsDigit (Three a b c) = Three (Three a b c) (Two b c) (One c)
-tailsDigit (Four a b c d) = Four (Four a b c d) (Three b c d) (Two c d) (One d)
-
-initsDigit :: Digit a -> Digit (Digit a)
-initsDigit (One a) = One (One a)
-initsDigit (Two a b) = Two (One a) (Two a b)
-initsDigit (Three a b c) = Three (One a) (Two a b) (Three a b c)
-initsDigit (Four a b c d) = Four (One a) (Two a b) (Three a b c) (Four a b c d)
-
-tailsNode :: Node a -> Node (Digit a)
-tailsNode (Node2 s a b) = Node2 s (Two a b) (One b)
-tailsNode (Node3 s a b c) = Node3 s (Three a b c) (Two b c) (One c)
-
-initsNode :: Node a -> Node (Digit a)
-initsNode (Node2 s a b) = Node2 s (One a) (Two a b)
-initsNode (Node3 s a b c) = Node3 s (One a) (Two a b) (Three a b c)
-
-{-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
-{-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
--- | Given a function to apply to tails of a tree, applies that function
--- to every tail of the specified tree.
-tailsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
-tailsTree _ Empty = Empty
-tailsTree f (Single x) = Single (f (Single x))
-tailsTree f (Deep n pr m sf) =
- Deep n (fmap (\ pr' -> f (deep pr' m sf)) (tailsDigit pr))
- (tailsTree f' m)
- (fmap (f . digitToTree) (tailsDigit sf))
- where f' ms = let Just2 node m' = viewLTree ms in
- fmap (\ pr' -> f (deep pr' m' sf)) (tailsNode node)
-
-{-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
-{-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
--- | Given a function to apply to inits of a tree, applies that function
--- to every init of the specified tree.
-initsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
-initsTree _ Empty = Empty
-initsTree f (Single x) = Single (f (Single x))
-initsTree f (Deep n pr m sf) =
- Deep n (fmap (f . digitToTree) (initsDigit pr))
- (initsTree f' m)
- (fmap (f . deep pr m) (initsDigit sf))
- where f' ms = let Just2 m' node = viewRTree ms in
- fmap (\ sf' -> f (deep pr m' sf')) (initsNode node)
-
-{-# INLINE foldlWithIndex #-}
--- | 'foldlWithIndex' is a version of 'foldl' that also provides access
--- to the index of each element.
-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
-foldlWithIndex f z xs = foldl (\ g x i -> i `seq` f (g (i - 1)) i x) (const z) xs (length xs - 1)
-
-{-# INLINE foldrWithIndex #-}
--- | 'foldrWithIndex' is a version of 'foldr' that also provides access
--- to the index of each element.
-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
-foldrWithIndex f z xs = foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0
-
-{-# INLINE listToMaybe' #-}
--- 'listToMaybe\'' is a good consumer version of 'listToMaybe'.
-listToMaybe' :: [a] -> Maybe a
-listToMaybe' = foldr (\ x _ -> Just x) Nothing
-
--- | /O(i)/ where /i/ is the prefix length. 'takeWhileL', applied
--- to a predicate @p@ and a sequence @xs@, returns the longest prefix
--- (possibly empty) of @xs@ of elements that satisfy @p@.
-takeWhileL :: (a -> Bool) -> Seq a -> Seq a
-takeWhileL p = fst . spanl p
-
--- | /O(i)/ where /i/ is the suffix length. 'takeWhileR', applied
--- to a predicate @p@ and a sequence @xs@, returns the longest suffix
--- (possibly empty) of @xs@ of elements that satisfy @p@.
---
--- @'takeWhileR' p xs@ is equivalent to @'reverse' ('takeWhileL' p ('reverse' xs))@.
-takeWhileR :: (a -> Bool) -> Seq a -> Seq a
-takeWhileR p = fst . spanr p
-
--- | /O(i)/ where /i/ is the prefix length. @'dropWhileL' p xs@ returns
--- the suffix remaining after @'takeWhileL' p xs@.
-dropWhileL :: (a -> Bool) -> Seq a -> Seq a
-dropWhileL p = snd . spanl p
-
--- | /O(i)/ where /i/ is the suffix length. @'dropWhileR' p xs@ returns
--- the prefix remaining after @'takeWhileR' p xs@.
---
--- @'dropWhileR' p xs@ is equivalent to @'reverse' ('dropWhileL' p ('reverse' xs))@.
-dropWhileR :: (a -> Bool) -> Seq a -> Seq a
-dropWhileR p = snd . spanr p
-
--- | /O(i)/ where /i/ is the prefix length. 'spanl', applied to
--- a predicate @p@ and a sequence @xs@, returns a pair whose first
--- element is the longest prefix (possibly empty) of @xs@ of elements that
--- satisfy @p@ and the second element is the remainder of the sequence.
-spanl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
-spanl p = breakl (not . p)
-
--- | /O(i)/ where /i/ is the suffix length. 'spanr', applied to a
--- predicate @p@ and a sequence @xs@, returns a pair whose /first/ element
--- is the longest /suffix/ (possibly empty) of @xs@ of elements that
--- satisfy @p@ and the second element is the remainder of the sequence.
-spanr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
-spanr p = breakr (not . p)
-
-{-# INLINE breakl #-}
--- | /O(i)/ where /i/ is the breakpoint index. 'breakl', applied to a
--- predicate @p@ and a sequence @xs@, returns a pair whose first element
--- is the longest prefix (possibly empty) of @xs@ of elements that
--- /do not satisfy/ @p@ and the second element is the remainder of
--- the sequence.
---
--- @'breakl' p@ is equivalent to @'spanl' (not . p)@.
-breakl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
-breakl p xs = foldr (\ i _ -> splitAt i xs) (xs, empty) (findIndicesL p xs)
-
-{-# INLINE breakr #-}
--- | @'breakr' p@ is equivalent to @'spanr' (not . p)@.
-breakr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
-breakr p xs = foldr (\ i _ -> flipPair (splitAt (i + 1) xs)) (xs, empty) (findIndicesR p xs)
- where flipPair (x, y) = (y, x)
-
--- | /O(n)/. The 'partition' function takes a predicate @p@ and a
--- sequence @xs@ and returns sequences of those elements which do and
--- do not satisfy the predicate.
-partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
-partition p = foldl part (empty, empty)
- where part (xs, ys) x
- | p x = (xs |> x, ys)
- | otherwise = (xs, ys |> x)
-
--- | /O(n)/. The 'filter' function takes a predicate @p@ and a sequence
--- @xs@ and returns a sequence of those elements which satisfy the
--- predicate.
-filter :: (a -> Bool) -> Seq a -> Seq a
-filter p = foldl (\ xs x -> if p x then xs |> x else xs) empty
-
--- Indexing sequences
-
--- | 'elemIndexL' finds the leftmost index of the specified element,
--- if it is present, and otherwise 'Nothing'.
-elemIndexL :: Eq a => a -> Seq a -> Maybe Int
-elemIndexL x = findIndexL (x ==)
-
--- | 'elemIndexR' finds the rightmost index of the specified element,
--- if it is present, and otherwise 'Nothing'.
-elemIndexR :: Eq a => a -> Seq a -> Maybe Int
-elemIndexR x = findIndexR (x ==)
-
--- | 'elemIndicesL' finds the indices of the specified element, from
--- left to right (i.e. in ascending order).
-elemIndicesL :: Eq a => a -> Seq a -> [Int]
-elemIndicesL x = findIndicesL (x ==)
-
--- | 'elemIndicesR' finds the indices of the specified element, from
--- right to left (i.e. in descending order).
-elemIndicesR :: Eq a => a -> Seq a -> [Int]
-elemIndicesR x = findIndicesR (x ==)
-
--- | @'findIndexL' p xs@ finds the index of the leftmost element that
--- satisfies @p@, if any exist.
-findIndexL :: (a -> Bool) -> Seq a -> Maybe Int
-findIndexL p = listToMaybe' . findIndicesL p
-
--- | @'findIndexR' p xs@ finds the index of the rightmost element that
--- satisfies @p@, if any exist.
-findIndexR :: (a -> Bool) -> Seq a -> Maybe Int
-findIndexR p = listToMaybe' . findIndicesR p
-
-{-# INLINE findIndicesL #-}
--- | @'findIndicesL' p@ finds all indices of elements that satisfy @p@,
--- in ascending order.
-findIndicesL :: (a -> Bool) -> Seq a -> [Int]
-#if __GLASGOW_HASKELL__
-findIndicesL p xs = build (\ c n -> let g i x z = if p x then c i z else z in
- foldrWithIndex g n xs)
-#else
-findIndicesL p xs = foldrWithIndex g [] xs
- where g i x is = if p x then i:is else is
-#endif
-
-{-# INLINE findIndicesR #-}
--- | @'findIndicesR' p@ finds all indices of elements that satisfy @p@,
--- in descending order.
-findIndicesR :: (a -> Bool) -> Seq a -> [Int]
-#if __GLASGOW_HASKELL__
-findIndicesR p xs = build (\ c n -> let g z i x = if p x then c i z else z in
- foldlWithIndex g n xs)
-#else
-findIndicesR p xs = foldlWithIndex g [] xs
- where g is i x = if p x then i:is else is
-#endif
-
-------------------------------------------------------------------------
--- Lists
-------------------------------------------------------------------------
-
--- | /O(n)/. Create a sequence from a finite list of elements.
--- There is a function 'toList' in the opposite direction for all
--- instances of the 'Foldable' class, including 'Seq'.
-fromList :: [a] -> Seq a
-fromList = Data.List.foldl' (|>) empty
-
-------------------------------------------------------------------------
--- Reverse
-------------------------------------------------------------------------
-
--- | /O(n)/. The reverse of a sequence.
-reverse :: Seq a -> Seq a
-reverse (Seq xs) = Seq (reverseTree id xs)
-
-reverseTree :: (a -> a) -> FingerTree a -> FingerTree a
-reverseTree _ Empty = Empty
-reverseTree f (Single x) = Single (f x)
-reverseTree f (Deep s pr m sf) =
- Deep s (reverseDigit f sf)
- (reverseTree (reverseNode f) m)
- (reverseDigit f pr)
-
-{-# INLINE reverseDigit #-}
-reverseDigit :: (a -> a) -> Digit a -> Digit a
-reverseDigit f (One a) = One (f a)
-reverseDigit f (Two a b) = Two (f b) (f a)
-reverseDigit f (Three a b c) = Three (f c) (f b) (f a)
-reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)
-
-reverseNode :: (a -> a) -> Node a -> Node a
-reverseNode f (Node2 s a b) = Node2 s (f b) (f a)
-reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)
-
-------------------------------------------------------------------------
--- Zipping
-------------------------------------------------------------------------
-
--- | /O(min(n1,n2))/. 'zip' takes two sequences and returns a sequence
--- of corresponding pairs. If one input is short, excess elements are
--- discarded from the right end of the longer sequence.
-zip :: Seq a -> Seq b -> Seq (a, b)
-zip = zipWith (,)
-
--- | /O(min(n1,n2))/. 'zipWith' generalizes 'zip' by zipping with the
--- function given as the first argument, instead of a tupling function.
--- For example, @zipWith (+)@ is applied to two sequences to take the
--- sequence of corresponding sums.
-zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
-zipWith f xs ys
- | length xs <= length ys = zipWith' f xs ys
- | otherwise = zipWith' (flip f) ys xs
-
--- like 'zipWith', but assumes length xs <= length ys
-zipWith' :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
-zipWith' f xs ys = snd (mapAccumL k ys xs)
- where
- k kys x = case viewl kys of
- (z :< zs) -> (zs, f x z)
- EmptyL -> error "zipWith': unexpected EmptyL"
-
--- | /O(min(n1,n2,n3))/. 'zip3' takes three sequences and returns a
--- sequence of triples, analogous to 'zip'.
-zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
-zip3 = zipWith3 (,,)
-
--- | /O(min(n1,n2,n3))/. 'zipWith3' takes a function which combines
--- three elements, as well as three sequences and returns a sequence of
--- their point-wise combinations, analogous to 'zipWith'.
-zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
-zipWith3 f s1 s2 s3 = zipWith ($) (zipWith f s1 s2) s3
-
--- | /O(min(n1,n2,n3,n4))/. 'zip4' takes four sequences and returns a
--- sequence of quadruples, analogous to 'zip'.
-zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d)
-zip4 = zipWith4 (,,,)
-
--- | /O(min(n1,n2,n3,n4))/. 'zipWith4' takes a function which combines
--- four elements, as well as four sequences and returns a sequence of
--- their point-wise combinations, analogous to 'zipWith'.
-zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
-zipWith4 f s1 s2 s3 s4 = zipWith ($) (zipWith ($) (zipWith f s1 s2) s3) s4
-
-------------------------------------------------------------------------
--- Sorting
---
--- sort and sortBy are implemented by simple deforestations of
--- \ xs -> fromList2 (length xs) . Data.List.sortBy cmp . toList
--- which does not get deforested automatically, it would appear.
---
--- Unstable sorting is performed by a heap sort implementation based on
--- pairing heaps. Because the internal structure of sequences is quite
--- varied, it is difficult to get blocks of elements of roughly the same
--- length, which would improve merge sort performance. Pairing heaps,
--- on the other hand, are relatively resistant to the effects of merging
--- heaps of wildly different sizes, as guaranteed by its amortized
--- constant-time merge operation. Moreover, extensive use of SpecConstr
--- transformations can be done on pairing heaps, especially when we're
--- only constructing them to immediately be unrolled.
---
--- On purely random sequences of length 50000, with no RTS options,
--- I get the following statistics, in which heapsort is about 42.5%
--- faster: (all comparisons done with -O2)
---
--- Times (ms) min mean +/-sd median max
--- to/from list: 103.802 108.572 7.487 106.436 143.339
--- unstable heapsort: 60.686 62.968 4.275 61.187 79.151
---
--- Heapsort, it would seem, is less of a memory hog than Data.List.sortBy.
--- The gap is narrowed when more memory is available, but heapsort still
--- wins, 15% faster, with +RTS -H128m:
---
--- Times (ms) min mean +/-sd median max
--- to/from list: 42.692 45.074 2.596 44.600 56.601
--- unstable heapsort: 37.100 38.344 3.043 37.715 55.526
---
--- In addition, on strictly increasing sequences the gap is even wider
--- than normal; heapsort is 68.5% faster with no RTS options:
--- Times (ms) min mean +/-sd median max
--- to/from list: 52.236 53.574 1.987 53.034 62.098
--- unstable heapsort: 16.433 16.919 0.931 16.681 21.622
---
--- This may be attributed to the elegant nature of the pairing heap.
---
--- wasserman.louis@gmail.com, 7/20/09
-------------------------------------------------------------------------
-
--- | /O(n log n)/. 'sort' sorts the specified 'Seq' by the natural
--- ordering of its elements. The sort is stable.
--- If stability is not required, 'unstableSort' can be considerably
--- faster, and in particular uses less memory.
-sort :: Ord a => Seq a -> Seq a
-sort = sortBy compare
-
--- | /O(n log n)/. 'sortBy' sorts the specified 'Seq' according to the
--- specified comparator. The sort is stable.
--- If stability is not required, 'unstableSortBy' can be considerably
--- faster, and in particular uses less memory.
-sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
-sortBy cmp xs = fromList2 (length xs) (Data.List.sortBy cmp (toList xs))
-
--- | /O(n log n)/. 'unstableSort' sorts the specified 'Seq' by
--- the natural ordering of its elements, but the sort is not stable.
--- This algorithm is frequently faster and uses less memory than 'sort',
--- and performs extremely well -- frequently twice as fast as 'sort' --
--- when the sequence is already nearly sorted.
-unstableSort :: Ord a => Seq a -> Seq a
-unstableSort = unstableSortBy compare
-
--- | /O(n log n)/. A generalization of 'unstableSort', 'unstableSortBy'
--- takes an arbitrary comparator and sorts the specified sequence.
--- The sort is not stable. This algorithm is frequently faster and
--- uses less memory than 'sortBy', and performs extremely well --
--- frequently twice as fast as 'sortBy' -- when the sequence is already
--- nearly sorted.
-unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
-unstableSortBy cmp (Seq xs) =
- fromList2 (size xs) $ maybe [] (unrollPQ cmp) $
- toPQ cmp (\ (Elem x) -> PQueue x Nil) xs
-
--- | fromList2, given a list and its length, constructs a completely
--- balanced Seq whose elements are that list using the applicativeTree
--- generalization.
-fromList2 :: Int -> [a] -> Seq a
-fromList2 n = execState (replicateA n (State ht))
- where
- ht (x:xs) = (xs, x)
- ht [] = error "fromList2: short list"
-
--- | A 'PQueue' is a simple pairing heap.
-data PQueue e = PQueue e (PQL e)
-data PQL e = Nil | {-# UNPACK #-} !(PQueue e) :& PQL e
-
-infixr 8 :&
-
-#if TESTING
-
-instance Functor PQueue where
- fmap f (PQueue x ts) = PQueue (f x) (fmap f ts)
-
-instance Functor PQL where
- fmap f (q :& qs) = fmap f q :& fmap f qs
- fmap _ Nil = Nil
-
-instance Show e => Show (PQueue e) where
- show = unlines . draw . fmap show
-
--- borrowed wholesale from Data.Tree, as Data.Tree actually depends
--- on Data.Sequence
-draw :: PQueue String -> [String]
-draw (PQueue x ts0) = x : drawSubTrees ts0
- where drawSubTrees Nil = []
- drawSubTrees (t :& Nil) =
- "|" : shift "`- " " " (draw t)
- drawSubTrees (t :& ts) =
- "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts
-
- shift first other = Data.List.zipWith (++) (first : repeat other)
-#endif
-
--- | 'unrollPQ', given a comparator function, unrolls a 'PQueue' into
--- a sorted list.
-unrollPQ :: (e -> e -> Ordering) -> PQueue e -> [e]
-unrollPQ cmp = unrollPQ'
- where
- {-# INLINE unrollPQ' #-}
- unrollPQ' (PQueue x ts) = x:mergePQs0 ts
- (<>) = mergePQ cmp
- mergePQs0 Nil = []
- mergePQs0 (t :& Nil) = unrollPQ' t
- mergePQs0 (t1 :& t2 :& ts) = mergePQs (t1 <> t2) ts
- mergePQs t ts = t `seq` case ts of
- Nil -> unrollPQ' t
- t1 :& Nil -> unrollPQ' (t <> t1)
- t1 :& t2 :& ts' -> mergePQs (t <> (t1 <> t2)) ts'
-
--- | 'toPQ', given an ordering function and a mechanism for queueifying
--- elements, converts a 'FingerTree' to a 'PQueue'.
-toPQ :: (e -> e -> Ordering) -> (a -> PQueue e) -> FingerTree a -> Maybe (PQueue e)
-toPQ _ _ Empty = Nothing
-toPQ _ f (Single x) = Just (f x)
-toPQ cmp f (Deep _ pr m sf) = Just (maybe (pr' <> sf') ((pr' <> sf') <>) (toPQ cmp fNode m))
- where
- fDigit digit = case fmap f digit of
- One a -> a
- Two a b -> a <> b
- Three a b c -> a <> b <> c
- Four a b c d -> (a <> b) <> (c <> d)
- (<>) = mergePQ cmp
- fNode = fDigit . nodeToDigit
- pr' = fDigit pr
- sf' = fDigit sf
-
--- | 'mergePQ' merges two 'PQueue's.
-mergePQ :: (a -> a -> Ordering) -> PQueue a -> PQueue a -> PQueue a
-mergePQ cmp q1@(PQueue x1 ts1) q2@(PQueue x2 ts2)
- | cmp x1 x2 == GT = PQueue x2 (q1 :& ts2)
- | otherwise = PQueue x1 (q2 :& ts1)
-
-#if TESTING
-
-------------------------------------------------------------------------
--- QuickCheck
-------------------------------------------------------------------------
-
-instance Arbitrary a => Arbitrary (Seq a) where
- arbitrary = liftM Seq arbitrary
- shrink (Seq x) = map Seq (shrink x)
-
-instance Arbitrary a => Arbitrary (Elem a) where
- arbitrary = liftM Elem arbitrary
-
-instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where
- arbitrary = sized arb
- where arb :: (Arbitrary a, Sized a) => Int -> Gen (FingerTree a)
- arb 0 = return Empty
- arb 1 = liftM Single arbitrary
- arb n = liftM3 deep arbitrary (arb (n `div` 2)) arbitrary
-
- shrink (Deep _ (One a) Empty (One b)) = [Single a, Single b]
- shrink (Deep _ pr m sf) =
- [deep pr' m sf | pr' <- shrink pr] ++
- [deep pr m' sf | m' <- shrink m] ++
- [deep pr m sf' | sf' <- shrink sf]
- shrink (Single x) = map Single (shrink x)
- shrink Empty = []
-
-instance (Arbitrary a, Sized a) => Arbitrary (Node a) where
- arbitrary = oneof [
- liftM2 node2 arbitrary arbitrary,
- liftM3 node3 arbitrary arbitrary arbitrary]
-
- shrink (Node2 _ a b) =
- [node2 a' b | a' <- shrink a] ++
- [node2 a b' | b' <- shrink b]
- shrink (Node3 _ a b c) =
- [node2 a b, node2 a c, node2 b c] ++
- [node3 a' b c | a' <- shrink a] ++
- [node3 a b' c | b' <- shrink b] ++
- [node3 a b c' | c' <- shrink c]
-
-instance Arbitrary a => Arbitrary (Digit a) where
- arbitrary = oneof [
- liftM One arbitrary,
- liftM2 Two arbitrary arbitrary,
- liftM3 Three arbitrary arbitrary arbitrary,
- liftM4 Four arbitrary arbitrary arbitrary arbitrary]
-
- shrink (One a) = map One (shrink a)
- shrink (Two a b) = [One a, One b]
- shrink (Three a b c) = [Two a b, Two a c, Two b c]
- shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d]
-
-------------------------------------------------------------------------
--- Valid trees
-------------------------------------------------------------------------
-
-class Valid a where
- valid :: a -> Bool
-
-instance Valid (Elem a) where
- valid _ = True
-
-instance Valid (Seq a) where
- valid (Seq xs) = valid xs
-
-instance (Sized a, Valid a) => Valid (FingerTree a) where
- valid Empty = True
- valid (Single x) = valid x
- valid (Deep s pr m sf) =
- s == size pr + size m + size sf && valid pr && valid m && valid sf
-
-instance (Sized a, Valid a) => Valid (Node a) where
- valid node = size node == sum (fmap size node) && all valid node
-
-instance Valid a => Valid (Digit a) where
- valid = all valid
+{-# LANGUAGE CPP, DeriveDataTypeable #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Sequence
+-- Copyright : (c) Ross Paterson 2005
+-- (c) Louis Wasserman 2009
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- General purpose finite sequences.
+-- Apart from being finite and having strict operations, sequences
+-- also differ from lists in supporting a wider variety of operations
+-- efficiently.
+--
+-- An amortized running time is given for each operation, with /n/ referring
+-- to the length of the sequence and /i/ being the integral index used by
+-- some operations. These bounds hold even in a persistent (shared) setting.
+--
+-- The implementation uses 2-3 finger trees annotated with sizes,
+-- as described in section 4.2 of
+--
+-- * Ralf Hinze and Ross Paterson,
+-- \"Finger trees: a simple general-purpose data structure\",
+-- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
+--
+--
+-- /Note/: Many of these operations have the same names as similar
+-- operations on lists in the "Prelude". The ambiguity may be resolved
+-- using either qualification or the @hiding@ clause.
+--
+-----------------------------------------------------------------------------
+
+module Data.Sequence (
+ Seq,
+ -- * Construction
+ empty, -- :: Seq a
+ singleton, -- :: a -> Seq a
+ (<|), -- :: a -> Seq a -> Seq a
+ (|>), -- :: Seq a -> a -> Seq a
+ (><), -- :: Seq a -> Seq a -> Seq a
+ fromList, -- :: [a] -> Seq a
+ -- ** Repetition
+ replicate, -- :: Int -> a -> Seq a
+ replicateA, -- :: Applicative f => Int -> f a -> f (Seq a)
+ replicateM, -- :: Monad m => Int -> m a -> m (Seq a)
+ -- ** Iterative construction
+ iterateN, -- :: Int -> (a -> a) -> a -> Seq a
+ unfoldr, -- :: (b -> Maybe (a, b)) -> b -> Seq a
+ unfoldl, -- :: (b -> Maybe (b, a)) -> b -> Seq a
+ -- * Deconstruction
+ -- | Additional functions for deconstructing sequences are available
+ -- via the 'Foldable' instance of 'Seq'.
+
+ -- ** Queries
+ null, -- :: Seq a -> Bool
+ length, -- :: Seq a -> Int
+ -- ** Views
+ ViewL(..),
+ viewl, -- :: Seq a -> ViewL a
+ ViewR(..),
+ viewr, -- :: Seq a -> ViewR a
+ -- * Scans
+ scanl, -- :: (a -> b -> a) -> a -> Seq b -> Seq a
+ scanl1, -- :: (a -> a -> a) -> Seq a -> Seq a
+ scanr, -- :: (a -> b -> b) -> b -> Seq a -> Seq b
+ scanr1, -- :: (a -> a -> a) -> Seq a -> Seq a
+ -- * Sublists
+ tails, -- :: Seq a -> Seq (Seq a)
+ inits, -- :: Seq a -> Seq (Seq a)
+ -- ** Sequential searches
+ takeWhileL, -- :: (a -> Bool) -> Seq a -> Seq a
+ takeWhileR, -- :: (a -> Bool) -> Seq a -> Seq a
+ dropWhileL, -- :: (a -> Bool) -> Seq a -> Seq a
+ dropWhileR, -- :: (a -> Bool) -> Seq a -> Seq a
+ spanl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+ spanr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+ breakl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+ breakr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+ partition, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+ filter, -- :: (a -> Bool) -> Seq a -> Seq a
+ -- * Sorting
+ sort, -- :: Ord a => Seq a -> Seq a
+ sortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
+ unstableSort, -- :: Ord a => Seq a -> Seq a
+ unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
+ -- * Indexing
+ index, -- :: Seq a -> Int -> a
+ adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a
+ update, -- :: Int -> a -> Seq a -> Seq a
+ take, -- :: Int -> Seq a -> Seq a
+ drop, -- :: Int -> Seq a -> Seq a
+ splitAt, -- :: Int -> Seq a -> (Seq a, Seq a)
+ -- ** Indexing with predicates
+ -- | These functions perform sequential searches from the left
+ -- or right ends of the sequence, returning indices of matching
+ -- elements.
+ elemIndexL, -- :: Eq a => a -> Seq a -> Maybe Int
+ elemIndicesL, -- :: Eq a => a -> Seq a -> [Int]
+ elemIndexR, -- :: Eq a => a -> Seq a -> Maybe Int
+ elemIndicesR, -- :: Eq a => a -> Seq a -> [Int]
+ findIndexL, -- :: (a -> Bool) -> Seq a -> Maybe Int
+ findIndicesL, -- :: (a -> Bool) -> Seq a -> [Int]
+ findIndexR, -- :: (a -> Bool) -> Seq a -> Maybe Int
+ findIndicesR, -- :: (a -> Bool) -> Seq a -> [Int]
+ -- * Folds
+ -- | General folds are available via the 'Foldable' instance of 'Seq'.
+ foldlWithIndex, -- :: (b -> Int -> a -> b) -> b -> Seq a -> b
+ foldrWithIndex, -- :: (Int -> a -> b -> b) -> b -> Seq a -> b
+ -- * Transformations
+ mapWithIndex, -- :: (Int -> a -> b) -> Seq a -> Seq b
+ reverse, -- :: Seq a -> Seq a
+ -- ** Zips
+ zip, -- :: Seq a -> Seq b -> Seq (a, b)
+ zipWith, -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
+ zip3, -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)
+ zipWith3, -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
+ zip4, -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)
+ zipWith4, -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
+#if TESTING
+ valid,
+#endif
+ ) where
+
+import Prelude hiding (
+ Functor(..),
+ null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
+ scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,
+ takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)
+import qualified Data.List (foldl', sortBy)
+import Control.Applicative (Applicative(..), (<$>), WrappedMonad(..), liftA, liftA2, liftA3)
+import Control.Monad (MonadPlus(..), ap)
+import Data.Monoid (Monoid(..))
+import Data.Functor (Functor(..))
+import Data.Foldable
+import Data.Traversable
+import Data.Typeable
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Exts (build)
+import Text.Read (Lexeme(Ident), lexP, parens, prec,
+ readPrec, readListPrec, readListPrecDefault)
+import Data.Data
+#endif
+
+#if TESTING
+import qualified Data.List (zipWith)
+import Test.QuickCheck hiding ((><))
+#endif
+
+infixr 5 `consTree`
+infixl 5 `snocTree`
+
+infixr 5 ><
+infixr 5 <|, :<
+infixl 5 |>, :>
+
+class Sized a where
+ size :: a -> Int
+
+-- | General-purpose finite sequences.
+newtype Seq a = Seq (FingerTree (Elem a))
+
+instance Functor Seq where
+ fmap f (Seq xs) = Seq (fmap (fmap f) xs)
+#ifdef __GLASGOW_HASKELL__
+ x <$ s = replicate (length s) x
+#endif
+
+instance Foldable Seq where
+ foldr f z (Seq xs) = foldr (flip (foldr f)) z xs
+ foldl f z (Seq xs) = foldl (foldl f) z xs
+
+ foldr1 f (Seq xs) = getElem (foldr1 f' xs)
+ where f' (Elem x) (Elem y) = Elem (f x y)
+
+ foldl1 f (Seq xs) = getElem (foldl1 f' xs)
+ where f' (Elem x) (Elem y) = Elem (f x y)
+
+instance Traversable Seq where
+ traverse f (Seq xs) = Seq <$> traverse (traverse f) xs
+
+instance Monad Seq where
+ return = singleton
+ xs >>= f = foldl' add empty xs
+ where add ys x = ys >< f x
+
+instance MonadPlus Seq where
+ mzero = empty
+ mplus = (><)
+
+instance Eq a => Eq (Seq a) where
+ xs == ys = length xs == length ys && toList xs == toList ys
+
+instance Ord a => Ord (Seq a) where
+ compare xs ys = compare (toList xs) (toList ys)
+
+#if TESTING
+instance Show a => Show (Seq a) where
+ showsPrec p (Seq x) = showsPrec p x
+#else
+instance Show a => Show (Seq a) where
+ showsPrec p xs = showParen (p > 10) $
+ showString "fromList " . shows (toList xs)
+#endif
+
+instance Read a => Read (Seq a) where
+#ifdef __GLASGOW_HASKELL__
+ readPrec = parens $ prec 10 $ do
+ Ident "fromList" <- lexP
+ xs <- readPrec
+ return (fromList xs)
+
+ readListPrec = readListPrecDefault
+#else
+ readsPrec p = readParen (p > 10) $ \ r -> do
+ ("fromList",s) <- lex r
+ (xs,t) <- reads s
+ return (fromList xs,t)
+#endif
+
+instance Monoid (Seq a) where
+ mempty = empty
+ mappend = (><)
+
+#include "Typeable.h"
+INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")
+
+#if __GLASGOW_HASKELL__
+instance Data a => Data (Seq a) where
+ gfoldl f z s = case viewl s of
+ EmptyL -> z empty
+ x :< xs -> z (<|) `f` x `f` xs
+
+ gunfold k z c = case constrIndex c of
+ 1 -> z empty
+ 2 -> k (k (z (<|)))
+ _ -> error "gunfold"
+
+ toConstr xs
+ | null xs = emptyConstr
+ | otherwise = consConstr
+
+ dataTypeOf _ = seqDataType
+
+ dataCast1 f = gcast1 f
+
+emptyConstr, consConstr :: Constr
+emptyConstr = mkConstr seqDataType "empty" [] Prefix
+consConstr = mkConstr seqDataType "<|" [] Infix
+
+seqDataType :: DataType
+seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]
+#endif
+
+-- Finger trees
+
+data FingerTree a
+ = Empty
+ | Single a
+ | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)
+#if TESTING
+ deriving Show
+#endif
+
+instance Sized a => Sized (FingerTree a) where
+ {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}
+ {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}
+ size Empty = 0
+ size (Single x) = size x
+ size (Deep v _ _ _) = v
+
+instance Foldable FingerTree where
+ foldr _ z Empty = z
+ foldr f z (Single x) = x `f` z
+ foldr f z (Deep _ pr m sf) =
+ foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr
+
+ foldl _ z Empty = z
+ foldl f z (Single x) = z `f` x
+ foldl f z (Deep _ pr m sf) =
+ foldl f (foldl (foldl f) (foldl f z pr) m) sf
+
+ foldr1 _ Empty = error "foldr1: empty sequence"
+ foldr1 _ (Single x) = x
+ foldr1 f (Deep _ pr m sf) =
+ foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr
+
+ foldl1 _ Empty = error "foldl1: empty sequence"
+ foldl1 _ (Single x) = x
+ foldl1 f (Deep _ pr m sf) =
+ foldl f (foldl (foldl f) (foldl1 f pr) m) sf
+
+instance Functor FingerTree where
+ fmap _ Empty = Empty
+ fmap f (Single x) = Single (f x)
+ fmap f (Deep v pr m sf) =
+ Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)
+
+instance Traversable FingerTree where
+ traverse _ Empty = pure Empty
+ traverse f (Single x) = Single <$> f x
+ traverse f (Deep v pr m sf) =
+ Deep v <$> traverse f pr <*> traverse (traverse f) m <*>
+ traverse f sf
+
+{-# INLINE deep #-}
+{-# SPECIALIZE INLINE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
+{-# SPECIALIZE INLINE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
+deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
+deep pr m sf = Deep (size pr + size m + size sf) pr m sf
+
+{-# INLINE pullL #-}
+pullL :: Sized a => Int -> FingerTree (Node a) -> Digit a -> FingerTree a
+pullL s m sf = case viewLTree m of
+ Nothing2 -> digitToTree' s sf
+ Just2 pr m' -> Deep s (nodeToDigit pr) m' sf
+
+{-# INLINE pullR #-}
+pullR :: Sized a => Int -> Digit a -> FingerTree (Node a) -> FingerTree a
+pullR s pr m = case viewRTree m of
+ Nothing2 -> digitToTree' s pr
+ Just2 m' sf -> Deep s pr m' (nodeToDigit sf)
+
+{-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
+{-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
+deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a
+deepL Nothing m sf = pullL (size m + size sf) m sf
+deepL (Just pr) m sf = deep pr m sf
+
+{-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}
+{-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}
+deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a
+deepR pr m Nothing = pullR (size m + size pr) pr m
+deepR pr m (Just sf) = deep pr m sf
+
+-- Digits
+
+data Digit a
+ = One a
+ | Two a a
+ | Three a a a
+ | Four a a a a
+#if TESTING
+ deriving Show
+#endif
+
+instance Foldable Digit where
+ foldr f z (One a) = a `f` z
+ foldr f z (Two a b) = a `f` (b `f` z)
+ foldr f z (Three a b c) = a `f` (b `f` (c `f` z))
+ foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
+
+ foldl f z (One a) = z `f` a
+ foldl f z (Two a b) = (z `f` a) `f` b
+ foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c
+ foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
+
+ foldr1 _ (One a) = a
+ foldr1 f (Two a b) = a `f` b
+ foldr1 f (Three a b c) = a `f` (b `f` c)
+ foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))
+
+ foldl1 _ (One a) = a
+ foldl1 f (Two a b) = a `f` b
+ foldl1 f (Three a b c) = (a `f` b) `f` c
+ foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d
+
+instance Functor Digit where
+ {-# INLINE fmap #-}
+ fmap f (One a) = One (f a)
+ fmap f (Two a b) = Two (f a) (f b)
+ fmap f (Three a b c) = Three (f a) (f b) (f c)
+ fmap f (Four a b c d) = Four (f a) (f b) (f c) (f d)
+
+instance Traversable Digit where
+ {-# INLINE traverse #-}
+ traverse f (One a) = One <$> f a
+ traverse f (Two a b) = Two <$> f a <*> f b
+ traverse f (Three a b c) = Three <$> f a <*> f b <*> f c
+ traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
+
+instance Sized a => Sized (Digit a) where
+ {-# INLINE size #-}
+ size = foldl1 (+) . fmap size
+
+{-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
+{-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
+digitToTree :: Sized a => Digit a -> FingerTree a
+digitToTree (One a) = Single a
+digitToTree (Two a b) = deep (One a) Empty (One b)
+digitToTree (Three a b c) = deep (Two a b) Empty (One c)
+digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)
+
+-- | Given the size of a digit and the digit itself, efficiently converts
+-- it to a FingerTree.
+digitToTree' :: Int -> Digit a -> FingerTree a
+digitToTree' n (Four a b c d) = Deep n (Two a b) Empty (Two c d)
+digitToTree' n (Three a b c) = Deep n (Two a b) Empty (One c)
+digitToTree' n (Two a b) = Deep n (One a) Empty (One b)
+digitToTree' n (One a) = n `seq` Single a
+
+-- Nodes
+
+data Node a
+ = Node2 {-# UNPACK #-} !Int a a
+ | Node3 {-# UNPACK #-} !Int a a a
+#if TESTING
+ deriving Show
+#endif
+
+instance Foldable Node where
+ foldr f z (Node2 _ a b) = a `f` (b `f` z)
+ foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
+
+ foldl f z (Node2 _ a b) = (z `f` a) `f` b
+ foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
+
+instance Functor Node where
+ {-# INLINE fmap #-}
+ fmap f (Node2 v a b) = Node2 v (f a) (f b)
+ fmap f (Node3 v a b c) = Node3 v (f a) (f b) (f c)
+
+instance Traversable Node where
+ {-# INLINE traverse #-}
+ traverse f (Node2 v a b) = Node2 v <$> f a <*> f b
+ traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c
+
+instance Sized (Node a) where
+ size (Node2 v _ _) = v
+ size (Node3 v _ _ _) = v
+
+{-# INLINE node2 #-}
+{-# SPECIALIZE node2 :: Elem a -> Elem a -> Node (Elem a) #-}
+{-# SPECIALIZE node2 :: Node a -> Node a -> Node (Node a) #-}
+node2 :: Sized a => a -> a -> Node a
+node2 a b = Node2 (size a + size b) a b
+
+{-# INLINE node3 #-}
+{-# SPECIALIZE node3 :: Elem a -> Elem a -> Elem a -> Node (Elem a) #-}
+{-# SPECIALIZE node3 :: Node a -> Node a -> Node a -> Node (Node a) #-}
+node3 :: Sized a => a -> a -> a -> Node a
+node3 a b c = Node3 (size a + size b + size c) a b c
+
+nodeToDigit :: Node a -> Digit a
+nodeToDigit (Node2 _ a b) = Two a b
+nodeToDigit (Node3 _ a b c) = Three a b c
+
+-- Elements
+
+newtype Elem a = Elem { getElem :: a }
+
+instance Sized (Elem a) where
+ size _ = 1
+
+instance Functor Elem where
+ fmap f (Elem x) = Elem (f x)
+
+instance Foldable Elem where
+ foldr f z (Elem x) = f x z
+ foldl f z (Elem x) = f z x
+
+instance Traversable Elem where
+ traverse f (Elem x) = Elem <$> f x
+
+#ifdef TESTING
+instance (Show a) => Show (Elem a) where
+ showsPrec p (Elem x) = showsPrec p x
+#endif
+
+-------------------------------------------------------
+-- Applicative construction
+-------------------------------------------------------
+
+newtype Id a = Id {runId :: a}
+
+instance Functor Id where
+ fmap f (Id x) = Id (f x)
+
+instance Monad Id where
+ return = Id
+ m >>= k = k (runId m)
+
+instance Applicative Id where
+ pure = return
+ (<*>) = ap
+
+-- | This is essentially a clone of Control.Monad.State.Strict.
+newtype State s a = State {runState :: s -> (s, a)}
+
+instance Functor (State s) where
+ fmap = liftA
+
+instance Monad (State s) where
+ {-# INLINE return #-}
+ {-# INLINE (>>=) #-}
+ return x = State $ \ s -> (s, x)
+ m >>= k = State $ \ s -> case runState m s of
+ (s', x) -> runState (k x) s'
+
+instance Applicative (State s) where
+ pure = return
+ (<*>) = ap
+
+execState :: State s a -> s -> a
+execState m x = snd (runState m x)
+
+-- | A helper method: a strict version of mapAccumL.
+mapAccumL' :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c)
+mapAccumL' f s t = runState (traverse (State . flip f) t) s
+
+-- | 'applicativeTree' takes an Applicative-wrapped construction of a
+-- piece of a FingerTree, assumed to always have the same size (which
+-- is put in the second argument), and replicates it as many times as
+-- specified. This is a generalization of 'replicateA', which itself
+-- is a generalization of many Data.Sequence methods.
+{-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-}
+{-# SPECIALIZE applicativeTree :: Int -> Int -> Id a -> Id (FingerTree a) #-}
+-- Special note: the Id specialization automatically does node sharing,
+-- reducing memory usage of the resulting tree to /O(log n)/.
+applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a)
+applicativeTree n mSize m = mSize `seq` case n of
+ 0 -> pure Empty
+ 1 -> liftA Single m
+ 2 -> deepA one emptyTree one
+ 3 -> deepA two emptyTree one
+ 4 -> deepA two emptyTree two
+ 5 -> deepA three emptyTree two
+ 6 -> deepA three emptyTree three
+ 7 -> deepA four emptyTree three
+ 8 -> deepA four emptyTree four
+ _ -> let (q, r) = n `quotRem` 3 in q `seq` case r of
+ 0 -> deepA three (applicativeTree (q - 2) mSize' n3) three
+ 1 -> deepA four (applicativeTree (q - 2) mSize' n3) three
+ _ -> deepA four (applicativeTree (q - 2) mSize' n3) four
+ where
+ one = liftA One m
+ two = liftA2 Two m m
+ three = liftA3 Three m m m
+ four = liftA3 Four m m m <*> m
+ deepA = liftA3 (Deep (n * mSize))
+ mSize' = 3 * mSize
+ n3 = liftA3 (Node3 mSize') m m m
+ emptyTree = pure Empty
+
+------------------------------------------------------------------------
+-- Construction
+------------------------------------------------------------------------
+
+-- | /O(1)/. The empty sequence.
+empty :: Seq a
+empty = Seq Empty
+
+-- | /O(1)/. A singleton sequence.
+singleton :: a -> Seq a
+singleton x = Seq (Single (Elem x))
+
+-- | /O(log n)/. @replicate n x@ is a sequence consisting of @n@ copies of @x@.
+replicate :: Int -> a -> Seq a
+replicate n x
+ | n >= 0 = runId (replicateA n (Id x))
+ | otherwise = error "replicate takes a nonnegative integer argument"
+
+-- | 'replicateA' is an 'Applicative' version of 'replicate', and makes
+-- /O(log n)/ calls to '<*>' and 'pure'.
+--
+-- > replicateA n x = sequenceA (replicate n x)
+replicateA :: Applicative f => Int -> f a -> f (Seq a)
+replicateA n x
+ | n >= 0 = Seq <$> applicativeTree n 1 (Elem <$> x)
+ | otherwise = error "replicateA takes a nonnegative integer argument"
+
+-- | 'replicateM' is a sequence counterpart of 'Control.Monad.replicateM'.
+--
+-- > replicateM n x = sequence (replicate n x)
+replicateM :: Monad m => Int -> m a -> m (Seq a)
+replicateM n x
+ | n >= 0 = unwrapMonad (replicateA n (WrapMonad x))
+ | otherwise = error "replicateM takes a nonnegative integer argument"
+
+-- | /O(1)/. Add an element to the left end of a sequence.
+-- Mnemonic: a triangle with the single element at the pointy end.
+(<|) :: a -> Seq a -> Seq a
+x <| Seq xs = Seq (Elem x `consTree` xs)
+
+{-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
+{-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}
+consTree :: Sized a => a -> FingerTree a -> FingerTree a
+consTree a Empty = Single a
+consTree a (Single b) = deep (One a) Empty (One b)
+consTree a (Deep s (Four b c d e) m sf) = m `seq`
+ Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf
+consTree a (Deep s (Three b c d) m sf) =
+ Deep (size a + s) (Four a b c d) m sf
+consTree a (Deep s (Two b c) m sf) =
+ Deep (size a + s) (Three a b c) m sf
+consTree a (Deep s (One b) m sf) =
+ Deep (size a + s) (Two a b) m sf
+
+-- | /O(1)/. Add an element to the right end of a sequence.
+-- Mnemonic: a triangle with the single element at the pointy end.
+(|>) :: Seq a -> a -> Seq a
+Seq xs |> x = Seq (xs `snocTree` Elem x)
+
+{-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}
+{-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}
+snocTree :: Sized a => FingerTree a -> a -> FingerTree a
+snocTree Empty a = Single a
+snocTree (Single a) b = deep (One a) Empty (One b)
+snocTree (Deep s pr m (Four a b c d)) e = m `seq`
+ Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)
+snocTree (Deep s pr m (Three a b c)) d =
+ Deep (s + size d) pr m (Four a b c d)
+snocTree (Deep s pr m (Two a b)) c =
+ Deep (s + size c) pr m (Three a b c)
+snocTree (Deep s pr m (One a)) b =
+ Deep (s + size b) pr m (Two a b)
+
+-- | /O(log(min(n1,n2)))/. Concatenate two sequences.
+(><) :: Seq a -> Seq a -> Seq a
+Seq xs >< Seq ys = Seq (appendTree0 xs ys)
+
+-- The appendTree/addDigits gunk below is machine generated
+
+appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)
+appendTree0 Empty xs =
+ xs
+appendTree0 xs Empty =
+ xs
+appendTree0 (Single x) xs =
+ x `consTree` xs
+appendTree0 xs (Single x) =
+ xs `snocTree` x
+appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =
+ Deep (s1 + s2) pr1 (addDigits0 m1 sf1 pr2 m2) sf2
+
+addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))
+addDigits0 m1 (One a) (One b) m2 =
+ appendTree1 m1 (node2 a b) m2
+addDigits0 m1 (One a) (Two b c) m2 =
+ appendTree1 m1 (node3 a b c) m2
+addDigits0 m1 (One a) (Three b c d) m2 =
+ appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits0 m1 (One a) (Four b c d e) m2 =
+ appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits0 m1 (Two a b) (One c) m2 =
+ appendTree1 m1 (node3 a b c) m2
+addDigits0 m1 (Two a b) (Two c d) m2 =
+ appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits0 m1 (Two a b) (Three c d e) m2 =
+ appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits0 m1 (Two a b) (Four c d e f) m2 =
+ appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits0 m1 (Three a b c) (One d) m2 =
+ appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits0 m1 (Three a b c) (Two d e) m2 =
+ appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits0 m1 (Three a b c) (Three d e f) m2 =
+ appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits0 m1 (Three a b c) (Four d e f g) m2 =
+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits0 m1 (Four a b c d) (One e) m2 =
+ appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits0 m1 (Four a b c d) (Two e f) m2 =
+ appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits0 m1 (Four a b c d) (Three e f g) m2 =
+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+
+appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
+appendTree1 Empty a xs =
+ a `consTree` xs
+appendTree1 xs a Empty =
+ xs `snocTree` a
+appendTree1 (Single x) a xs =
+ x `consTree` a `consTree` xs
+appendTree1 xs a (Single x) =
+ xs `snocTree` a `snocTree` x
+appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
+ Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
+
+addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
+addDigits1 m1 (One a) b (One c) m2 =
+ appendTree1 m1 (node3 a b c) m2
+addDigits1 m1 (One a) b (Two c d) m2 =
+ appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits1 m1 (One a) b (Three c d e) m2 =
+ appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits1 m1 (One a) b (Four c d e f) m2 =
+ appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits1 m1 (Two a b) c (One d) m2 =
+ appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits1 m1 (Two a b) c (Two d e) m2 =
+ appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits1 m1 (Two a b) c (Three d e f) m2 =
+ appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits1 m1 (Two a b) c (Four d e f g) m2 =
+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits1 m1 (Three a b c) d (One e) m2 =
+ appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits1 m1 (Three a b c) d (Two e f) m2 =
+ appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits1 m1 (Three a b c) d (Three e f g) m2 =
+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits1 m1 (Four a b c d) e (One f) m2 =
+ appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits1 m1 (Four a b c d) e (Two f g) m2 =
+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+
+appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
+appendTree2 Empty a b xs =
+ a `consTree` b `consTree` xs
+appendTree2 xs a b Empty =
+ xs `snocTree` a `snocTree` b
+appendTree2 (Single x) a b xs =
+ x `consTree` a `consTree` b `consTree` xs
+appendTree2 xs a b (Single x) =
+ xs `snocTree` a `snocTree` b `snocTree` x
+appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
+ Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
+
+addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
+addDigits2 m1 (One a) b c (One d) m2 =
+ appendTree2 m1 (node2 a b) (node2 c d) m2
+addDigits2 m1 (One a) b c (Two d e) m2 =
+ appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits2 m1 (One a) b c (Three d e f) m2 =
+ appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits2 m1 (One a) b c (Four d e f g) m2 =
+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits2 m1 (Two a b) c d (One e) m2 =
+ appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits2 m1 (Two a b) c d (Two e f) m2 =
+ appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits2 m1 (Two a b) c d (Three e f g) m2 =
+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits2 m1 (Three a b c) d e (One f) m2 =
+ appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits2 m1 (Three a b c) d e (Two f g) m2 =
+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits2 m1 (Four a b c d) e f (One g) m2 =
+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+
+appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
+appendTree3 Empty a b c xs =
+ a `consTree` b `consTree` c `consTree` xs
+appendTree3 xs a b c Empty =
+ xs `snocTree` a `snocTree` b `snocTree` c
+appendTree3 (Single x) a b c xs =
+ x `consTree` a `consTree` b `consTree` c `consTree` xs
+appendTree3 xs a b c (Single x) =
+ xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
+appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
+ Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
+
+addDigits3 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
+addDigits3 m1 (One a) b c d (One e) m2 =
+ appendTree2 m1 (node3 a b c) (node2 d e) m2
+addDigits3 m1 (One a) b c d (Two e f) m2 =
+ appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits3 m1 (One a) b c d (Three e f g) m2 =
+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits3 m1 (One a) b c d (Four e f g h) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits3 m1 (Two a b) c d e (One f) m2 =
+ appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits3 m1 (Two a b) c d e (Two f g) m2 =
+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits3 m1 (Three a b c) d e f (One g) m2 =
+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+addDigits3 m1 (Four a b c d) e f g (One h) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
+ appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
+
+appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
+appendTree4 Empty a b c d xs =
+ a `consTree` b `consTree` c `consTree` d `consTree` xs
+appendTree4 xs a b c d Empty =
+ xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
+appendTree4 (Single x) a b c d xs =
+ x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
+appendTree4 xs a b c d (Single x) =
+ xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
+appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
+ Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
+
+addDigits4 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
+addDigits4 m1 (One a) b c d e (One f) m2 =
+ appendTree2 m1 (node3 a b c) (node3 d e f) m2
+addDigits4 m1 (One a) b c d e (Two f g) m2 =
+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits4 m1 (One a) b c d e (Three f g h) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits4 m1 (Two a b) c d e f (One g) m2 =
+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
+addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+addDigits4 m1 (Three a b c) d e f g (One h) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
+addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
+ appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
+addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
+addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
+addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
+ appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
+addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
+ appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
+
+-- | Builds a sequence from a seed value. Takes time linear in the
+-- number of generated elements. /WARNING:/ If the number of generated
+-- elements is infinite, this method will not terminate.
+unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a
+unfoldr f = unfoldr' empty
+ -- uses tail recursion rather than, for instance, the List implementation.
+ where unfoldr' as b = maybe as (\ (a, b') -> unfoldr' (as |> a) b') (f b)
+
+-- | @'unfoldl' f x@ is equivalent to @'reverse' ('unfoldr' ('fmap' swap . f) x)@.
+unfoldl :: (b -> Maybe (b, a)) -> b -> Seq a
+unfoldl f = unfoldl' empty
+ where unfoldl' as b = maybe as (\ (b', a) -> unfoldl' (a <| as) b') (f b)
+
+-- | /O(n)/. Constructs a sequence by repeated application of a function
+-- to a seed value.
+--
+-- > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x))
+iterateN :: Int -> (a -> a) -> a -> Seq a
+iterateN n f x
+ | n >= 0 = replicateA n (State (\ y -> (f y, y))) `execState` x
+ | otherwise = error "iterateN takes a nonnegative integer argument"
+
+------------------------------------------------------------------------
+-- Deconstruction
+------------------------------------------------------------------------
+
+-- | /O(1)/. Is this the empty sequence?
+null :: Seq a -> Bool
+null (Seq Empty) = True
+null _ = False
+
+-- | /O(1)/. The number of elements in the sequence.
+length :: Seq a -> Int
+length (Seq xs) = size xs
+
+-- Views
+
+data Maybe2 a b = Nothing2 | Just2 a b
+
+-- | View of the left end of a sequence.
+data ViewL a
+ = EmptyL -- ^ empty sequence
+ | a :< Seq a -- ^ leftmost element and the rest of the sequence
+#if __GLASGOW_HASKELL__
+ deriving (Eq, Ord, Show, Read, Data)
+#else
+ deriving (Eq, Ord, Show, Read)
+#endif
+
+INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")
+
+instance Functor ViewL where
+ {-# INLINE fmap #-}
+ fmap _ EmptyL = EmptyL
+ fmap f (x :< xs) = f x :< fmap f xs
+
+instance Foldable ViewL where
+ foldr _ z EmptyL = z
+ foldr f z (x :< xs) = f x (foldr f z xs)
+
+ foldl _ z EmptyL = z
+ foldl f z (x :< xs) = foldl f (f z x) xs
+
+ foldl1 _ EmptyL = error "foldl1: empty view"
+ foldl1 f (x :< xs) = foldl f x xs
+
+instance Traversable ViewL where
+ traverse _ EmptyL = pure EmptyL
+ traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs
+
+-- | /O(1)/. Analyse the left end of a sequence.
+viewl :: Seq a -> ViewL a
+viewl (Seq xs) = case viewLTree xs of
+ Nothing2 -> EmptyL
+ Just2 (Elem x) xs' -> x :< Seq xs'
+
+{-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> Maybe2 (Elem a) (FingerTree (Elem a)) #-}
+{-# SPECIALIZE viewLTree :: FingerTree (Node a) -> Maybe2 (Node a) (FingerTree (Node a)) #-}
+viewLTree :: Sized a => FingerTree a -> Maybe2 a (FingerTree a)
+viewLTree Empty = Nothing2
+viewLTree (Single a) = Just2 a Empty
+viewLTree (Deep s (One a) m sf) = Just2 a (pullL (s - size a) m sf)
+viewLTree (Deep s (Two a b) m sf) =
+ Just2 a (Deep (s - size a) (One b) m sf)
+viewLTree (Deep s (Three a b c) m sf) =
+ Just2 a (Deep (s - size a) (Two b c) m sf)
+viewLTree (Deep s (Four a b c d) m sf) =
+ Just2 a (Deep (s - size a) (Three b c d) m sf)
+
+-- | View of the right end of a sequence.
+data ViewR a
+ = EmptyR -- ^ empty sequence
+ | Seq a :> a -- ^ the sequence minus the rightmost element,
+ -- and the rightmost element
+#if __GLASGOW_HASKELL__
+ deriving (Eq, Ord, Show, Read, Data)
+#else
+ deriving (Eq, Ord, Show, Read)
+#endif
+
+INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")
+
+instance Functor ViewR where
+ {-# INLINE fmap #-}
+ fmap _ EmptyR = EmptyR
+ fmap f (xs :> x) = fmap f xs :> f x
+
+instance Foldable ViewR where
+ foldr _ z EmptyR = z
+ foldr f z (xs :> x) = foldr f (f x z) xs
+
+ foldl _ z EmptyR = z
+ foldl f z (xs :> x) = foldl f z xs `f` x
+
+ foldr1 _ EmptyR = error "foldr1: empty view"
+ foldr1 f (xs :> x) = foldr f x xs
+
+instance Traversable ViewR where
+ traverse _ EmptyR = pure EmptyR
+ traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x
+
+-- | /O(1)/. Analyse the right end of a sequence.
+viewr :: Seq a -> ViewR a
+viewr (Seq xs) = case viewRTree xs of
+ Nothing2 -> EmptyR
+ Just2 xs' (Elem x) -> Seq xs' :> x
+
+{-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> Maybe2 (FingerTree (Elem a)) (Elem a) #-}
+{-# SPECIALIZE viewRTree :: FingerTree (Node a) -> Maybe2 (FingerTree (Node a)) (Node a) #-}
+viewRTree :: Sized a => FingerTree a -> Maybe2 (FingerTree a) a
+viewRTree Empty = Nothing2
+viewRTree (Single z) = Just2 Empty z
+viewRTree (Deep s pr m (One z)) = Just2 (pullR (s - size z) pr m) z
+viewRTree (Deep s pr m (Two y z)) =
+ Just2 (Deep (s - size z) pr m (One y)) z
+viewRTree (Deep s pr m (Three x y z)) =
+ Just2 (Deep (s - size z) pr m (Two x y)) z
+viewRTree (Deep s pr m (Four w x y z)) =
+ Just2 (Deep (s - size z) pr m (Three w x y)) z
+
+------------------------------------------------------------------------
+-- Scans
+--
+-- These are not particularly complex applications of the Traversable
+-- functor, though making the correspondence with Data.List exact
+-- requires the use of (<|) and (|>).
+--
+-- Note that save for the single (<|) or (|>), we maintain the original
+-- structure of the Seq, not having to do any restructuring of our own.
+--
+-- wasserman.louis@gmail.com, 5/23/09
+------------------------------------------------------------------------
+
+-- | 'scanl' is similar to 'foldl', but returns a sequence of reduced
+-- values from the left:
+--
+-- > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...]
+scanl :: (a -> b -> a) -> a -> Seq b -> Seq a
+scanl f z0 xs = z0 <| snd (mapAccumL (\ x z -> let x' = f x z in (x', x')) z0 xs)
+
+-- | 'scanl1' is a variant of 'scanl' that has no starting value argument:
+--
+-- > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...]
+scanl1 :: (a -> a -> a) -> Seq a -> Seq a
+scanl1 f xs = case viewl xs of
+ EmptyL -> error "scanl1 takes a nonempty sequence as an argument"
+ x :< xs' -> scanl f x xs'
+
+-- | 'scanr' is the right-to-left dual of 'scanl'.
+scanr :: (a -> b -> b) -> b -> Seq a -> Seq b
+scanr f z0 xs = snd (mapAccumR (\ z x -> let z' = f x z in (z', z')) z0 xs) |> z0
+
+-- | 'scanr1' is a variant of 'scanr' that has no starting value argument.
+scanr1 :: (a -> a -> a) -> Seq a -> Seq a
+scanr1 f xs = case viewr xs of
+ EmptyR -> error "scanr1 takes a nonempty sequence as an argument"
+ xs' :> x -> scanr f x xs'
+
+-- Indexing
+
+-- | /O(log(min(i,n-i)))/. The element at the specified position,
+-- counting from 0. The argument should thus be a non-negative
+-- integer less than the size of the sequence.
+-- If the position is out of range, 'index' fails with an error.
+index :: Seq a -> Int -> a
+index (Seq xs) i
+ | 0 <= i && i < size xs = case lookupTree i xs of
+ Place _ (Elem x) -> x
+ | otherwise = error "index out of bounds"
+
+data Place a = Place {-# UNPACK #-} !Int a
+#if TESTING
+ deriving Show
+#endif
+
+{-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}
+{-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}
+lookupTree :: Sized a => Int -> FingerTree a -> Place a
+lookupTree _ Empty = error "lookupTree of empty tree"
+lookupTree i (Single x) = Place i x
+lookupTree i (Deep _ pr m sf)
+ | i < spr = lookupDigit i pr
+ | i < spm = case lookupTree (i - spr) m of
+ Place i' xs -> lookupNode i' xs
+ | otherwise = lookupDigit (i - spm) sf
+ where
+ spr = size pr
+ spm = spr + size m
+
+{-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}
+{-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}
+lookupNode :: Sized a => Int -> Node a -> Place a
+lookupNode i (Node2 _ a b)
+ | i < sa = Place i a
+ | otherwise = Place (i - sa) b
+ where
+ sa = size a
+lookupNode i (Node3 _ a b c)
+ | i < sa = Place i a
+ | i < sab = Place (i - sa) b
+ | otherwise = Place (i - sab) c
+ where
+ sa = size a
+ sab = sa + size b
+
+{-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}
+{-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}
+lookupDigit :: Sized a => Int -> Digit a -> Place a
+lookupDigit i (One a) = Place i a
+lookupDigit i (Two a b)
+ | i < sa = Place i a
+ | otherwise = Place (i - sa) b
+ where
+ sa = size a
+lookupDigit i (Three a b c)
+ | i < sa = Place i a
+ | i < sab = Place (i - sa) b
+ | otherwise = Place (i - sab) c
+ where
+ sa = size a
+ sab = sa + size b
+lookupDigit i (Four a b c d)
+ | i < sa = Place i a
+ | i < sab = Place (i - sa) b
+ | i < sabc = Place (i - sab) c
+ | otherwise = Place (i - sabc) d
+ where
+ sa = size a
+ sab = sa + size b
+ sabc = sab + size c
+
+-- | /O(log(min(i,n-i)))/. Replace the element at the specified position.
+-- If the position is out of range, the original sequence is returned.
+update :: Int -> a -> Seq a -> Seq a
+update i x = adjust (const x) i
+
+-- | /O(log(min(i,n-i)))/. Update the element at the specified position.
+-- If the position is out of range, the original sequence is returned.
+adjust :: (a -> a) -> Int -> Seq a -> Seq a
+adjust f i (Seq xs)
+ | 0 <= i && i < size xs = Seq (adjustTree (const (fmap f)) i xs)
+ | otherwise = Seq xs
+
+{-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
+{-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}
+adjustTree :: Sized a => (Int -> a -> a) ->
+ Int -> FingerTree a -> FingerTree a
+adjustTree _ _ Empty = error "adjustTree of empty tree"
+adjustTree f i (Single x) = Single (f i x)
+adjustTree f i (Deep s pr m sf)
+ | i < spr = Deep s (adjustDigit f i pr) m sf
+ | i < spm = Deep s pr (adjustTree (adjustNode f) (i - spr) m) sf
+ | otherwise = Deep s pr m (adjustDigit f (i - spm) sf)
+ where
+ spr = size pr
+ spm = spr + size m
+
+{-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}
+{-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}
+adjustNode :: Sized a => (Int -> a -> a) -> Int -> Node a -> Node a
+adjustNode f i (Node2 s a b)
+ | i < sa = Node2 s (f i a) b
+ | otherwise = Node2 s a (f (i - sa) b)
+ where
+ sa = size a
+adjustNode f i (Node3 s a b c)
+ | i < sa = Node3 s (f i a) b c
+ | i < sab = Node3 s a (f (i - sa) b) c
+ | otherwise = Node3 s a b (f (i - sab) c)
+ where
+ sa = size a
+ sab = sa + size b
+
+{-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}
+{-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}
+adjustDigit :: Sized a => (Int -> a -> a) -> Int -> Digit a -> Digit a
+adjustDigit f i (One a) = One (f i a)
+adjustDigit f i (Two a b)
+ | i < sa = Two (f i a) b
+ | otherwise = Two a (f (i - sa) b)
+ where
+ sa = size a
+adjustDigit f i (Three a b c)
+ | i < sa = Three (f i a) b c
+ | i < sab = Three a (f (i - sa) b) c
+ | otherwise = Three a b (f (i - sab) c)
+ where
+ sa = size a
+ sab = sa + size b
+adjustDigit f i (Four a b c d)
+ | i < sa = Four (f i a) b c d
+ | i < sab = Four a (f (i - sa) b) c d
+ | i < sabc = Four a b (f (i - sab) c) d
+ | otherwise = Four a b c (f (i- sabc) d)
+ where
+ sa = size a
+ sab = sa + size b
+ sabc = sab + size c
+
+-- | A generalization of 'fmap', 'mapWithIndex' takes a mapping function
+-- that also depends on the element's index, and applies it to every
+-- element in the sequence.
+mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b
+mapWithIndex f xs = snd (mapAccumL' (\ i x -> (i + 1, f i x)) 0 xs)
+
+-- Splitting
+
+-- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.
+-- If @i@ is negative, @'take' i s@ yields the empty sequence.
+-- If the sequence contains fewer than @i@ elements, the whole sequence
+-- is returned.
+take :: Int -> Seq a -> Seq a
+take i = fst . splitAt i
+
+-- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@.
+-- If @i@ is negative, @'drop' i s@ yields the whole sequence.
+-- If the sequence contains fewer than @i@ elements, the empty sequence
+-- is returned.
+drop :: Int -> Seq a -> Seq a
+drop i = snd . splitAt i
+
+-- | /O(log(min(i,n-i)))/. Split a sequence at a given position.
+-- @'splitAt' i s = ('take' i s, 'drop' i s)@.
+splitAt :: Int -> Seq a -> (Seq a, Seq a)
+splitAt i (Seq xs) = (Seq l, Seq r)
+ where (l, r) = split i xs
+
+split :: Int -> FingerTree (Elem a) ->
+ (FingerTree (Elem a), FingerTree (Elem a))
+split i Empty = i `seq` (Empty, Empty)
+split i xs
+ | size xs > i = (l, consTree x r)
+ | otherwise = (xs, Empty)
+ where Split l x r = splitTree i xs
+
+data Split t a = Split t a t
+#if TESTING
+ deriving Show
+#endif
+
+{-# SPECIALIZE splitTree :: Int -> FingerTree (Elem a) -> Split (FingerTree (Elem a)) (Elem a) #-}
+{-# SPECIALIZE splitTree :: Int -> FingerTree (Node a) -> Split (FingerTree (Node a)) (Node a) #-}
+splitTree :: Sized a => Int -> FingerTree a -> Split (FingerTree a) a
+splitTree _ Empty = error "splitTree of empty tree"
+splitTree i (Single x) = i `seq` Split Empty x Empty
+splitTree i (Deep _ pr m sf)
+ | i < spr = case splitDigit i pr of
+ Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)
+ | i < spm = case splitTree im m of
+ Split ml xs mr -> case splitNode (im - size ml) xs of
+ Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)
+ | otherwise = case splitDigit (i - spm) sf of
+ Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)
+ where
+ spr = size pr
+ spm = spr + size m
+ im = i - spr
+
+{-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
+{-# SPECIALIZE splitNode :: Int -> Node (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
+splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a
+splitNode i (Node2 _ a b)
+ | i < sa = Split Nothing a (Just (One b))
+ | otherwise = Split (Just (One a)) b Nothing
+ where
+ sa = size a
+splitNode i (Node3 _ a b c)
+ | i < sa = Split Nothing a (Just (Two b c))
+ | i < sab = Split (Just (One a)) b (Just (One c))
+ | otherwise = Split (Just (Two a b)) c Nothing
+ where
+ sa = size a
+ sab = sa + size b
+
+{-# SPECIALIZE splitDigit :: Int -> Digit (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
+{-# SPECIALIZE splitDigit :: Int -> Digit (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
+splitDigit :: Sized a => Int -> Digit a -> Split (Maybe (Digit a)) a
+splitDigit i (One a) = i `seq` Split Nothing a Nothing
+splitDigit i (Two a b)
+ | i < sa = Split Nothing a (Just (One b))
+ | otherwise = Split (Just (One a)) b Nothing
+ where
+ sa = size a
+splitDigit i (Three a b c)
+ | i < sa = Split Nothing a (Just (Two b c))
+ | i < sab = Split (Just (One a)) b (Just (One c))
+ | otherwise = Split (Just (Two a b)) c Nothing
+ where
+ sa = size a
+ sab = sa + size b
+splitDigit i (Four a b c d)
+ | i < sa = Split Nothing a (Just (Three b c d))
+ | i < sab = Split (Just (One a)) b (Just (Two c d))
+ | i < sabc = Split (Just (Two a b)) c (Just (One d))
+ | otherwise = Split (Just (Three a b c)) d Nothing
+ where
+ sa = size a
+ sab = sa + size b
+ sabc = sab + size c
+
+-- | /O(n)/. Returns a sequence of all suffixes of this sequence,
+-- longest first. For example,
+--
+-- > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""]
+--
+-- Evaluating the /i/th suffix takes /O(log(min(i, n-i)))/, but evaluating
+-- every suffix in the sequence takes /O(n)/ due to sharing.
+tails :: Seq a -> Seq (Seq a)
+tails (Seq xs) = Seq (tailsTree (Elem . Seq) xs) |> empty
+
+-- | /O(n)/. Returns a sequence of all prefixes of this sequence,
+-- shortest first. For example,
+--
+-- > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"]
+--
+-- Evaluating the /i/th prefix takes /O(log(min(i, n-i)))/, but evaluating
+-- every prefix in the sequence takes /O(n)/ due to sharing.
+inits :: Seq a -> Seq (Seq a)
+inits (Seq xs) = empty <| Seq (initsTree (Elem . Seq) xs)
+
+-- This implementation of tails (and, analogously, inits) has the
+-- following algorithmic advantages:
+-- Evaluating each tail in the sequence takes linear total time,
+-- which is better than we could say for
+-- @fromList [drop n xs | n <- [0..length xs]]@.
+-- Evaluating any individual tail takes logarithmic time, which is
+-- better than we can say for either
+-- @scanr (<|) empty xs@ or @iterateN (length xs + 1) (\ xs -> let _ :< xs' = viewl xs in xs') xs@.
+--
+-- Moreover, if we actually look at every tail in the sequence, the
+-- following benchmarks demonstrate that this implementation is modestly
+-- faster than any of the above:
+--
+-- Times (ms)
+-- min mean +/-sd median max
+-- Seq.tails: 21.986 24.961 10.169 22.417 86.485
+-- scanr: 85.392 87.942 2.488 87.425 100.217
+-- iterateN: 29.952 31.245 1.574 30.412 37.268
+--
+-- The algorithm for tails (and, analogously, inits) is as follows:
+--
+-- A Node in the FingerTree of tails is constructed by evaluating the
+-- corresponding tail of the FingerTree of Nodes, considering the first
+-- Node in this tail, and constructing a Node in which each tail of this
+-- Node is made to be the prefix of the remaining tree. This ends up
+-- working quite elegantly, as the remainder of the tail of the FingerTree
+-- of Nodes becomes the middle of a new tail, the suffix of the Node is
+-- the prefix, and the suffix of the original tree is retained.
+--
+-- In particular, evaluating the /i/th tail involves making as
+-- many partial evaluations as the Node depth of the /i/th element.
+-- In addition, when we evaluate the /i/th tail, and we also evaluate
+-- the /j/th tail, and /m/ Nodes are on the path to both /i/ and /j/,
+-- each of those /m/ evaluations are shared between the computation of
+-- the /i/th and /j/th tails.
+--
+-- wasserman.louis@gmail.com, 7/16/09
+
+tailsDigit :: Digit a -> Digit (Digit a)
+tailsDigit (One a) = One (One a)
+tailsDigit (Two a b) = Two (Two a b) (One b)
+tailsDigit (Three a b c) = Three (Three a b c) (Two b c) (One c)
+tailsDigit (Four a b c d) = Four (Four a b c d) (Three b c d) (Two c d) (One d)
+
+initsDigit :: Digit a -> Digit (Digit a)
+initsDigit (One a) = One (One a)
+initsDigit (Two a b) = Two (One a) (Two a b)
+initsDigit (Three a b c) = Three (One a) (Two a b) (Three a b c)
+initsDigit (Four a b c d) = Four (One a) (Two a b) (Three a b c) (Four a b c d)
+
+tailsNode :: Node a -> Node (Digit a)
+tailsNode (Node2 s a b) = Node2 s (Two a b) (One b)
+tailsNode (Node3 s a b c) = Node3 s (Three a b c) (Two b c) (One c)
+
+initsNode :: Node a -> Node (Digit a)
+initsNode (Node2 s a b) = Node2 s (One a) (Two a b)
+initsNode (Node3 s a b c) = Node3 s (One a) (Two a b) (Three a b c)
+
+{-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
+{-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
+-- | Given a function to apply to tails of a tree, applies that function
+-- to every tail of the specified tree.
+tailsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
+tailsTree _ Empty = Empty
+tailsTree f (Single x) = Single (f (Single x))
+tailsTree f (Deep n pr m sf) =
+ Deep n (fmap (\ pr' -> f (deep pr' m sf)) (tailsDigit pr))
+ (tailsTree f' m)
+ (fmap (f . digitToTree) (tailsDigit sf))
+ where
+ f' ms = let Just2 node m' = viewLTree ms in
+ fmap (\ pr' -> f (deep pr' m' sf)) (tailsNode node)
+
+{-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
+{-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
+-- | Given a function to apply to inits of a tree, applies that function
+-- to every init of the specified tree.
+initsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
+initsTree _ Empty = Empty
+initsTree f (Single x) = Single (f (Single x))
+initsTree f (Deep n pr m sf) =
+ Deep n (fmap (f . digitToTree) (initsDigit pr))
+ (initsTree f' m)
+ (fmap (f . deep pr m) (initsDigit sf))
+ where
+ f' ms = let Just2 m' node = viewRTree ms in
+ fmap (\ sf' -> f (deep pr m' sf')) (initsNode node)
+
+{-# INLINE foldlWithIndex #-}
+-- | 'foldlWithIndex' is a version of 'foldl' that also provides access
+-- to the index of each element.
+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
+foldlWithIndex f z xs = foldl (\ g x i -> i `seq` f (g (i - 1)) i x) (const z) xs (length xs - 1)
+
+{-# INLINE foldrWithIndex #-}
+-- | 'foldrWithIndex' is a version of 'foldr' that also provides access
+-- to the index of each element.
+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
+foldrWithIndex f z xs = foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0
+
+{-# INLINE listToMaybe' #-}
+-- 'listToMaybe\'' is a good consumer version of 'listToMaybe'.
+listToMaybe' :: [a] -> Maybe a
+listToMaybe' = foldr (\ x _ -> Just x) Nothing
+
+-- | /O(i)/ where /i/ is the prefix length. 'takeWhileL', applied
+-- to a predicate @p@ and a sequence @xs@, returns the longest prefix
+-- (possibly empty) of @xs@ of elements that satisfy @p@.
+takeWhileL :: (a -> Bool) -> Seq a -> Seq a
+takeWhileL p = fst . spanl p
+
+-- | /O(i)/ where /i/ is the suffix length. 'takeWhileR', applied
+-- to a predicate @p@ and a sequence @xs@, returns the longest suffix
+-- (possibly empty) of @xs@ of elements that satisfy @p@.
+--
+-- @'takeWhileR' p xs@ is equivalent to @'reverse' ('takeWhileL' p ('reverse' xs))@.
+takeWhileR :: (a -> Bool) -> Seq a -> Seq a
+takeWhileR p = fst . spanr p
+
+-- | /O(i)/ where /i/ is the prefix length. @'dropWhileL' p xs@ returns
+-- the suffix remaining after @'takeWhileL' p xs@.
+dropWhileL :: (a -> Bool) -> Seq a -> Seq a
+dropWhileL p = snd . spanl p
+
+-- | /O(i)/ where /i/ is the suffix length. @'dropWhileR' p xs@ returns
+-- the prefix remaining after @'takeWhileR' p xs@.
+--
+-- @'dropWhileR' p xs@ is equivalent to @'reverse' ('dropWhileL' p ('reverse' xs))@.
+dropWhileR :: (a -> Bool) -> Seq a -> Seq a
+dropWhileR p = snd . spanr p
+
+-- | /O(i)/ where /i/ is the prefix length. 'spanl', applied to
+-- a predicate @p@ and a sequence @xs@, returns a pair whose first
+-- element is the longest prefix (possibly empty) of @xs@ of elements that
+-- satisfy @p@ and the second element is the remainder of the sequence.
+spanl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+spanl p = breakl (not . p)
+
+-- | /O(i)/ where /i/ is the suffix length. 'spanr', applied to a
+-- predicate @p@ and a sequence @xs@, returns a pair whose /first/ element
+-- is the longest /suffix/ (possibly empty) of @xs@ of elements that
+-- satisfy @p@ and the second element is the remainder of the sequence.
+spanr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+spanr p = breakr (not . p)
+
+{-# INLINE breakl #-}
+-- | /O(i)/ where /i/ is the breakpoint index. 'breakl', applied to a
+-- predicate @p@ and a sequence @xs@, returns a pair whose first element
+-- is the longest prefix (possibly empty) of @xs@ of elements that
+-- /do not satisfy/ @p@ and the second element is the remainder of
+-- the sequence.
+--
+-- @'breakl' p@ is equivalent to @'spanl' (not . p)@.
+breakl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+breakl p xs = foldr (\ i _ -> splitAt i xs) (xs, empty) (findIndicesL p xs)
+
+{-# INLINE breakr #-}
+-- | @'breakr' p@ is equivalent to @'spanr' (not . p)@.
+breakr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+breakr p xs = foldr (\ i _ -> flipPair (splitAt (i + 1) xs)) (xs, empty) (findIndicesR p xs)
+ where flipPair (x, y) = (y, x)
+
+-- | /O(n)/. The 'partition' function takes a predicate @p@ and a
+-- sequence @xs@ and returns sequences of those elements which do and
+-- do not satisfy the predicate.
+partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
+partition p = foldl part (empty, empty)
+ where
+ part (xs, ys) x
+ | p x = (xs |> x, ys)
+ | otherwise = (xs, ys |> x)
+
+-- | /O(n)/. The 'filter' function takes a predicate @p@ and a sequence
+-- @xs@ and returns a sequence of those elements which satisfy the
+-- predicate.
+filter :: (a -> Bool) -> Seq a -> Seq a
+filter p = foldl (\ xs x -> if p x then xs |> x else xs) empty
+
+-- Indexing sequences
+
+-- | 'elemIndexL' finds the leftmost index of the specified element,
+-- if it is present, and otherwise 'Nothing'.
+elemIndexL :: Eq a => a -> Seq a -> Maybe Int
+elemIndexL x = findIndexL (x ==)
+
+-- | 'elemIndexR' finds the rightmost index of the specified element,
+-- if it is present, and otherwise 'Nothing'.
+elemIndexR :: Eq a => a -> Seq a -> Maybe Int
+elemIndexR x = findIndexR (x ==)
+
+-- | 'elemIndicesL' finds the indices of the specified element, from
+-- left to right (i.e. in ascending order).
+elemIndicesL :: Eq a => a -> Seq a -> [Int]
+elemIndicesL x = findIndicesL (x ==)
+
+-- | 'elemIndicesR' finds the indices of the specified element, from
+-- right to left (i.e. in descending order).
+elemIndicesR :: Eq a => a -> Seq a -> [Int]
+elemIndicesR x = findIndicesR (x ==)
+
+-- | @'findIndexL' p xs@ finds the index of the leftmost element that
+-- satisfies @p@, if any exist.
+findIndexL :: (a -> Bool) -> Seq a -> Maybe Int
+findIndexL p = listToMaybe' . findIndicesL p
+
+-- | @'findIndexR' p xs@ finds the index of the rightmost element that
+-- satisfies @p@, if any exist.
+findIndexR :: (a -> Bool) -> Seq a -> Maybe Int
+findIndexR p = listToMaybe' . findIndicesR p
+
+{-# INLINE findIndicesL #-}
+-- | @'findIndicesL' p@ finds all indices of elements that satisfy @p@,
+-- in ascending order.
+findIndicesL :: (a -> Bool) -> Seq a -> [Int]
+#if __GLASGOW_HASKELL__
+findIndicesL p xs = build (\ c n -> let g i x z = if p x then c i z else z in
+ foldrWithIndex g n xs)
+#else
+findIndicesL p xs = foldrWithIndex g [] xs
+ where g i x is = if p x then i:is else is
+#endif
+
+{-# INLINE findIndicesR #-}
+-- | @'findIndicesR' p@ finds all indices of elements that satisfy @p@,
+-- in descending order.
+findIndicesR :: (a -> Bool) -> Seq a -> [Int]
+#if __GLASGOW_HASKELL__
+findIndicesR p xs = build (\ c n ->
+ let g z i x = if p x then c i z else z in foldlWithIndex g n xs)
+#else
+findIndicesR p xs = foldlWithIndex g [] xs
+ where g is i x = if p x then i:is else is
+#endif
+
+------------------------------------------------------------------------
+-- Lists
+------------------------------------------------------------------------
+
+-- | /O(n)/. Create a sequence from a finite list of elements.
+-- There is a function 'toList' in the opposite direction for all
+-- instances of the 'Foldable' class, including 'Seq'.
+fromList :: [a] -> Seq a
+fromList = Data.List.foldl' (|>) empty
+
+------------------------------------------------------------------------
+-- Reverse
+------------------------------------------------------------------------
+
+-- | /O(n)/. The reverse of a sequence.
+reverse :: Seq a -> Seq a
+reverse (Seq xs) = Seq (reverseTree id xs)
+
+reverseTree :: (a -> a) -> FingerTree a -> FingerTree a
+reverseTree _ Empty = Empty
+reverseTree f (Single x) = Single (f x)
+reverseTree f (Deep s pr m sf) =
+ Deep s (reverseDigit f sf)
+ (reverseTree (reverseNode f) m)
+ (reverseDigit f pr)
+
+{-# INLINE reverseDigit #-}
+reverseDigit :: (a -> a) -> Digit a -> Digit a
+reverseDigit f (One a) = One (f a)
+reverseDigit f (Two a b) = Two (f b) (f a)
+reverseDigit f (Three a b c) = Three (f c) (f b) (f a)
+reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)
+
+reverseNode :: (a -> a) -> Node a -> Node a
+reverseNode f (Node2 s a b) = Node2 s (f b) (f a)
+reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)
+
+------------------------------------------------------------------------
+-- Zipping
+------------------------------------------------------------------------
+
+-- | /O(min(n1,n2))/. 'zip' takes two sequences and returns a sequence
+-- of corresponding pairs. If one input is short, excess elements are
+-- discarded from the right end of the longer sequence.
+zip :: Seq a -> Seq b -> Seq (a, b)
+zip = zipWith (,)
+
+-- | /O(min(n1,n2))/. 'zipWith' generalizes 'zip' by zipping with the
+-- function given as the first argument, instead of a tupling function.
+-- For example, @zipWith (+)@ is applied to two sequences to take the
+-- sequence of corresponding sums.
+zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
+zipWith f xs ys
+ | length xs <= length ys = zipWith' f xs ys
+ | otherwise = zipWith' (flip f) ys xs
+
+-- like 'zipWith', but assumes length xs <= length ys
+zipWith' :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
+zipWith' f xs ys = snd (mapAccumL k ys xs)
+ where
+ k kys x = case viewl kys of
+ (z :< zs) -> (zs, f x z)
+ EmptyL -> error "zipWith': unexpected EmptyL"
+
+-- | /O(min(n1,n2,n3))/. 'zip3' takes three sequences and returns a
+-- sequence of triples, analogous to 'zip'.
+zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
+zip3 = zipWith3 (,,)
+
+-- | /O(min(n1,n2,n3))/. 'zipWith3' takes a function which combines
+-- three elements, as well as three sequences and returns a sequence of
+-- their point-wise combinations, analogous to 'zipWith'.
+zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
+zipWith3 f s1 s2 s3 = zipWith ($) (zipWith f s1 s2) s3
+
+-- | /O(min(n1,n2,n3,n4))/. 'zip4' takes four sequences and returns a
+-- sequence of quadruples, analogous to 'zip'.
+zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d)
+zip4 = zipWith4 (,,,)
+
+-- | /O(min(n1,n2,n3,n4))/. 'zipWith4' takes a function which combines
+-- four elements, as well as four sequences and returns a sequence of
+-- their point-wise combinations, analogous to 'zipWith'.
+zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
+zipWith4 f s1 s2 s3 s4 = zipWith ($) (zipWith ($) (zipWith f s1 s2) s3) s4
+
+------------------------------------------------------------------------
+-- Sorting
+--
+-- sort and sortBy are implemented by simple deforestations of
+-- \ xs -> fromList2 (length xs) . Data.List.sortBy cmp . toList
+-- which does not get deforested automatically, it would appear.
+--
+-- Unstable sorting is performed by a heap sort implementation based on
+-- pairing heaps. Because the internal structure of sequences is quite
+-- varied, it is difficult to get blocks of elements of roughly the same
+-- length, which would improve merge sort performance. Pairing heaps,
+-- on the other hand, are relatively resistant to the effects of merging
+-- heaps of wildly different sizes, as guaranteed by its amortized
+-- constant-time merge operation. Moreover, extensive use of SpecConstr
+-- transformations can be done on pairing heaps, especially when we're
+-- only constructing them to immediately be unrolled.
+--
+-- On purely random sequences of length 50000, with no RTS options,
+-- I get the following statistics, in which heapsort is about 42.5%
+-- faster: (all comparisons done with -O2)
+--
+-- Times (ms) min mean +/-sd median max
+-- to/from list: 103.802 108.572 7.487 106.436 143.339
+-- unstable heapsort: 60.686 62.968 4.275 61.187 79.151
+--
+-- Heapsort, it would seem, is less of a memory hog than Data.List.sortBy.
+-- The gap is narrowed when more memory is available, but heapsort still
+-- wins, 15% faster, with +RTS -H128m:
+--
+-- Times (ms) min mean +/-sd median max
+-- to/from list: 42.692 45.074 2.596 44.600 56.601
+-- unstable heapsort: 37.100 38.344 3.043 37.715 55.526
+--
+-- In addition, on strictly increasing sequences the gap is even wider
+-- than normal; heapsort is 68.5% faster with no RTS options:
+-- Times (ms) min mean +/-sd median max
+-- to/from list: 52.236 53.574 1.987 53.034 62.098
+-- unstable heapsort: 16.433 16.919 0.931 16.681 21.622
+--
+-- This may be attributed to the elegant nature of the pairing heap.
+--
+-- wasserman.louis@gmail.com, 7/20/09
+------------------------------------------------------------------------
+
+-- | /O(n log n)/. 'sort' sorts the specified 'Seq' by the natural
+-- ordering of its elements. The sort is stable.
+-- If stability is not required, 'unstableSort' can be considerably
+-- faster, and in particular uses less memory.
+sort :: Ord a => Seq a -> Seq a
+sort = sortBy compare
+
+-- | /O(n log n)/. 'sortBy' sorts the specified 'Seq' according to the
+-- specified comparator. The sort is stable.
+-- If stability is not required, 'unstableSortBy' can be considerably
+-- faster, and in particular uses less memory.
+sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
+sortBy cmp xs = fromList2 (length xs) (Data.List.sortBy cmp (toList xs))
+
+-- | /O(n log n)/. 'unstableSort' sorts the specified 'Seq' by
+-- the natural ordering of its elements, but the sort is not stable.
+-- This algorithm is frequently faster and uses less memory than 'sort',
+-- and performs extremely well -- frequently twice as fast as 'sort' --
+-- when the sequence is already nearly sorted.
+unstableSort :: Ord a => Seq a -> Seq a
+unstableSort = unstableSortBy compare
+
+-- | /O(n log n)/. A generalization of 'unstableSort', 'unstableSortBy'
+-- takes an arbitrary comparator and sorts the specified sequence.
+-- The sort is not stable. This algorithm is frequently faster and
+-- uses less memory than 'sortBy', and performs extremely well --
+-- frequently twice as fast as 'sortBy' -- when the sequence is already
+-- nearly sorted.
+unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
+unstableSortBy cmp (Seq xs) =
+ fromList2 (size xs) $ maybe [] (unrollPQ cmp) $
+ toPQ cmp (\ (Elem x) -> PQueue x Nil) xs
+
+-- | fromList2, given a list and its length, constructs a completely
+-- balanced Seq whose elements are that list using the applicativeTree
+-- generalization.
+fromList2 :: Int -> [a] -> Seq a
+fromList2 n = execState (replicateA n (State ht))
+ where
+ ht (x:xs) = (xs, x)
+ ht [] = error "fromList2: short list"
+
+-- | A 'PQueue' is a simple pairing heap.
+data PQueue e = PQueue e (PQL e)
+data PQL e = Nil | {-# UNPACK #-} !(PQueue e) :& PQL e
+
+infixr 8 :&
+
+#if TESTING
+
+instance Functor PQueue where
+ fmap f (PQueue x ts) = PQueue (f x) (fmap f ts)
+
+instance Functor PQL where
+ fmap f (q :& qs) = fmap f q :& fmap f qs
+ fmap _ Nil = Nil
+
+instance Show e => Show (PQueue e) where
+ show = unlines . draw . fmap show
+
+-- borrowed wholesale from Data.Tree, as Data.Tree actually depends
+-- on Data.Sequence
+draw :: PQueue String -> [String]
+draw (PQueue x ts0) = x : drawSubTrees ts0
+ where
+ drawSubTrees Nil = []
+ drawSubTrees (t :& Nil) =
+ "|" : shift "`- " " " (draw t)
+ drawSubTrees (t :& ts) =
+ "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts
+
+ shift first other = Data.List.zipWith (++) (first : repeat other)
+#endif
+
+-- | 'unrollPQ', given a comparator function, unrolls a 'PQueue' into
+-- a sorted list.
+unrollPQ :: (e -> e -> Ordering) -> PQueue e -> [e]
+unrollPQ cmp = unrollPQ'
+ where
+ {-# INLINE unrollPQ' #-}
+ unrollPQ' (PQueue x ts) = x:mergePQs0 ts
+ (<>) = mergePQ cmp
+ mergePQs0 Nil = []
+ mergePQs0 (t :& Nil) = unrollPQ' t
+ mergePQs0 (t1 :& t2 :& ts) = mergePQs (t1 <> t2) ts
+ mergePQs t ts = t `seq` case ts of
+ Nil -> unrollPQ' t
+ t1 :& Nil -> unrollPQ' (t <> t1)
+ t1 :& t2 :& ts' -> mergePQs (t <> (t1 <> t2)) ts'
+
+-- | 'toPQ', given an ordering function and a mechanism for queueifying
+-- elements, converts a 'FingerTree' to a 'PQueue'.
+toPQ :: (e -> e -> Ordering) -> (a -> PQueue e) -> FingerTree a -> Maybe (PQueue e)
+toPQ _ _ Empty = Nothing
+toPQ _ f (Single x) = Just (f x)
+toPQ cmp f (Deep _ pr m sf) = Just (maybe (pr' <> sf') ((pr' <> sf') <>) (toPQ cmp fNode m))
+ where
+ fDigit digit = case fmap f digit of
+ One a -> a
+ Two a b -> a <> b
+ Three a b c -> a <> b <> c
+ Four a b c d -> (a <> b) <> (c <> d)
+ (<>) = mergePQ cmp
+ fNode = fDigit . nodeToDigit
+ pr' = fDigit pr
+ sf' = fDigit sf
+
+-- | 'mergePQ' merges two 'PQueue's.
+mergePQ :: (a -> a -> Ordering) -> PQueue a -> PQueue a -> PQueue a
+mergePQ cmp q1@(PQueue x1 ts1) q2@(PQueue x2 ts2)
+ | cmp x1 x2 == GT = PQueue x2 (q1 :& ts2)
+ | otherwise = PQueue x1 (q2 :& ts1)
+
+#if TESTING
+
+------------------------------------------------------------------------
+-- QuickCheck
+------------------------------------------------------------------------
+
+instance Arbitrary a => Arbitrary (Seq a) where
+ arbitrary = Seq <$> arbitrary
+ shrink (Seq x) = map Seq (shrink x)
+
+instance Arbitrary a => Arbitrary (Elem a) where
+ arbitrary = Elem <$> arbitrary
+
+instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where
+ arbitrary = sized arb
+ where
+ arb :: (Arbitrary a, Sized a) => Int -> Gen (FingerTree a)
+ arb 0 = return Empty
+ arb 1 = Single <$> arbitrary
+ arb n = deep <$> arbitrary <*> arb (n `div` 2) <*> arbitrary
+
+ shrink (Deep _ (One a) Empty (One b)) = [Single a, Single b]
+ shrink (Deep _ pr m sf) =
+ [deep pr' m sf | pr' <- shrink pr] ++
+ [deep pr m' sf | m' <- shrink m] ++
+ [deep pr m sf' | sf' <- shrink sf]
+ shrink (Single x) = map Single (shrink x)
+ shrink Empty = []
+
+instance (Arbitrary a, Sized a) => Arbitrary (Node a) where
+ arbitrary = oneof [
+ node2 <$> arbitrary <*> arbitrary,
+ node3 <$> arbitrary <*> arbitrary <*> arbitrary]
+
+ shrink (Node2 _ a b) =
+ [node2 a' b | a' <- shrink a] ++
+ [node2 a b' | b' <- shrink b]
+ shrink (Node3 _ a b c) =
+ [node2 a b, node2 a c, node2 b c] ++
+ [node3 a' b c | a' <- shrink a] ++
+ [node3 a b' c | b' <- shrink b] ++
+ [node3 a b c' | c' <- shrink c]
+
+instance Arbitrary a => Arbitrary (Digit a) where
+ arbitrary = oneof [
+ One <$> arbitrary,
+ Two <$> arbitrary <*> arbitrary,
+ Three <$> arbitrary <*> arbitrary <*> arbitrary,
+ Four <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary]
+
+ shrink (One a) = map One (shrink a)
+ shrink (Two a b) = [One a, One b]
+ shrink (Three a b c) = [Two a b, Two a c, Two b c]
+ shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d]
+
+------------------------------------------------------------------------
+-- Valid trees
+------------------------------------------------------------------------
+
+class Valid a where
+ valid :: a -> Bool
+
+instance Valid (Elem a) where
+ valid _ = True
+
+instance Valid (Seq a) where
+ valid (Seq xs) = valid xs
+
+instance (Sized a, Valid a) => Valid (FingerTree a) where
+ valid Empty = True
+ valid (Single x) = valid x
+ valid (Deep s pr m sf) =
+ s == size pr + size m + size sf && valid pr && valid m && valid sf
+
+instance (Sized a, Valid a) => Valid (Node a) where
+ valid node = size node == sum (fmap size node) && all valid node
+
+instance Valid a => Valid (Digit a) where
+ valid = all valid
#endif
diff --git a/Data/Set.hs b/Data/Set.hs
--- a/Data/Set.hs
+++ b/Data/Set.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS -cpp #-}
+{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Set
@@ -20,12 +20,12 @@
-- trees of /bounded balance/) as described by:
--
-- * Stephen Adams, \"/Efficient sets: a balancing act/\",
--- Journal of Functional Programming 3(4):553-562, October 1993,
--- .
+-- Journal of Functional Programming 3(4):553-562, October 1993,
+-- .
--
-- * J. Nievergelt and E.M. Reingold,
--- \"/Binary search trees of bounded balance/\",
--- SIAM journal of computing 2(1), March 1973.
+-- \"/Binary search trees of bounded balance/\",
+-- SIAM journal of computing 2(1), March 1973.
--
-- Note that the implementation is /left-biased/ -- the elements of a
-- first argument are always preferred to the second, for example in
@@ -34,9 +34,28 @@
-- equality.
-----------------------------------------------------------------------------
-module Data.Set (
+-- It is crucial to the performance that the functions specialize on the Ord
+-- type when possible. GHC 7.0 and higher does this by itself when it sees th
+-- unfolding of a function -- that is why all public functions are marked
+-- INLINABLE (that exposes the unfolding).
+--
+-- For other compilers and GHC pre 7.0, we mark some of the functions INLINE.
+-- We mark the functions that just navigate down the tree (lookup, insert,
+-- delete and similar). That navigation code gets inlined and thus specialized
+-- when possible. There is a price to pay -- code growth. The code INLINED is
+-- therefore only the tree navigation, all the real work (rebalancing) is not
+-- INLINED by using a NOINLINE.
+--
+-- All methods that can be INLINE are not recursive -- a 'go' function doing
+-- the real work is provided.
+
+module Data.Set (
-- * Set type
+#if !defined(TESTING)
Set -- instance Eq,Ord,Show,Read,Data,Typeable
+#else
+ Set(..)
+#endif
-- * Operators
, (\\)
@@ -48,18 +67,19 @@
, notMember
, isSubsetOf
, isProperSubsetOf
-
+
-- * Construction
, empty
, singleton
, insert
, delete
-
+
-- * Combine
- , union, unions
+ , union
+ , unions
, difference
, intersection
-
+
-- * Filter
, filter
, partition
@@ -67,8 +87,8 @@
, splitMember
-- * Map
- , map
- , mapMonotonic
+ , map
+ , mapMonotonic
-- * Fold
, fold
@@ -89,26 +109,31 @@
, elems
, toList
, fromList
-
+
-- ** Ordered list
, toAscList
, fromAscList
, fromDistinctAscList
-
+
-- * Debugging
, showTree
, showTreeWith
, valid
+
+#if defined(TESTING)
+ -- Internals (for testing)
+ , bin
+ , balanced
+ , join
+ , merge
+#endif
) where
import Prelude hiding (filter,foldr,null,map)
import qualified Data.List as List
import Data.Monoid (Monoid(..))
import Data.Foldable (Foldable(foldMap))
-#ifndef __GLASGOW_HASKELL__
-import Data.Typeable (Typeable, typeOf, typeOfDefault)
-#endif
-import Data.Typeable (Typeable1(..), TyCon, mkTyCon, mkTyConApp)
+import Data.Typeable
{-
-- just for testing
@@ -119,9 +144,15 @@
#if __GLASGOW_HASKELL__
import Text.Read
-import Data.Data (Data(..), mkNoRepType, gcast1)
+import Data.Data
#endif
+-- Use macros to define strictness of functions.
+-- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.
+-- We do not use BangPatterns, because they are not in any standard and we
+-- want the compilers to be compiled by as many compilers as possible.
+#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined
+
{--------------------------------------------------------------------
Operators
--------------------------------------------------------------------}
@@ -130,13 +161,16 @@
-- | /O(n+m)/. See 'difference'.
(\\) :: Ord a => Set a -> Set a -> Set a
m1 \\ m2 = difference m1 m2
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE (\\) #-}
+#endif
{--------------------------------------------------------------------
Sets are size balanced trees
--------------------------------------------------------------------}
-- | A set of values @a@.
data Set a = Tip
- | Bin {-# UNPACK #-} !Size a !(Set a) !(Set a)
+ | Bin {-# UNPACK #-} !Size !a !(Set a) !(Set a)
type Size = Int
@@ -172,45 +206,51 @@
--------------------------------------------------------------------}
-- | /O(1)/. Is this the empty set?
null :: Set a -> Bool
-null t
- = case t of
- Tip -> True
- Bin {} -> False
+null Tip = True
+null (Bin {}) = False
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE null #-}
+#endif
-- | /O(1)/. The number of elements in the set.
size :: Set a -> Int
-size t
- = case t of
- Tip -> 0
- Bin sz _ _ _ -> sz
+size Tip = 0
+size (Bin sz _ _ _) = sz
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE size #-}
+#endif
-- | /O(log n)/. Is the element in the set?
member :: Ord a => a -> Set a -> Bool
-member x t
- = case t of
- Tip -> False
- Bin _ y l r
- -> case compare x y of
- LT -> member x l
- GT -> member x r
- EQ -> True
+member = go
+ where
+ STRICT_1_OF_2(go)
+ go _ Tip = False
+ go x (Bin _ y l r) = case compare x y of
+ LT -> go x l
+ GT -> go x r
+ EQ -> True
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE member #-}
+#else
+{-# INLINE member #-}
+#endif
-- | /O(log n)/. Is the element not in the set?
notMember :: Ord a => a -> Set a -> Bool
-notMember x t = not $ member x t
+notMember a t = not $ member a t
+{-# INLINE notMember #-}
{--------------------------------------------------------------------
Construction
--------------------------------------------------------------------}
-- | /O(1)/. The empty set.
empty :: Set a
-empty
- = Tip
+empty = Tip
-- | /O(1)/. Create a singleton set.
singleton :: a -> Set a
-singleton x
- = Bin 1 x Tip Tip
+singleton x = Bin 1 x Tip Tip
{--------------------------------------------------------------------
Insertion, Deletion
@@ -219,26 +259,52 @@
-- If the set already contains an element equal to the given value,
-- it is replaced with the new value.
insert :: Ord a => a -> Set a -> Set a
-insert x t
- = case t of
- Tip -> singleton x
- Bin sz y l r
- -> case compare x y of
- LT -> balance y (insert x l) r
- GT -> balance y l (insert x r)
- EQ -> Bin sz x l r
+insert = go
+ where
+ STRICT_1_OF_2(go)
+ go x Tip = singleton x
+ go x (Bin sz y l r) = case compare x y of
+ LT -> balanceL y (go x l) r
+ GT -> balanceR y l (go x r)
+ EQ -> Bin sz x l r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINEABLE insert #-}
+#else
+{-# INLINE insert #-}
+#endif
+-- Insert an element to the set only if it is not in the set. Used by
+-- `union`.
+insertR :: Ord a => a -> Set a -> Set a
+insertR = go
+ where
+ STRICT_1_OF_2(go)
+ go x Tip = singleton x
+ go x t@(Bin _ y l r) = case compare x y of
+ LT -> balanceL y (go x l) r
+ GT -> balanceR y l (go x r)
+ EQ -> t
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINEABLE insertR #-}
+#else
+{-# INLINE insertR #-}
+#endif
-- | /O(log n)/. Delete an element from a set.
delete :: Ord a => a -> Set a -> Set a
-delete x t
- = case t of
- Tip -> Tip
- Bin _ y l r
- -> case compare x y of
- LT -> balance y (delete x l) r
- GT -> balance y l (delete x r)
- EQ -> glue l r
+delete = go
+ where
+ STRICT_1_OF_2(go)
+ go _ Tip = Tip
+ go x (Bin _ y l r) = case compare x y of
+ LT -> balanceR y (go x l) r
+ GT -> balanceL y l (go x r)
+ EQ -> glue l r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINEABLE delete #-}
+#else
+{-# INLINE delete #-}
+#endif
{--------------------------------------------------------------------
Subset
@@ -247,6 +313,9 @@
isProperSubsetOf :: Ord a => Set a -> Set a -> Bool
isProperSubsetOf s1 s2
= (size s1 < size s2) && (isSubsetOf s1 s2)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE isProperSubsetOf #-}
+#endif
-- | /O(n+m)/. Is this a subset?
@@ -254,6 +323,9 @@
isSubsetOf :: Ord a => Set a -> Set a -> Bool
isSubsetOf t1 t2
= (size t1 <= size t2) && (isSubsetOfX t1 t2)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE isSubsetOf #-}
+#endif
isSubsetOfX :: Ord a => Set a -> Set a -> Bool
isSubsetOfX Tip _ = True
@@ -262,6 +334,9 @@
= found && isSubsetOfX l lt && isSubsetOfX r gt
where
(lt,found,gt) = splitMember x t
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE isSubsetOfX #-}
+#endif
{--------------------------------------------------------------------
@@ -272,34 +347,46 @@
findMin (Bin _ x Tip _) = x
findMin (Bin _ _ l _) = findMin l
findMin Tip = error "Set.findMin: empty set has no minimal element"
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE findMin #-}
+#endif
-- | /O(log n)/. The maximal element of a set.
findMax :: Set a -> a
findMax (Bin _ x _ Tip) = x
findMax (Bin _ _ _ r) = findMax r
findMax Tip = error "Set.findMax: empty set has no maximal element"
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE findMax #-}
+#endif
-- | /O(log n)/. Delete the minimal element.
deleteMin :: Set a -> Set a
deleteMin (Bin _ _ Tip r) = r
-deleteMin (Bin _ x l r) = balance x (deleteMin l) r
+deleteMin (Bin _ x l r) = balanceR x (deleteMin l) r
deleteMin Tip = Tip
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE deleteMin #-}
+#endif
-- | /O(log n)/. Delete the maximal element.
deleteMax :: Set a -> Set a
deleteMax (Bin _ _ l Tip) = l
-deleteMax (Bin _ x l r) = balance x l (deleteMax r)
+deleteMax (Bin _ x l r) = balanceL x l (deleteMax r)
deleteMax Tip = Tip
-
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE deleteMax #-}
+#endif
{--------------------------------------------------------------------
Union.
--------------------------------------------------------------------}
-- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).
unions :: Ord a => [Set a] -> Set a
-unions ts
- = foldlStrict union empty ts
-
+unions = foldlStrict union empty
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE unions #-}
+#endif
-- | /O(n+m)/. The union of two sets, preferring the first set when
-- equal elements are encountered.
@@ -308,19 +395,27 @@
union :: Ord a => Set a -> Set a -> Set a
union Tip t2 = t2
union t1 Tip = t1
-union t1 t2 = hedgeUnion (const LT) (const GT) t1 t2
+union (Bin _ x Tip Tip) t = insert x t
+union t (Bin _ x Tip Tip) = insertR x t
+union t1 t2 = hedgeUnion NothingS NothingS t1 t2
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE union #-}
+#endif
hedgeUnion :: Ord a
- => (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a -> Set a
+ => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a
hedgeUnion _ _ t1 Tip
= t1
-hedgeUnion cmplo cmphi Tip (Bin _ x l r)
- = join x (filterGt cmplo l) (filterLt cmphi r)
-hedgeUnion cmplo cmphi (Bin _ x l r) t2
- = join x (hedgeUnion cmplo cmpx l (trim cmplo cmpx t2))
- (hedgeUnion cmpx cmphi r (trim cmpx cmphi t2))
+hedgeUnion blo bhi Tip (Bin _ x l r)
+ = join x (filterGt blo l) (filterLt bhi r)
+hedgeUnion blo bhi (Bin _ x l r) t2
+ = join x (hedgeUnion blo bmi l (trim blo bmi t2))
+ (hedgeUnion bmi bhi r (trim bmi bhi t2))
where
- cmpx y = compare x y
+ bmi = JustS x
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE hedgeUnion #-}
+#endif
{--------------------------------------------------------------------
Difference
@@ -330,19 +425,25 @@
difference :: Ord a => Set a -> Set a -> Set a
difference Tip _ = Tip
difference t1 Tip = t1
-difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
+difference t1 t2 = hedgeDiff NothingS NothingS t1 t2
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE difference #-}
+#endif
hedgeDiff :: Ord a
- => (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a -> Set a
+ => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a
hedgeDiff _ _ Tip _
= Tip
-hedgeDiff cmplo cmphi (Bin _ x l r) Tip
- = join x (filterGt cmplo l) (filterLt cmphi r)
-hedgeDiff cmplo cmphi t (Bin _ x l r)
- = merge (hedgeDiff cmplo cmpx (trim cmplo cmpx t) l)
- (hedgeDiff cmpx cmphi (trim cmpx cmphi t) r)
+hedgeDiff blo bhi (Bin _ x l r) Tip
+ = join x (filterGt blo l) (filterLt bhi r)
+hedgeDiff blo bhi t (Bin _ x l r)
+ = merge (hedgeDiff blo bmi (trim blo bmi t) l)
+ (hedgeDiff bmi bhi (trim bmi bhi t) r)
where
- cmpx y = compare x y
+ bmi = JustS x
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE hedgeDiff #-}
+#endif
{--------------------------------------------------------------------
Intersection
@@ -374,6 +475,9 @@
tr = intersection r1 gt
in if found then join x1 tl tr
else merge tl tr
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE intersection #-}
+#endif
{--------------------------------------------------------------------
Filter and partition
@@ -382,20 +486,24 @@
filter :: Ord a => (a -> Bool) -> Set a -> Set a
filter _ Tip = Tip
filter p (Bin _ x l r)
- | p x = join x (filter p l) (filter p r)
- | otherwise = merge (filter p l) (filter p r)
+ | p x = join x (filter p l) (filter p r)
+ | otherwise = merge (filter p l) (filter p r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE filter #-}
+#endif
-- | /O(n)/. Partition the set into two sets, one with all elements that satisfy
-- the predicate and one with all elements that don't satisfy the predicate.
-- See also 'split'.
partition :: Ord a => (a -> Bool) -> Set a -> (Set a,Set a)
-partition _ Tip = (Tip,Tip)
-partition p (Bin _ x l r)
- | p x = (join x l1 r1,merge l2 r2)
- | otherwise = (merge l1 r1,join x l2 r2)
- where
- (l1,l2) = partition p l
- (r1,r2) = partition p r
+partition _ Tip = (Tip, Tip)
+partition p (Bin _ x l r) = case (partition p l, partition p r) of
+ ((l1, l2), (r1, r2))
+ | p x -> (join x l1 r1, merge l2 r2)
+ | otherwise -> (merge l1 r1, join x l2 r2)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE partition #-}
+#endif
{----------------------------------------------------------------------
Map
@@ -409,6 +517,9 @@
map :: (Ord a, Ord b) => (a->b) -> Set a -> Set b
map f = fromList . List.map f . toList
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE map #-}
+#endif
-- | /O(n)/. The
--
@@ -422,51 +533,62 @@
mapMonotonic :: (a->b) -> Set a -> Set b
mapMonotonic _ Tip = Tip
-mapMonotonic f (Bin sz x l r) =
- Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)
-
+mapMonotonic f (Bin sz x l r) = Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE mapMonotonic #-}
+#endif
{--------------------------------------------------------------------
Fold
--------------------------------------------------------------------}
-- | /O(n)/. Fold over the elements of a set in an unspecified order.
fold :: (a -> b -> b) -> b -> Set a -> b
-fold f z s
- = foldr f z s
+fold = foldr
+{-# INLINE fold #-}
-- | /O(n)/. Post-order fold.
foldr :: (a -> b -> b) -> b -> Set a -> b
-foldr _ z Tip = z
-foldr f z (Bin _ x l r) = foldr f (f x (foldr f z r)) l
+foldr f = go
+ where
+ go z Tip = z
+ go z (Bin _ x l r) = go (f x (go z r)) l
+{-# INLINE foldr #-}
{--------------------------------------------------------------------
List variations
--------------------------------------------------------------------}
-- | /O(n)/. The elements of a set.
elems :: Set a -> [a]
-elems s
- = toList s
+elems = toList
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE elems #-}
+#endif
{--------------------------------------------------------------------
Lists
--------------------------------------------------------------------}
-- | /O(n)/. Convert the set to a list of elements.
toList :: Set a -> [a]
-toList s
- = toAscList s
+toList = toAscList
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE toList #-}
+#endif
-- | /O(n)/. Convert the set to an ascending list of elements.
toAscList :: Set a -> [a]
-toAscList t
- = foldr (:) [] t
-
+toAscList = foldr (:) []
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE toAscList #-}
+#endif
-- | /O(n*log n)/. Create a set from a list of elements.
fromList :: Ord a => [a] -> Set a
-fromList xs
- = foldlStrict ins empty xs
+fromList = foldlStrict ins empty
where
ins t x = insert x t
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE fromList #-}
+#endif
{--------------------------------------------------------------------
Building trees from ascending/descending lists can be done in linear time.
@@ -491,6 +613,9 @@
combineEq' z (x:xs')
| z==x = combineEq' z xs'
| otherwise = z:combineEq' x xs'
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE fromAscList #-}
+#endif
-- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.
@@ -514,6 +639,9 @@
buildR n c l (x:ys) = build (buildB l x c) n ys
buildR _ _ _ [] = error "fromDistinctAscList buildR []"
buildB l x c r zs = c (bin x l r) zs
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE fromDistinctAscList #-}
+#endif
{--------------------------------------------------------------------
Eq converts the set to a list. In a lazy setting, this
@@ -537,19 +665,6 @@
showsPrec p xs = showParen (p > 10) $
showString "fromList " . shows (toList xs)
-{-
-XXX unused code
-
-showSet :: (Show a) => [a] -> ShowS
-showSet []
- = showString "{}"
-showSet (x:xs)
- = showChar '{' . shows x . showTail xs
- where
- showTail [] = showChar '}'
- showTail (x':xs') = showChar ',' . shows x' . showTail xs'
--}
-
{--------------------------------------------------------------------
Read
--------------------------------------------------------------------}
@@ -577,14 +692,15 @@
{--------------------------------------------------------------------
Utility functions that return sub-ranges of the original
- tree. Some functions take a comparison function as argument to
- allow comparisons against infinite values. A function [cmplo x]
- should be read as [compare lo x].
+ tree. Some functions take a `Maybe value` as an argument to
+ allow comparisons against infinite values. These are called `blow`
+ (Nothing is -\infty) and `bhigh` (here Nothing is +\infty).
+ We use MaybeS value, which is a Maybe strict in the Just case.
- [trim cmplo cmphi t] A tree that is either empty or where [cmplo x == LT]
- and [cmphi x == GT] for the value [x] of the root.
- [filterGt cmp t] A tree where for all values [k]. [cmp k == LT]
- [filterLt cmp t] A tree where for all values [k]. [cmp k == GT]
+ [trim blow bhigh t] A tree that is either empty or where [x > blow]
+ and [x < bhigh] for the value [x] of the root.
+ [filterGt blow t] A tree where for all values [k]. [k > blow]
+ [filterLt bhigh t] A tree where for all values [k]. [k < bhigh]
[split k t] Returns two trees [l] and [r] where all values
in [l] are <[k] and all keys in [r] are >[k].
@@ -592,54 +708,53 @@
was found in the tree.
--------------------------------------------------------------------}
+data MaybeS a = NothingS | JustS !a
+
{--------------------------------------------------------------------
- [trim lo hi t] trims away all subtrees that surely contain no
- values between the range [lo] to [hi]. The returned tree is either
- empty or the key of the root is between @lo@ and @hi@.
+ [trim blo bhi t] trims away all subtrees that surely contain no
+ values between the range [blo] to [bhi]. The returned tree is either
+ empty or the key of the root is between @blo@ and @bhi@.
--------------------------------------------------------------------}
-trim :: (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a
-trim _ _ Tip = Tip
-trim cmplo cmphi t@(Bin _ x l r)
- = case cmplo x of
- LT -> case cmphi x of
- GT -> t
- _ -> trim cmplo cmphi l
- _ -> trim cmplo cmphi r
-
-{-
-XXX unused code
-
-trimMemberLo :: Ord a => a -> (a -> Ordering) -> Set a -> (Bool, Set a)
-trimMemberLo _ _ Tip = (False,Tip)
-trimMemberLo lo cmphi t@(Bin _ x l r)
- = case compare lo x of
- LT -> case cmphi x of
- GT -> (member lo t, t)
- _ -> trimMemberLo lo cmphi l
- GT -> trimMemberLo lo cmphi r
- EQ -> (True,trim (compare lo) cmphi r)
--}
+trim :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a
+trim NothingS NothingS t = t
+trim (JustS lx) NothingS t = greater lx t where greater lo (Bin _ x _ r) | x <= lo = greater lo r
+ greater _ t' = t'
+trim NothingS (JustS hx) t = lesser hx t where lesser hi (Bin _ x l _) | x >= hi = lesser hi l
+ lesser _ t' = t'
+trim (JustS lx) (JustS hx) t = middle lx hx t where middle lo hi (Bin _ x _ r) | x <= lo = middle lo hi r
+ middle lo hi (Bin _ x l _) | x >= hi = middle lo hi l
+ middle _ _ t' = t'
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE trim #-}
+#endif
{--------------------------------------------------------------------
- [filterGt x t] filter all values >[x] from tree [t]
- [filterLt x t] filter all values <[x] from tree [t]
+ [filterGt b t] filter all values >[b] from tree [t]
+ [filterLt b t] filter all values <[b] from tree [t]
--------------------------------------------------------------------}
-filterGt :: (a -> Ordering) -> Set a -> Set a
-filterGt _ Tip = Tip
-filterGt cmp (Bin _ x l r)
- = case cmp x of
- LT -> join x (filterGt cmp l) r
- GT -> filterGt cmp r
- EQ -> r
-
-filterLt :: (a -> Ordering) -> Set a -> Set a
-filterLt _ Tip = Tip
-filterLt cmp (Bin _ x l r)
- = case cmp x of
- LT -> filterLt cmp l
- GT -> join x l (filterLt cmp r)
- EQ -> l
+filterGt :: Ord a => MaybeS a -> Set a -> Set a
+filterGt NothingS t = t
+filterGt (JustS b) t = filter' b t
+ where filter' _ Tip = Tip
+ filter' b' (Bin _ x l r) =
+ case compare b' x of LT -> join x (filter' b' l) r
+ EQ -> r
+ GT -> filter' b' r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE filterGt #-}
+#endif
+filterLt :: Ord a => MaybeS a -> Set a -> Set a
+filterLt NothingS t = t
+filterLt (JustS b) t = filter' b t
+ where filter' _ Tip = Tip
+ filter' b' (Bin _ x l r) =
+ case compare x b' of LT -> join x l (filter' b' r)
+ EQ -> l
+ GT -> filter' b' l
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE filterLt #-}
+#endif
{--------------------------------------------------------------------
Split
@@ -654,12 +769,18 @@
LT -> let (lt,gt) = split x l in (lt,join y gt r)
GT -> let (lt,gt) = split x r in (join y l lt,gt)
EQ -> (l,r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE split #-}
+#endif
-- | /O(log n)/. Performs a 'split' but also returns whether the pivot
-- element was found in the original set.
splitMember :: Ord a => a -> Set a -> (Set a,Bool,Set a)
splitMember x t = let (l,m,r) = splitLookup x t in
(l,maybe False (const True) m,r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE splitMember #-}
+#endif
-- | /O(log n)/. Performs a 'split' but also returns the pivot
-- element that was found in the original set.
@@ -670,6 +791,9 @@
LT -> let (lt,found,gt) = splitLookup x l in (lt,found,join y gt r)
GT -> let (lt,found,gt) = splitLookup x r in (join y l lt,found,gt)
EQ -> (l,Just y,r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE splitLookup #-}
+#endif
{--------------------------------------------------------------------
Utility functions that maintain the balance properties of the tree.
@@ -707,9 +831,12 @@
join x Tip r = insertMin x r
join x l Tip = insertMax x l
join x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)
- | delta*sizeL <= sizeR = balance z (join x l lz) rz
- | delta*sizeR <= sizeL = balance y ly (join x ry r)
- | otherwise = bin x l r
+ | delta*sizeL < sizeR = balanceL z (join x l lz) rz
+ | delta*sizeR < sizeL = balanceR y ly (join x ry r)
+ | otherwise = bin x l r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE join #-}
+#endif
-- insertMin and insertMax don't perform potentially expensive comparisons.
@@ -718,14 +845,20 @@
= case t of
Tip -> singleton x
Bin _ y l r
- -> balance y l (insertMax x r)
-
+ -> balanceR y l (insertMax x r)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE insertMax #-}
+#endif
+
insertMin x t
= case t of
Tip -> singleton x
Bin _ y l r
- -> balance y (insertMin x l) r
-
+ -> balanceL y (insertMin x l) r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE insertMin #-}
+#endif
+
{--------------------------------------------------------------------
[merge l r]: merges two trees.
--------------------------------------------------------------------}
@@ -733,9 +866,12 @@
merge Tip r = r
merge l Tip = l
merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)
- | delta*sizeL <= sizeR = balance y (merge l ly) ry
- | delta*sizeR <= sizeL = balance x lx (merge rx r)
- | otherwise = glue l r
+ | delta*sizeL < sizeR = balanceL y (merge l ly) ry
+ | delta*sizeR < sizeL = balanceR x lx (merge rx r)
+ | otherwise = glue l r
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE merge #-}
+#endif
{--------------------------------------------------------------------
[glue l r]: glues two trees together.
@@ -745,8 +881,11 @@
glue Tip r = r
glue l Tip = l
glue l r
- | size l > size r = let (m,l') = deleteFindMax l in balance m l' r
- | otherwise = let (m,r') = deleteFindMin r in balance m l r'
+ | size l > size r = let (m,l') = deleteFindMax l in balanceR m l' r
+ | otherwise = let (m,r') = deleteFindMin r in balanceL m l r'
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE glue #-}
+#endif
-- | /O(log n)/. Delete and find the minimal element.
@@ -757,8 +896,11 @@
deleteFindMin t
= case t of
Bin _ x Tip r -> (x,r)
- Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balance x l' r)
+ Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balanceR x l' r)
Tip -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE deleteFindMin #-}
+#endif
-- | /O(log n)/. Delete and find the maximal element.
--
@@ -767,20 +909,29 @@
deleteFindMax t
= case t of
Bin _ x l Tip -> (x,l)
- Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balance x l r')
+ Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balanceL x l r')
Tip -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE deleteFindMax #-}
+#endif
-- | /O(log n)/. Retrieves the minimal key of the set, and the set
-- stripped of that element, or 'Nothing' if passed an empty set.
minView :: Set a -> Maybe (a, Set a)
minView Tip = Nothing
minView x = Just (deleteFindMin x)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE minView #-}
+#endif
-- | /O(log n)/. Retrieves the maximal key of the set, and the set
-- stripped of that element, or 'Nothing' if passed an empty set.
maxView :: Set a -> Maybe (a, Set a)
maxView Tip = Nothing
maxView x = Just (deleteFindMax x)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE maxView #-}
+#endif
{--------------------------------------------------------------------
[balance x l r] balances two trees with value x.
@@ -788,104 +939,142 @@
size of one of them. (a rotation).
[delta] is the maximal relative difference between the sizes of
- two trees, it corresponds with the [w] in Adams' paper,
- or equivalently, [1/delta] corresponds with the $\alpha$
- in Nievergelt's paper. Adams shows that [delta] should
- be larger than 3.745 in order to garantee that the
- rotations can always restore balance.
-
+ two trees, it corresponds with the [w] in Adams' paper.
[ratio] is the ratio between an outer and inner sibling of the
heavier subtree in an unbalanced setting. It determines
whether a double or single rotation should be performed
to restore balance. It is correspondes with the inverse
of $\alpha$ in Adam's article.
- Note that:
+ Note that according to the Adam's paper:
- [delta] should be larger than 4.646 with a [ratio] of 2.
- [delta] should be larger than 3.745 with a [ratio] of 1.534.
-
+
+ But the Adam's paper is errorneous:
+ - it can be proved that for delta=2 and delta>=5 there does
+ not exist any ratio that would work
+ - delta=4.5 and ratio=2 does not work
+
+ That leaves two reasonable variants, delta=3 and delta=4,
+ both with ratio=2.
+
- A lower [delta] leads to a more 'perfectly' balanced tree.
- A higher [delta] performs less rebalancing.
- - Balancing is automatic for random data and a balancing
- scheme is only necessary to avoid pathological worst cases.
- Almost any choice will do in practice
-
- - Allthough it seems that a rather large [delta] may perform better
- than smaller one, measurements have shown that the smallest [delta]
- of 4 is actually the fastest on a wide range of operations. It
- especially improves performance on worst-case scenarios like
- a sequence of ordered insertions.
+ In the benchmarks, delta=3 is faster on insert operations,
+ and delta=4 has slightly better deletes. As the insert speedup
+ is larger, we currently use delta=3.
- Note: in contrast to Adams' paper, we use a ratio of (at least) 2
- to decide whether a single or double rotation is needed. Allthough
- he actually proves that this ratio is needed to maintain the
- invariants, his implementation uses a (invalid) ratio of 1.
- He is aware of the problem though since he has put a comment in his
- original source code that he doesn't care about generating a
- slightly inbalanced tree since it doesn't seem to matter in practice.
- However (since we use quickcheck :-) we will stick to strictly balanced
- trees.
--------------------------------------------------------------------}
delta,ratio :: Int
-delta = 4
+delta = 3
ratio = 2
-balance :: a -> Set a -> Set a -> Set a
-balance x l r
- | sizeL + sizeR <= 1 = Bin sizeX x l r
- | sizeR >= delta*sizeL = rotateL x l r
- | sizeL >= delta*sizeR = rotateR x l r
- | otherwise = Bin sizeX x l r
- where
- sizeL = size l
- sizeR = size r
- sizeX = sizeL + sizeR + 1
+-- The balance function is equivalent to the following:
+--
+-- balance :: a -> Set a -> Set a -> Set a
+-- balance x l r
+-- | sizeL + sizeR <= 1 = Bin sizeX x l r
+-- | sizeR > delta*sizeL = rotateL x l r
+-- | sizeL > delta*sizeR = rotateR x l r
+-- | otherwise = Bin sizeX x l r
+-- where
+-- sizeL = size l
+-- sizeR = size r
+-- sizeX = sizeL + sizeR + 1
+--
+-- rotateL :: a -> Set a -> Set a -> Set a
+-- rotateL x l r@(Bin _ _ ly ry) | size ly < ratio*size ry = singleL x l r
+-- | otherwise = doubleL x l r
+-- rotateR :: a -> Set a -> Set a -> Set a
+-- rotateR x l@(Bin _ _ ly ry) r | size ry < ratio*size ly = singleR x l r
+-- | otherwise = doubleR x l r
+--
+-- singleL, singleR :: a -> Set a -> Set a -> Set a
+-- singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3
+-- singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3)
+--
+-- doubleL, doubleR :: a -> Set a -> Set a -> Set a
+-- doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)
+-- doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)
+--
+-- It is only written in such a way that every node is pattern-matched only once.
+--
+-- Only balanceL and balanceR are needed at the moment, so balance is not here anymore.
+-- In case it is needed, it can be found in Data.Map.
--- rotate
-rotateL :: a -> Set a -> Set a -> Set a
-rotateL x l r@(Bin _ _ ly ry)
- | size ly < ratio*size ry = singleL x l r
- | otherwise = doubleL x l r
-rotateL _ _ Tip = error "rotateL Tip"
+-- Functions balanceL and balanceR are specialised versions of balance.
+-- balanceL only checks whether the left subtree is too big,
+-- balanceR only checks whether the right subtree is too big.
-rotateR :: a -> Set a -> Set a -> Set a
-rotateR x l@(Bin _ _ ly ry) r
- | size ry < ratio*size ly = singleR x l r
- | otherwise = doubleR x l r
-rotateR _ Tip _ = error "rotateL Tip"
+-- balanceL is called when left subtree might have been inserted to or when
+-- right subtree might have been deleted from.
+balanceL :: a -> Set a -> Set a -> Set a
+balanceL x l r = case r of
+ Tip -> case l of
+ Tip -> Bin 1 x Tip Tip
+ (Bin _ _ Tip Tip) -> Bin 2 x l Tip
+ (Bin _ lx Tip (Bin _ lrx _ _)) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip)
+ (Bin _ lx ll@(Bin _ _ _ _) Tip) -> Bin 3 lx ll (Bin 1 x Tip Tip)
+ (Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr))
+ | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip)
+ | otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip)
--- basic rotations
-singleL, singleR :: a -> Set a -> Set a -> Set a
-singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3
-singleL _ _ Tip = error "singleL"
-singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3)
-singleR _ Tip _ = error "singleR"
+ (Bin rs _ _ _) -> case l of
+ Tip -> Bin (1+rs) x Tip r
-doubleL, doubleR :: a -> Set a -> Set a -> Set a
-doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)
-doubleL _ _ _ = error "doubleL"
-doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)
-doubleR _ _ _ = error "doubleR"
+ (Bin ls lx ll lr)
+ | ls > delta*rs -> case (ll, lr) of
+ (Bin lls _ _ _, Bin lrs lrx lrl lrr)
+ | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r)
+ | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r)
+ (_, _) -> error "Failure in Data.Map.balanceL"
+ | otherwise -> Bin (1+ls+rs) x l r
+{-# NOINLINE balanceL #-}
+-- balanceR is called when right subtree might have been inserted to or when
+-- left subtree might have been deleted from.
+balanceR :: a -> Set a -> Set a -> Set a
+balanceR x l r = case l of
+ Tip -> case r of
+ Tip -> Bin 1 x Tip Tip
+ (Bin _ _ Tip Tip) -> Bin 2 x Tip r
+ (Bin _ rx Tip rr@(Bin _ _ _ _)) -> Bin 3 rx (Bin 1 x Tip Tip) rr
+ (Bin _ rx (Bin _ rlx _ _) Tip) -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip)
+ (Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _))
+ | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr
+ | otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr)
+ (Bin ls _ _ _) -> case r of
+ Tip -> Bin (1+ls) x l Tip
+
+ (Bin rs rx rl rr)
+ | rs > delta*ls -> case (rl, rr) of
+ (Bin rls rlx rll rlr, Bin rrs _ _ _)
+ | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr
+ | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr)
+ (_, _) -> error "Failure in Data.Map.balanceR"
+ | otherwise -> Bin (1+ls+rs) x l r
+{-# NOINLINE balanceR #-}
+
{--------------------------------------------------------------------
The bin constructor maintains the size of the tree
--------------------------------------------------------------------}
bin :: a -> Set a -> Set a -> Set a
bin x l r
= Bin (size l + size r + 1) x l r
+{-# INLINE bin #-}
{--------------------------------------------------------------------
Utilities
--------------------------------------------------------------------}
foldlStrict :: (a -> b -> a) -> a -> [b] -> a
-foldlStrict f z xs
- = case xs of
- [] -> z
- (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
-
+foldlStrict f = go
+ where
+ go z [] = z
+ go z (x:xs) = let z' = f z x in z' `seq` go z' xs
+{-# INLINE foldlStrict #-}
{--------------------------------------------------------------------
Debugging
@@ -1015,166 +1204,3 @@
Bin sz _ l r -> case (realsize l,realsize r) of
(Just n,Just m) | n+m+1 == sz -> Just sz
_ -> Nothing
-
-{-
-{--------------------------------------------------------------------
- Testing
---------------------------------------------------------------------}
-testTree :: [Int] -> Set Int
-testTree xs = fromList xs
-test1 = testTree [1..20]
-test2 = testTree [30,29..10]
-test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
-
-{--------------------------------------------------------------------
- QuickCheck
---------------------------------------------------------------------}
-qcheck prop
- = check config prop
- where
- config = Config
- { configMaxTest = 500
- , configMaxFail = 5000
- , configSize = \n -> (div n 2 + 3)
- , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
- }
-
-
-{--------------------------------------------------------------------
- Arbitrary, reasonably balanced trees
---------------------------------------------------------------------}
-instance (Enum a) => Arbitrary (Set a) where
- arbitrary = sized (arbtree 0 maxkey)
- where maxkey = 10000
-
-arbtree :: (Enum a) => Int -> Int -> Int -> Gen (Set a)
-arbtree lo hi n
- | n <= 0 = return Tip
- | lo >= hi = return Tip
- | otherwise = do{ i <- choose (lo,hi)
- ; m <- choose (1,30)
- ; let (ml,mr) | m==(1::Int)= (1,2)
- | m==2 = (2,1)
- | m==3 = (1,1)
- | otherwise = (2,2)
- ; l <- arbtree lo (i-1) (n `div` ml)
- ; r <- arbtree (i+1) hi (n `div` mr)
- ; return (bin (toEnum i) l r)
- }
-
-
-{--------------------------------------------------------------------
- Valid tree's
---------------------------------------------------------------------}
-forValid :: (Enum a,Show a,Testable b) => (Set a -> b) -> Property
-forValid f
- = forAll arbitrary $ \t ->
--- classify (balanced t) "balanced" $
- classify (size t == 0) "empty" $
- classify (size t > 0 && size t <= 10) "small" $
- classify (size t > 10 && size t <= 64) "medium" $
- classify (size t > 64) "large" $
- balanced t ==> f t
-
-forValidIntTree :: Testable a => (Set Int -> a) -> Property
-forValidIntTree f
- = forValid f
-
-forValidUnitTree :: Testable a => (Set Int -> a) -> Property
-forValidUnitTree f
- = forValid f
-
-
-prop_Valid
- = forValidUnitTree $ \t -> valid t
-
-{--------------------------------------------------------------------
- Single, Insert, Delete
---------------------------------------------------------------------}
-prop_Single :: Int -> Bool
-prop_Single x
- = (insert x empty == singleton x)
-
-prop_InsertValid :: Int -> Property
-prop_InsertValid k
- = forValidUnitTree $ \t -> valid (insert k t)
-
-prop_InsertDelete :: Int -> Set Int -> Property
-prop_InsertDelete k t
- = not (member k t) ==> delete k (insert k t) == t
-
-prop_DeleteValid :: Int -> Property
-prop_DeleteValid k
- = forValidUnitTree $ \t ->
- valid (delete k (insert k t))
-
-{--------------------------------------------------------------------
- Balance
---------------------------------------------------------------------}
-prop_Join :: Int -> Property
-prop_Join x
- = forValidUnitTree $ \t ->
- let (l,r) = split x t
- in valid (join x l r)
-
-prop_Merge :: Int -> Property
-prop_Merge x
- = forValidUnitTree $ \t ->
- let (l,r) = split x t
- in valid (merge l r)
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
-prop_UnionValid :: Property
-prop_UnionValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (union t1 t2)
-
-prop_UnionInsert :: Int -> Set Int -> Bool
-prop_UnionInsert x t
- = union t (singleton x) == insert x t
-
-prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool
-prop_UnionAssoc t1 t2 t3
- = union t1 (union t2 t3) == union (union t1 t2) t3
-
-prop_UnionComm :: Set Int -> Set Int -> Bool
-prop_UnionComm t1 t2
- = (union t1 t2 == union t2 t1)
-
-
-prop_DiffValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (difference t1 t2)
-
-prop_Diff :: [Int] -> [Int] -> Bool
-prop_Diff xs ys
- = toAscList (difference (fromList xs) (fromList ys))
- == List.sort ((List.\\) (nub xs) (nub ys))
-
-prop_IntValid
- = forValidUnitTree $ \t1 ->
- forValidUnitTree $ \t2 ->
- valid (intersection t1 t2)
-
-prop_Int :: [Int] -> [Int] -> Bool
-prop_Int xs ys
- = toAscList (intersection (fromList xs) (fromList ys))
- == List.sort (nub ((List.intersect) (xs) (ys)))
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
-prop_Ordered
- = forAll (choose (5,100)) $ \n ->
- let xs = [0..n::Int]
- in fromAscList xs == fromList xs
-
-prop_List :: [Int] -> Bool
-prop_List xs
- = (sort (nub xs) == toList (fromList xs))
--}
diff --git a/Data/Tree.hs b/Data/Tree.hs
--- a/Data/Tree.hs
+++ b/Data/Tree.hs
@@ -13,26 +13,22 @@
-----------------------------------------------------------------------------
module Data.Tree(
- Tree(..), Forest,
- -- * Two-dimensional drawing
- drawTree, drawForest,
- -- * Extraction
- flatten, levels,
- -- * Building trees
- unfoldTree, unfoldForest,
- unfoldTreeM, unfoldForestM,
- unfoldTreeM_BF, unfoldForestM_BF,
+ Tree(..), Forest,
+ -- * Two-dimensional drawing
+ drawTree, drawForest,
+ -- * Extraction
+ flatten, levels,
+ -- * Building trees
+ unfoldTree, unfoldForest,
+ unfoldTreeM, unfoldForestM,
+ unfoldTreeM_BF, unfoldForestM_BF,
) where
-#ifdef __HADDOCK__
-import Prelude
-#endif
-
import Control.Applicative (Applicative(..), (<$>))
import Control.Monad
import Data.Monoid (Monoid(..))
import Data.Sequence (Seq, empty, singleton, (<|), (|>), fromList,
- ViewL(..), ViewR(..), viewl, viewr)
+ ViewL(..), ViewR(..), viewl, viewr)
import Data.Foldable (Foldable(foldMap), toList)
import Data.Traversable (Traversable(traverse))
import Data.Typeable
@@ -42,21 +38,14 @@
#endif
-- | Multi-way trees, also known as /rose trees/.
-data Tree a = Node {
- rootLabel :: a, -- ^ label value
- subForest :: Forest a -- ^ zero or more child trees
- }
-#ifndef __HADDOCK__
-# ifdef __GLASGOW_HASKELL__
+data Tree a = Node {
+ rootLabel :: a, -- ^ label value
+ subForest :: Forest a -- ^ zero or more child trees
+ }
+#ifdef __GLASGOW_HASKELL__
deriving (Eq, Read, Show, Data)
-# else
+#else
deriving (Eq, Read, Show)
-# endif
-#else /* __HADDOCK__ (which can't figure these out by itself) */
-instance Eq a => Eq (Tree a)
-instance Read a => Read (Tree a)
-instance Show a => Show (Tree a)
-instance Data a => Data (Tree a)
#endif
type Forest a = [Tree a]
@@ -64,23 +53,23 @@
INSTANCE_TYPEABLE1(Tree,treeTc,"Tree")
instance Functor Tree where
- fmap f (Node x ts) = Node (f x) (map (fmap f) ts)
+ fmap f (Node x ts) = Node (f x) (map (fmap f) ts)
instance Applicative Tree where
- pure x = Node x []
- Node f tfs <*> tx@(Node x txs) =
- Node (f x) (map (f <$>) txs ++ map (<*> tx) tfs)
+ pure x = Node x []
+ Node f tfs <*> tx@(Node x txs) =
+ Node (f x) (map (f <$>) txs ++ map (<*> tx) tfs)
instance Monad Tree where
- return x = Node x []
- Node x ts >>= f = Node x' (ts' ++ map (>>= f) ts)
- where Node x' ts' = f x
+ return x = Node x []
+ Node x ts >>= f = Node x' (ts' ++ map (>>= f) ts)
+ where Node x' ts' = f x
instance Traversable Tree where
- traverse f (Node x ts) = Node <$> f x <*> traverse (traverse f) ts
+ traverse f (Node x ts) = Node <$> f x <*> traverse (traverse f) ts
instance Foldable Tree where
- foldMap f (Node x ts) = f x `mappend` foldMap (foldMap f) ts
+ foldMap f (Node x ts) = f x `mappend` foldMap (foldMap f) ts
-- | Neat 2-dimensional drawing of a tree.
drawTree :: Tree String -> String
@@ -92,13 +81,14 @@
draw :: Tree String -> [String]
draw (Node x ts0) = x : drawSubTrees ts0
- where drawSubTrees [] = []
- drawSubTrees [t] =
- "|" : shift "`- " " " (draw t)
- drawSubTrees (t:ts) =
- "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts
+ where
+ drawSubTrees [] = []
+ drawSubTrees [t] =
+ "|" : shift "`- " " " (draw t)
+ drawSubTrees (t:ts) =
+ "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts
- shift first other = zipWith (++) (first : repeat other)
+ shift first other = zipWith (++) (first : repeat other)
-- | The elements of a tree in pre-order.
flatten :: Tree a -> [a]
@@ -107,9 +97,10 @@
-- | Lists of nodes at each level of the tree.
levels :: Tree a -> [[a]]
-levels t = map (map rootLabel) $
- takeWhile (not . null) $
- iterate (concatMap subForest) [t]
+levels t =
+ map (map rootLabel) $
+ takeWhile (not . null) $
+ iterate (concatMap subForest) [t]
-- | Build a tree from a seed value
unfoldTree :: (b -> (a, [b])) -> b -> Tree a
@@ -122,9 +113,9 @@
-- | Monadic tree builder, in depth-first order
unfoldTreeM :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a)
unfoldTreeM f b = do
- (a, bs) <- f b
- ts <- unfoldForestM f bs
- return (Node a ts)
+ (a, bs) <- f b
+ ts <- unfoldForestM f bs
+ return (Node a ts)
-- | Monadic forest builder, in depth-first order
#ifndef __NHC__
@@ -138,9 +129,10 @@
-- by Chris Okasaki, /ICFP'00/.
unfoldTreeM_BF :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a)
unfoldTreeM_BF f b = liftM getElement $ unfoldForestQ f (singleton b)
- where getElement xs = case viewl xs of
- x :< _ -> x
- EmptyL -> error "unfoldTreeM_BF"
+ where
+ getElement xs = case viewl xs of
+ x :< _ -> x
+ EmptyL -> error "unfoldTreeM_BF"
-- | Monadic forest builder, in breadth-first order,
-- using an algorithm adapted from
@@ -153,14 +145,15 @@
-- produces a sequence (reversed queue) of trees of the same length
unfoldForestQ :: Monad m => (b -> m (a, [b])) -> Seq b -> m (Seq (Tree a))
unfoldForestQ f aQ = case viewl aQ of
- EmptyL -> return empty
- a :< aQ' -> do
- (b, as) <- f a
- tQ <- unfoldForestQ f (Prelude.foldl (|>) aQ' as)
- let (tQ', ts) = splitOnto [] as tQ
- return (Node b ts <| tQ')
- where splitOnto :: [a'] -> [b'] -> Seq a' -> (Seq a', [a'])
- splitOnto as [] q = (q, as)
- splitOnto as (_:bs) q = case viewr q of
- q' :> a -> splitOnto (a:as) bs q'
- EmptyR -> error "unfoldForestQ"
+ EmptyL -> return empty
+ a :< aQ' -> do
+ (b, as) <- f a
+ tQ <- unfoldForestQ f (Prelude.foldl (|>) aQ' as)
+ let (tQ', ts) = splitOnto [] as tQ
+ return (Node b ts <| tQ')
+ where
+ splitOnto :: [a'] -> [b'] -> Seq a' -> (Seq a', [a'])
+ splitOnto as [] q = (q, as)
+ splitOnto as (_:bs) q = case viewr q of
+ q' :> a -> splitOnto (a:as) bs q'
+ EmptyR -> error "unfoldForestQ"
diff --git a/containers.cabal b/containers.cabal
--- a/containers.cabal
+++ b/containers.cabal
@@ -1,23 +1,23 @@
-name: containers
-version: 0.4.0.0
-license: BSD3
-license-file: LICENSE
-maintainer: libraries@haskell.org
+name: containers
+version: 0.4.1.0
+license: BSD3
+license-file: LICENSE
+maintainer: libraries@haskell.org
bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries%20%28other%29
-synopsis: Assorted concrete container types
-category: Data Structures
+synopsis: Assorted concrete container types
+category: Data Structures
description:
- This package contains efficient general-purpose implementations
- of various basic immutable container types. The declared cost of
- each operation is either worst-case or amortized, but remains
- valid even if structures are shared.
+ This package contains efficient general-purpose implementations
+ of various basic immutable container types. The declared cost of
+ each operation is either worst-case or amortized, but remains
+ valid even if structures are shared.
build-type: Simple
cabal-version: >=1.6
extra-source-files: include/Typeable.h
source-repository head
- type: darcs
- location: http://darcs.haskell.org/packages/containers/
+ type: git
+ location: http://github.com/haskell/containers.git
Library {
build-depends: base >= 4.2 && < 6, array
@@ -38,7 +38,8 @@
Data.Tree
}
if impl(ghc) {
- extensions: DeriveDataTypeable, MagicHash, Rank2Types
+ extensions: DeriveDataTypeable, StandaloneDeriving,
+ MagicHash, Rank2Types
}
}
diff --git a/include/Typeable.h b/include/Typeable.h
--- a/include/Typeable.h
+++ b/include/Typeable.h
@@ -14,32 +14,22 @@
#ifndef TYPEABLE_H
#define TYPEABLE_H
-#define INSTANCE_TYPEABLE0(tycon,tcname,str) \
-tcname :: TyCon; \
-tcname = mkTyCon str; \
-instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] }
-
#ifdef __GLASGOW_HASKELL__
--- // For GHC, the extra instances follow from general instance declarations
--- // defined in Data.Typeable.
+-- // For GHC, we can use DeriveDataTypeable + StandaloneDeriving to
+-- // generate the instances.
-#define INSTANCE_TYPEABLE1(tycon,tcname,str) \
-tcname :: TyCon; \
-tcname = mkTyCon str; \
-instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }
+#define INSTANCE_TYPEABLE0(tycon,tcname,str) deriving instance Typeable tycon
+#define INSTANCE_TYPEABLE1(tycon,tcname,str) deriving instance Typeable1 tycon
+#define INSTANCE_TYPEABLE2(tycon,tcname,str) deriving instance Typeable2 tycon
+#define INSTANCE_TYPEABLE3(tycon,tcname,str) deriving instance Typeable3 tycon
-#define INSTANCE_TYPEABLE2(tycon,tcname,str) \
-tcname :: TyCon; \
-tcname = mkTyCon str; \
-instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }
+#else /* !__GLASGOW_HASKELL__ */
-#define INSTANCE_TYPEABLE3(tycon,tcname,str) \
+#define INSTANCE_TYPEABLE0(tycon,tcname,str) \
tcname :: TyCon; \
tcname = mkTyCon str; \
-instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }
-
-#else /* !__GLASGOW_HASKELL__ */
+instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] }
#define INSTANCE_TYPEABLE1(tycon,tcname,str) \
tcname = mkTyCon str; \