containers 0.5.6.3 → 0.5.7.0
raw patch · 13 files changed
+409/−220 lines, 13 filesdep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Data.Sequence: instance Data.String.IsString (Data.Sequence.Seq GHC.Types.Char)
Files
- Data/Graph.hs +1/−1
- Data/IntMap/Base.hs +13/−4
- Data/IntMap/Strict.hs +1/−1
- Data/IntSet/Base.hs +12/−2
- Data/Map/Base.hs +16/−7
- Data/Sequence.hs +257/−195
- Data/Set/Base.hs +14/−2
- Data/Tree.hs +1/−2
- benchmarks/Sequence.hs +6/−1
- benchmarks/bench-cmp.sh +1/−1
- containers.cabal +19/−1
- include/containers.h +22/−3
- tests/intset-strictness.hs +46/−0
Data/Graph.hs view
@@ -295,7 +295,7 @@ newtype SetM s a = SetM { runSetM :: STArray s Vertex Bool -> ST s a } instance Monad (SetM s) where- return x = SetM $ const (return x)+ return = pure {-# INLINE return #-} SetM v >>= f = SetM $ \s -> do { x <- v s; runSetM (f x) s } {-# INLINE (>>=) #-}
Data/IntMap/Base.hs view
@@ -216,14 +216,15 @@ , highestBitMask ) where -#if MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#else+#if !(MIN_VERSION_base(4,8,0)) import Control.Applicative (Applicative(pure, (<*>)), (<$>)) import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable(traverse)) import Data.Word (Word) #endif+#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)+#endif import Control.DeepSeq (NFData(rnf)) import Control.Monad (liftM)@@ -307,8 +308,16 @@ instance Monoid (IntMap a) where mempty = empty- mappend = union mconcat = unions+#if !(MIN_VERSION_base(4,9,0))+ mappend = union+#else+ mappend = (<>)++instance Semigroup (IntMap a) where+ (<>) = union+ stimes = stimesIdempotentMonoid+#endif instance Foldable.Foldable IntMap where fold = go
Data/IntMap/Strict.hs view
@@ -505,7 +505,7 @@ --- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- | /O(min(n,W))/. 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) -> Key -> IntMap a -> IntMap a
Data/IntSet/Base.hs view
@@ -173,6 +173,9 @@ import Data.Monoid (Monoid(..)) import Data.Word (Word) #endif+#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)+#endif import Data.Typeable import Prelude hiding (filter, foldr, foldl, null, map) @@ -247,9 +250,17 @@ instance Monoid IntSet where mempty = empty- mappend = union mconcat = unions+#if !(MIN_VERSION_base(4,9,0))+ mappend = union+#else+ mappend = (<>) +instance Semigroup IntSet where+ (<>) = union+ stimes = stimesIdempotentMonoid+#endif+ #if __GLASGOW_HASKELL__ {--------------------------------------------------------------------@@ -882,7 +893,6 @@ | otherwise -> go (go z l) r _ -> go z t where- STRICT_1_OF_2(go) go z' Nil = z' go z' (Tip kx bm) = foldlBits kx f z' bm go z' (Bin _ _ l r) = go (go z' l) r
Data/Map/Base.hs view
@@ -80,7 +80,7 @@ -- [Note: Local 'go' functions and capturing] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- As opposed to IntMap, when 'go' function captures an argument, increased+-- As opposed to Map, when 'go' function captures an argument, increased -- heap-allocation can occur: sometimes in a polymorphic function, the 'go' -- floats out of its enclosing function and then it heap-allocates the -- dictionary and the argument. Maybe it floats out too late and strictness@@ -270,13 +270,14 @@ , filterLt ) where -#if MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#else+#if !(MIN_VERSION_base(4,8,0)) import Control.Applicative (Applicative(..), (<$>)) import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable(traverse)) #endif+#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)+#endif import Control.DeepSeq (NFData(rnf)) import Data.Bits (shiftL, shiftR)@@ -342,9 +343,17 @@ instance (Ord k) => Monoid (Map k v) where mempty = empty- mappend = union mconcat = unions+#if !(MIN_VERSION_base(4,9,0))+ mappend = union+#else+ mappend = (<>) +instance (Ord k) => Semigroup (Map k v) where+ (<>) = union+ stimes = stimesIdempotentMonoid+#endif+ #if __GLASGOW_HASKELL__ {--------------------------------------------------------------------@@ -1413,7 +1422,7 @@ -- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2 -- -- When calling @'mergeWithKey' combine only1 only2@, a function combining two--- 'IntMap's is created, such that+-- 'Map's is created, such that -- -- * if a key is present in both maps, it is passed with both corresponding -- values to the @combine@ function. Depending on the result, the key is either@@ -1689,7 +1698,7 @@ #endif -- | /O(n)/.--- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@+-- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ -- That is, behaves exactly like a regular 'traverse' except that the traversing -- function also has access to the key associated with a value. --
Data/Sequence.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-} #endif #if __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Trustworthy #-}@@ -156,7 +158,7 @@ import Prelude hiding ( Functor(..), #if MIN_VERSION_base(4,8,0)- Applicative, foldMap, Monoid,+ Applicative, (<$>), foldMap, Monoid, #endif null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1, scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,@@ -173,6 +175,9 @@ #if MIN_VERSION_base(4,8,0) import Data.Foldable (foldr') #endif+#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (Semigroup((<>)))+#endif import Data.Traversable import Data.Typeable @@ -182,6 +187,7 @@ import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec, readListPrecDefault) import Data.Data+import Data.String (IsString(..)) #endif -- Array stuff, with GHC.Arr on GHC@@ -264,160 +270,158 @@ rnf (Seq xs) = rnf xs instance Monad Seq where- return = singleton+ return = pure xs >>= f = foldl' add empty xs where add ys x = ys >< f x (>>) = (*>) instance Applicative Seq where pure = singleton+ xs *> ys = cycleN (length xs) ys - Seq Empty <*> xs = xs `seq` empty- fs <*> Seq Empty = fs `seq` empty- fs <*> Seq (Single (Elem x)) = fmap ($ x) fs- fs <*> xs- | length fs < 4 = foldl' add empty fs- where add ys f = ys >< fmap f xs- fs <*> xs | length xs < 4 = apShort fs xs- fs <*> xs = apty fs xs+ fs <*> xs@(Seq xsFT) = case viewl fs of+ EmptyL -> empty+ firstf :< fs' -> case viewr fs' of+ EmptyR -> fmap firstf xs+ Seq fs''FT :> lastf -> case rigidify xsFT of+ RigidEmpty -> empty+ RigidOne (Elem x) -> fmap ($x) fs+ RigidTwo (Elem x1) (Elem x2) ->+ Seq $ ap2FT firstf fs''FT lastf (x1, x2)+ RigidThree (Elem x1) (Elem x2) (Elem x3) ->+ Seq $ ap3FT firstf fs''FT lastf (x1, x2, x3)+ RigidFull r@(Rigid s pr _m sf) -> Seq $+ Deep (s * length fs)+ (fmap (fmap firstf) (nodeToDigit pr))+ (aptyMiddle (fmap firstf) (fmap lastf) fmap fs''FT r)+ (fmap (fmap lastf) (nodeToDigit sf)) - xs *> ys = replicateSeq (length xs) ys --- <*> when the length of the first argument is at least two and--- the length of the second is two or three.-apShort :: Seq (a -> b) -> Seq a -> Seq b-apShort (Seq fs) xs = Seq $ case toList xs of- [a,b] -> ap2FT fs (a,b)- [a,b,c] -> ap3FT fs (a,b,c)- _ -> error "apShort: not 2-3"--ap2FT :: FingerTree (Elem (a->b)) -> (a,a) -> FingerTree (Elem b)-ap2FT fs (x,y) = Deep (size fs * 2)+ap2FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a) -> FingerTree (Elem b)+ap2FT firstf fs lastf (x,y) =+ Deep (size fs * 2 + 4) (Two (Elem $ firstf x) (Elem $ firstf y))- (mapMulFT 2 (\(Elem f) -> Node2 2 (Elem (f x)) (Elem (f y))) m)+ (mapMulFT 2 (\(Elem f) -> Node2 2 (Elem (f x)) (Elem (f y))) fs) (Two (Elem $ lastf x) (Elem $ lastf y))- where- (Elem firstf, m, Elem lastf) = trimTree fs -ap3FT :: FingerTree (Elem (a->b)) -> (a,a,a) -> FingerTree (Elem b)-ap3FT fs (x,y,z) = Deep (size fs * 3)+ap3FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a,a) -> FingerTree (Elem b)+ap3FT firstf fs lastf (x,y,z) = Deep (size fs * 3 + 6) (Three (Elem $ firstf x) (Elem $ firstf y) (Elem $ firstf z))- (mapMulFT 3 (\(Elem f) -> Node3 3 (Elem (f x)) (Elem (f y)) (Elem (f z))) m)+ (mapMulFT 3 (\(Elem f) -> Node3 3 (Elem (f x)) (Elem (f y)) (Elem (f z))) fs) (Three (Elem $ lastf x) (Elem $ lastf y) (Elem $ lastf z))- where- (Elem firstf, m, Elem lastf) = trimTree fs --- <*> when the length of each argument is at least four.-apty :: Seq (a -> b) -> Seq a -> Seq b-apty (Seq fs) (Seq xs@Deep{}) = Seq $- Deep (s' * size fs)- (fmap (fmap firstf) pr')- (aptyMiddle (fmap firstf) (fmap lastf) fmap fs' xs')- (fmap (fmap lastf) sf')- where- (Elem firstf, fs', Elem lastf) = trimTree fs- xs'@(Deep s' pr' _m' sf') = rigidify xs-apty _ _ = error "apty: expects a Deep constructor" --- | 'aptyMiddle' does most of the hard work of computing @fs<*>xs@.--- It produces the center part of a finger tree, with a prefix corresponding--- to the prefix of @xs@ and a suffix corresponding to the suffix of @xs@--- omitted; the missing suffix and prefix are added by the caller.--- For the recursive call, it squashes the prefix and the suffix into--- the center tree. Once it gets to the bottom, it turns the tree into--- a 2-3 tree, applies 'mapMulFT' to produce the main body, and glues all--- the pieces together.+data Rigidified a = RigidEmpty+ | RigidOne a+ | RigidTwo a a+ | RigidThree a a a+ | RigidFull (Rigid a)+#ifdef TESTING+ deriving Show+#endif++-- | A finger tree whose top level has only Two and/or Three digits, and whose+-- other levels have only One and Two digits. A Rigid tree is precisely what one+-- gets by unzipping/inverting a 2-3 tree, so it is precisely what we need to+-- turn a finger tree into in order to transform it into a 2-3 tree.+data Rigid a = Rigid {-# UNPACK #-} !Int !(Digit23 a) (Thin (Node a)) !(Digit23 a)+#ifdef TESTING+ deriving Show+#endif++-- | A finger tree whose digits are all ones and twos+data Thin a = EmptyTh+ | SingleTh a+ | DeepTh {-# UNPACK #-} !Int !(Digit12 a) (Thin (Node a)) !(Digit12 a)+#ifdef TESTING+ deriving Show+#endif++data Digit12 a = One12 a | Two12 a a+#ifdef TESTING+ deriving Show+#endif++-- | Sometimes, we want to emphasize that we are viewing a node as a top-level+-- digit of a 'Rigid' tree.+type Digit23 a = Node a++-- | 'aptyMiddle' does most of the hard work of computing @fs<*>xs@. It+-- produces the center part of a finger tree, with a prefix corresponding to+-- the prefix of @xs@ and a suffix corresponding to the suffix of @xs@ omitted;+-- the missing suffix and prefix are added by the caller. For the recursive+-- call, it squashes the prefix and the suffix into the center tree. Once it+-- gets to the bottom, it turns the tree into a 2-3 tree, applies 'mapMulFT' to+-- produce the main body, and glues all the pieces together.+--+-- 'map23' itself is a bit horrifying because of the nested types involved. Its+-- job is to map over the *elements* of a 2-3 tree, rather than the subtrees.+-- If we used a higher-order nested type with MPTC, we could probably use a+-- class, but as it is we have to build up 'map23' explicitly through the+-- recursion. aptyMiddle- :: Sized c =>- (c -> d)+ :: (c -> d) -> (c -> d) -> ((a -> b) -> c -> d) -> FingerTree (Elem (a -> b))- -> FingerTree c+ -> Rigid c -> FingerTree (Node d)+ -- Not at the bottom yet+ aptyMiddle firstf lastf map23 fs- (Deep s pr (Deep sm prm mm sfm) sf)+ (Rigid s pr (DeepTh sm prm mm sfm) sf) = Deep (sm + s * (size fs + 1)) -- note: sm = s - size pr - size sf- (fmap (fmap firstf) prm)+ (fmap (fmap firstf) (digit12ToDigit prm)) (aptyMiddle (fmap firstf) (fmap lastf)- (\f -> fmap (map23 f))+ (fmap . map23) fs- (Deep s (squashL pr prm) mm (squashR sfm sf)))- (fmap (fmap lastf) sfm)+ (Rigid s (squashL pr prm) mm (squashR sfm sf)))+ (fmap (fmap lastf) (digit12ToDigit sfm)) --- At the bottom. Note that these appendTree0 calls are very cheap, because in--- each case, one of the arguments is guaranteed to be Empty or Single.+-- At the bottom+ aptyMiddle firstf lastf map23 fs- (Deep s pr m sf)- = fmap (fmap firstf) m `appendTree0`- ((fmap firstf (digitToNode sf)- `consTree` middle)- `snocTree` fmap lastf (digitToNode pr))- `appendTree0` fmap (fmap lastf) m- where middle = case trimTree $ mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs of- (firstMapped, restMapped, lastMapped) ->- Deep (size firstMapped + size restMapped + size lastMapped)- (nodeToDigit firstMapped) restMapped (nodeToDigit lastMapped)- converted = case m of- Empty -> Node2 s lconv rconv- Single q -> Node3 s lconv q rconv- Deep{} -> error "aptyMiddle: impossible"- lconv = digitToNode pr- rconv = digitToNode sf--aptyMiddle _ _ _ _ _ = error "aptyMiddle: expected Deep finger tree"--{-# SPECIALIZE- aptyMiddle- :: (Node c -> d)- -> (Node c -> d)- -> ((a -> b) -> Node c -> d)- -> FingerTree (Elem (a -> b))- -> FingerTree (Node c)- -> FingerTree (Node d)- #-}-{-# SPECIALIZE- aptyMiddle- :: (Elem c -> d)- -> (Elem c -> d)- -> ((a -> b) -> Elem c -> d)- -> FingerTree (Elem (a -> b))- -> FingerTree (Elem c)- -> FingerTree (Node d)- #-}+ (Rigid s pr EmptyTh sf)+ = deep+ (One (fmap firstf sf))+ (mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs)+ (One (fmap lastf pr))+ where converted = node2 pr sf -digitToNode :: Sized a => Digit a -> Node a-digitToNode (Two a b) = node2 a b-digitToNode (Three a b c) = node3 a b c-digitToNode _ = error "digitToNode: not representable as a node"+aptyMiddle firstf+ lastf+ map23+ fs+ (Rigid s pr (SingleTh q) sf)+ = deep+ (Two (fmap firstf q) (fmap firstf sf))+ (mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs)+ (Two (fmap lastf pr) (fmap lastf q))+ where converted = node3 pr q sf -type Digit23 = Digit-type Digit12 = Digit+digit12ToDigit :: Digit12 a -> Digit a+digit12ToDigit (One12 a) = One a+digit12ToDigit (Two12 a b) = Two a b -- Squash the first argument down onto the left side of the second.-squashL :: Sized a => Digit23 a -> Digit12 (Node a) -> Digit23 (Node a)-squashL (Two a b) (One n) = Two (node2 a b) n-squashL (Two a b) (Two n1 n2) = Three (node2 a b) n1 n2-squashL (Three a b c) (One n) = Two (node3 a b c) n-squashL (Three a b c) (Two n1 n2) = Three (node3 a b c) n1 n2-squashL _ _ = error "squashL: wrong digit types"+squashL :: Digit23 a -> Digit12 (Node a) -> Digit23 (Node a)+squashL m (One12 n) = node2 m n+squashL m (Two12 n1 n2) = node3 m n1 n2 -- Squash the second argument down onto the right side of the first-squashR :: Sized a => Digit12 (Node a) -> Digit23 a -> Digit23 (Node a)-squashR (One n) (Two a b) = Two n (node2 a b)-squashR (Two n1 n2) (Two a b) = Three n1 n2 (node2 a b)-squashR (One n) (Three a b c) = Two n (node3 a b c)-squashR (Two n1 n2) (Three a b c) = Three n1 n2 (node3 a b c)-squashR _ _ = error "squashR: wrong digit types"+squashR :: Digit12 (Node a) -> Digit23 a -> Digit23 (Node a)+squashR (One12 n) m = node2 n m+squashR (Two12 n1 n2) m = node3 n1 n2 m + -- | /O(m*n)/ (incremental) Takes an /O(m)/ function and a finger tree of size -- /n/ and maps the function over the tree leaves. Unlike the usual 'fmap', the -- function is applied to the "leaves" of the 'FingerTree' (i.e., given a@@ -434,73 +438,72 @@ mapMulNode mul f (Node2 s a b) = Node2 (mul * s) (f a) (f b) mapMulNode mul f (Node3 s a b c) = Node3 (mul * s) (f a) (f b) (f c) --trimTree :: Sized a => FingerTree a -> (a, FingerTree a, a)-trimTree Empty = error "trim: empty tree"-trimTree Single{} = error "trim: singleton"-trimTree t = case splitTree 0 t of- Split _ hd r ->- case splitTree (size r - 1) r of- Split m tl _ -> (hd, m, tl)- -- | /O(log n)/ (incremental) Takes the extra flexibility out of a 'FingerTree' -- to make it a genuine 2-3 finger tree. The result of 'rigidify' will have--- only 'Two' and 'Three' digits at the top level and only 'One' and 'Two'--- digits elsewhere. It gives an error if the tree has fewer than four--- elements.-rigidify :: Sized a => FingerTree a -> FingerTree a--- Note that 'rigidify' may call itself, but it will do so at most--- once: each call to 'rigidify' will either fix the whole tree or fix one digit--- and leave the other alone. The patterns below just fix up the top level of--- the tree; 'rigidify' delegates the hard work to 'thin'.+-- only two and three digits at the top level and only one and two+-- digits elsewhere. If the tree has fewer than four elements, 'rigidify'+-- will simply extract them, and will not build a tree.+rigidify :: FingerTree (Elem a) -> Rigidified (Elem a)+-- The patterns below just fix up the top level of the tree; 'rigidify'+-- delegates the hard work to 'thin'. --- The top of the tree is fine.-rigidify (Deep s pr@Two{} m sf@Three{}) = Deep s pr (thin m) sf-rigidify (Deep s pr@Three{} m sf@Three{}) = Deep s pr (thin m) sf-rigidify (Deep s pr@Two{} m sf@Two{}) = Deep s pr (thin m) sf-rigidify (Deep s pr@Three{} m sf@Two{}) = Deep s pr (thin m) sf+rigidify Empty = RigidEmpty --- One of the Digits is a Four.-rigidify (Deep s (Four a b c d) m sf) =- rigidify $ Deep s (Two a b) (node2 c d `consTree` m) sf-rigidify (Deep s pr m (Four a b c d)) =- rigidify $ Deep s pr (m `snocTree` node2 a b) (Two c d)+rigidify (Single q) = RigidOne q --- One of the Digits is a One. If the middle is empty, we can only rigidify the--- tree if the other Digit is a Three.-rigidify (Deep s (One a) Empty (Three b c d)) = Deep s (Two a b) Empty (Two c d)-rigidify (Deep s (One a) m sf) = rigidify $ case viewLTree m of- Just2 (Node2 _ b c) m' -> Deep s (Three a b c) m' sf- Just2 (Node3 _ b c d) m' -> Deep s (Two a b) (node2 c d `consTree` m') sf- Nothing2 -> error "rigidify: small tree"-rigidify (Deep s (Three a b c) Empty (One d)) = Deep s (Two a b) Empty (Two c d)-rigidify (Deep s pr m (One e)) = rigidify $ case viewRTree m of- Just2 m' (Node2 _ a b) -> Deep s pr m' (Three a b e)- Just2 m' (Node3 _ a b c) -> Deep s pr (m' `snocTree` node2 a b) (Two c e)- Nothing2 -> error "rigidify: small tree"-rigidify Empty = error "rigidify: empty tree"-rigidify Single{} = error "rigidify: singleton"+-- The left digit is Two or Three+rigidify (Deep s (Two a b) m sf) = rigidifyRight s (node2 a b) m sf+rigidify (Deep s (Three a b c) m sf) = rigidifyRight s (node3 a b c) m sf +-- The left digit is Four+rigidify (Deep s (Four a b c d) m sf) = rigidifyRight s (node2 a b) (node2 c d `consTree` m) sf++-- The left digit is One+rigidify (Deep s (One a) m sf) = case viewLTree m of+ Just2 (Node2 _ b c) m' -> rigidifyRight s (node3 a b c) m' sf+ Just2 (Node3 _ b c d) m' -> rigidifyRight s (node2 a b) (node2 c d `consTree` m') sf+ Nothing2 -> case sf of+ One b -> RigidTwo a b+ Two b c -> RigidThree a b c+ Three b c d -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c d)+ Four b c d e -> RigidFull $ Rigid s (node3 a b c) EmptyTh (node2 d e)++-- | /O(log n)/ (incremental) Takes a tree whose left side has been rigidified+-- and finishes the job.+rigidifyRight :: Int -> Digit23 (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> Rigidified (Elem a)++-- The right digit is Two, Three, or Four+rigidifyRight s pr m (Two a b) = RigidFull $ Rigid s pr (thin m) (node2 a b)+rigidifyRight s pr m (Three a b c) = RigidFull $ Rigid s pr (thin m) (node3 a b c)+rigidifyRight s pr m (Four a b c d) = RigidFull $ Rigid s pr (thin $ m `snocTree` node2 a b) (node2 c d)++-- The right digit is One+rigidifyRight s pr m (One e) = case viewRTree m of+ Just2 m' (Node2 _ a b) -> RigidFull $ Rigid s pr (thin m') (node3 a b e)+ Just2 m' (Node3 _ a b c) -> RigidFull $ Rigid s pr (thin $ m' `snocTree` node2 a b) (node2 c e)+ Nothing2 -> case pr of+ Node2 _ a b -> RigidThree a b e+ Node3 _ a b c -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c e)+ -- | /O(log n)/ (incremental) Rejigger a finger tree so the digits are all ones -- and twos.-thin :: Sized a => FingerTree a -> FingerTree a--- Note that 'thin12' will produce a 'Deep' constructor immediately before+thin :: Sized a => FingerTree a -> Thin a+-- Note that 'thin12' will produce a 'DeepTh' constructor immediately before -- recursively calling 'thin'.-thin Empty = Empty-thin (Single a) = Single a-thin t@(Deep s pr m sf) =+thin Empty = EmptyTh+thin (Single a) = SingleTh a+thin (Deep s pr m sf) = case pr of- One{} -> thin12 t- Two{} -> thin12 t- Three a b c -> thin12 $ Deep s (One a) (node2 b c `consTree` m) sf- Four a b c d -> thin12 $ Deep s (Two a b) (node2 c d `consTree` m) sf+ One a -> thin12 s (One12 a) m sf+ Two a b -> thin12 s (Two12 a b) m sf+ Three a b c -> thin12 s (One12 a) (node2 b c `consTree` m) sf+ Four a b c d -> thin12 s (Two12 a b) (node2 c d `consTree` m) sf -thin12 :: Sized a => FingerTree a -> FingerTree a-thin12 (Deep s pr m sf@One{}) = Deep s pr (thin m) sf-thin12 (Deep s pr m sf@Two{}) = Deep s pr (thin m) sf-thin12 (Deep s pr m (Three a b c)) = Deep s pr (thin $ m `snocTree` node2 a b) (One c)-thin12 (Deep s pr m (Four a b c d)) = Deep s pr (thin $ m `snocTree` node2 a b) (Two c d)-thin12 _ = error "thin12 expects a Deep FingerTree."+thin12 :: Sized a => Int -> Digit12 a -> FingerTree (Node a) -> Digit a -> Thin a+thin12 s pr m (One a) = DeepTh s pr (thin m) (One12 a)+thin12 s pr m (Two a b) = DeepTh s pr (thin m) (Two12 a b)+thin12 s pr m (Three a b c) = DeepTh s pr (thin $ m `snocTree` node2 a b) (One12 c)+thin12 s pr m (Four a b c d) = DeepTh s pr (thin $ m `snocTree` node2 a b) (Two12 c d) instance MonadPlus Seq where@@ -543,8 +546,15 @@ instance Monoid (Seq a) where mempty = empty+#if !(MIN_VERSION_base(4,9,0)) mappend = (><)+#else+ mappend = (<>) +instance Semigroup (Seq a) where+ (<>) = (><)+#endif+ INSTANCE_TYPEABLE1(Seq,seqTc,"Seq") #if __GLASGOW_HASKELL__@@ -841,12 +851,13 @@ instance Monad (State s) where {-# INLINE return #-} {-# INLINE (>>=) #-}- return x = State $ \ s -> (s, x)+ return = pure m >>= k = State $ \ s -> case runState m s of (s', x) -> runState (k x) s' instance Applicative (State s) where- pure = return+ {-# INLINE pure #-}+ pure x = State $ \ s -> (s, x) (<*>) = ap execState :: State s a -> s -> a@@ -918,19 +929,67 @@ | n >= 0 = unwrapMonad (replicateA n (WrapMonad x)) | otherwise = error "replicateM takes a nonnegative integer argument" --- | @'replicateSeq' n xs@ concatenates @n@ copies of @xs@.-replicateSeq :: Int -> Seq a -> Seq a-replicateSeq n s- | n < 0 = error "replicateSeq takes a nonnegative integer argument"+-- | @'cycleN' n xs@ concatenates @n@ copies of @xs@.+cycleN :: Int -> Seq a -> Seq a+cycleN n xs+ | n < 0 = error "cycleN takes a nonnegative integer argument" | n == 0 = empty- | otherwise = go n s- where- -- Invariant: k >= 1- go 1 xs = xs- go k xs | even k = kxs- | otherwise = xs >< kxs- where kxs = go (k `quot` 2) $! (xs >< xs)+ | n == 1 = xs+cycleN n (Seq xsFT) = case rigidify xsFT of+ RigidEmpty -> empty+ RigidOne (Elem x) -> replicate n x+ RigidTwo x1 x2 -> Seq $+ Deep (n*2) pair+ (runIdentity $ applicativeTree (n-2) 2 (Identity (node2 x1 x2)))+ pair+ where pair = Two x1 x2+ RigidThree x1 x2 x3 -> Seq $+ Deep (n*3) triple+ (runIdentity $ applicativeTree (n-2) 3 (Identity (node3 x1 x2 x3)))+ triple+ where triple = Three x1 x2 x3+ RigidFull r@(Rigid s pr _m sf) -> Seq $+ Deep (n*s)+ (nodeToDigit pr)+ (cycleNMiddle (n-2) r)+ (nodeToDigit sf) +cycleNMiddle+ :: Int+ -> Rigid c+ -> FingerTree (Node c)++STRICT_1_OF_2(cycleNMiddle)++-- Not at the bottom yet++cycleNMiddle n+ (Rigid s pr (DeepTh sm prm mm sfm) sf)+ = Deep (sm + s * (n + 1)) -- note: sm = s - size pr - size sf+ (digit12ToDigit prm)+ (cycleNMiddle n+ (Rigid s (squashL pr prm) mm (squashR sfm sf)))+ (digit12ToDigit sfm)++-- At the bottom++cycleNMiddle n+ (Rigid s pr EmptyTh sf)+ = deep+ (One sf)+ (runIdentity $ applicativeTree n s (Identity converted))+ (One pr)+ where converted = node2 pr sf++cycleNMiddle n+ (Rigid s pr (SingleTh q) sf)+ = deep+ (Two q sf)+ (runIdentity $ applicativeTree n s (Identity converted))+ (Two pr q)+ where converted = node3 pr q sf++ -- | /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@@ -975,9 +1034,7 @@ -- The appendTree/addDigits gunk below is machine generated -{-# SPECIALIZE appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a) #-}-{-# SPECIALIZE appendTree0 :: FingerTree (Node a) -> FingerTree (Node a) -> FingerTree (Node a) #-}-appendTree0 :: Sized a => FingerTree a -> FingerTree a -> FingerTree a+appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a) appendTree0 Empty xs = xs appendTree0 xs Empty =@@ -2061,6 +2118,11 @@ toList = toList #endif +#ifdef __GLASGOW_HASKELL__+instance IsString (Seq Char) where+ fromString = fromList+#endif+ ------------------------------------------------------------------------ -- Reverse ------------------------------------------------------------------------@@ -2397,28 +2459,28 @@ where {-# INLINE unrollPQ' #-} unrollPQ' (PQueue x ts) = x:mergePQs0 ts- (<>) = mergePQ cmp+ (<+>) = mergePQ cmp mergePQs0 Nil = [] mergePQs0 (t :& Nil) = unrollPQ' t- mergePQs0 (t1 :& t2 :& ts) = mergePQs (t1 <> t2) ts+ 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'+ 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))+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+ 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
Data/Set/Base.hs view
@@ -199,6 +199,9 @@ #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid(..)) #endif+#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)+#endif import qualified Data.Foldable as Foldable import Data.Typeable import Control.DeepSeq (NFData(rnf))@@ -245,9 +248,18 @@ instance Ord a => Monoid (Set a) where mempty = empty- mappend = union mconcat = unions+#if !(MIN_VERSION_base(4,9,0))+ mappend = union+#else+ mappend = (<>) +instance Ord a => Semigroup (Set a) where+ (<>) = union+ stimes = stimesIdempotentMonoid+#endif++ instance Foldable.Foldable Set where fold = go where go Tip = mempty@@ -853,7 +865,7 @@ -- | /O(n*log n)/. Create a set from a list of elements. ----- If the elemens are ordered, linear-time implementation is used,+-- If the elements are ordered, a linear-time implementation is used, -- with the performance equal to 'fromDistinctAscList'. -- For some reason, when 'singleton' is used in fromList or in
Data/Tree.hs view
@@ -35,7 +35,6 @@ ) where #if MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>)) import Data.Foldable (toList) #else import Control.Applicative (Applicative(..), (<$>))@@ -92,7 +91,7 @@ Node (f x) (map (f <$>) txs ++ map (<*> tx) tfs) instance Monad Tree where- return x = Node x []+ return = pure Node x ts >>= f = Node x' (ts' ++ map (>>= f) ts) where Node x' ts' = f x
benchmarks/Sequence.hs view
@@ -47,8 +47,13 @@ , bench "nf10000" $ nf (\s -> S.fromFunction s (+1)) 10000 ] , bgroup "<*>"- [ bench "ix1000/500000" $+ [ bench "ix500/1000^2" $ nf (\s -> ((+) <$> s <*> s) `S.index` (S.length s `div` 2)) (S.fromFunction 1000 (+1))+ , bench "ix500000/1000^2" $+ nf (\s -> ((+) <$> s <*> s) `S.index` (S.length s * S.length s `div` 2)) (S.fromFunction 1000 (+1))+ , bench "ixBIG" $+ nf (\s -> ((+) <$> s <*> s) `S.index` (S.length s * S.length s `div` 2))+ (S.fromFunction (floor (sqrt $ fromIntegral (maxBound::Int))-10) (+1)) , bench "nf100/2500/rep" $ nf (\(s,t) -> (,) <$> replicate s () <*> replicate t ()) (100,2500) , bench "nf100/2500/ff" $
benchmarks/bench-cmp.sh view
@@ -1,3 +1,3 @@ #!/bin/sh -./bench-cmp.pl "$@" | column -nts\; | less -SR+(echo 'Benchmark;Runtime change;Original runtime'; ./bench-cmp.pl "$@") | column -ts\;
containers.cabal view
@@ -1,5 +1,5 @@ name: containers-version: 0.5.6.3+version: 0.5.7.0 license: BSD3 license-file: LICENSE maintainer: fox@ucw.cz@@ -238,6 +238,24 @@ test-suite intmap-strictness-properties hs-source-dirs: tests, . main-is: intmap-strictness.hs+ type: exitcode-stdio-1.0++ build-depends:+ array,+ base >= 4.2 && < 5,+ ChasingBottoms,+ deepseq >= 1.2 && < 1.5,+ QuickCheck >= 2.4.0.1,+ ghc-prim,+ test-framework >= 0.3.3,+ test-framework-quickcheck2 >= 0.2.9++ ghc-options: -Wall+ include-dirs: include++test-suite intset-strictness-properties+ hs-source-dirs: tests, .+ main-is: intset-strictness.hs type: exitcode-stdio-1.0 build-depends:
include/containers.h view
@@ -51,11 +51,30 @@ /* * We use cabal-generated MIN_VERSION_base to adapt to changes of base. * Nevertheless, as a convenience, we also allow compiling without cabal by- * defining trivial MIN_VERSION_base if needed.+ * defining an approximate MIN_VERSION_base if needed. The alternative version+ * guesses the version of base using the version of GHC. This is usually+ * sufficiently accurate. However, it completely ignores minor version numbers,+ * and it makes the assumption that a pre-release version of GHC will ship with+ * base libraries with the same version numbers as the final release. This+ * assumption is violated in certain stages of GHC development, but in practice+ * this should very rarely matter, and will not affect any released version. */ #ifndef MIN_VERSION_base-#define MIN_VERSION_base(major1,major2,minor) 0+#if __GLASGOW_HASKELL__ >= 709+#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=8)))+#elif __GLASGOW_HASKELL__ >= 707+#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=7)))+#elif __GLASGOW_HASKELL__ >= 705+#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=6)))+#elif __GLASGOW_HASKELL__ >= 703+#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=5)))+#elif __GLASGOW_HASKELL__ >= 701+#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=4)))+#elif __GLASGOW_HASKELL__ >= 700+#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=3)))+#else+#define MIN_VERSION_base(major1,major2,minor) (0) #endif-+#endif #endif
+ tests/intset-strictness.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main (main) where++import Prelude hiding (foldl)++import Test.ChasingBottoms.IsBottom+import Test.Framework (Test, defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)++import Data.IntSet++------------------------------------------------------------------------+-- * Properties++------------------------------------------------------------------------+-- ** Lazy module++pFoldlAccLazy :: Int -> Bool+pFoldlAccLazy k =+ isn'tBottom $ foldl (\_ x -> x) (bottom :: Int) (singleton k)++------------------------------------------------------------------------+-- * Test list++tests :: [Test]+tests =+ [+ -- Basic interface+ testGroup "IntSet"+ [ testProperty "foldl is lazy in accumulator" pFoldlAccLazy+ ]+ ]++------------------------------------------------------------------------+-- * Test harness++main :: IO ()+main = defaultMain tests++------------------------------------------------------------------------+-- * Utilities++isn'tBottom :: a -> Bool+isn'tBottom = not . isBottom