packages feed

containers 0.5.5.1 → 0.5.6.0

raw patch · 23 files changed

+1239/−490 lines, 23 filesdep −containersdep ~basedep ~deepseq

Dependencies removed: containers

Dependency ranges changed: base, deepseq

Files

− Data/BitUtil.hs 
@@ -1,71 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE MagicHash #-}-#endif-#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703-{-# LANGUAGE Trustworthy #-}-#endif--------------------------------------------------------------------------------- |--- Module      :  Data.BitUtil--- Copyright   :  (c) Clark Gaebel 2012---                (c) Johan Tibel 2012--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable--------------------------------------------------------------------------------module Data.BitUtil-    ( highestBitMask-    , shiftLL-    , shiftRL-    ) where---- On GHC, include MachDeps.h to get WORD_SIZE_IN_BITS macro.-#if defined(__GLASGOW_HASKELL__)-# include "MachDeps.h"-#endif--import Data.Bits ((.|.), xor)--#if __GLASGOW_HASKELL__-import GHC.Exts (Word(..), Int(..))-import GHC.Prim (uncheckedShiftL#, uncheckedShiftRL#)-#else-import Data.Word (shiftL, shiftR)-#endif---- The highestBitMask implementation is based on--- http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2--- which has been put in the public domain.---- | Return a word where only the highest bit is set.-highestBitMask :: Word -> Word-highestBitMask x1 = let x2 = x1 .|. x1 `shiftRL` 1-                        x3 = x2 .|. x2 `shiftRL` 2-                        x4 = x3 .|. x3 `shiftRL` 4-                        x5 = x4 .|. x4 `shiftRL` 8-                        x6 = x5 .|. x5 `shiftRL` 16-#if !(defined(__GLASGOW_HASKELL__) && WORD_SIZE_IN_BITS==32)-                        x7 = x6 .|. x6 `shiftRL` 32-                     in x7 `xor` (x7 `shiftRL` 1)-#else-                     in x6 `xor` (x6 `shiftRL` 1)-#endif-{-# INLINE highestBitMask #-}---- Right and left logical shifts.-shiftRL, shiftLL :: Word -> Int -> Word-#if __GLASGOW_HASKELL__-{---------------------------------------------------------------------  GHC: use unboxing to get @shiftRL@ inlined.---------------------------------------------------------------------}-shiftRL (W# x) (I# i) = W# (uncheckedShiftRL# x i)-shiftLL (W# x) (I# i) = W# (uncheckedShiftL#  x i)-#else-shiftRL x i   = shiftR x i-shiftLL x i   = shiftL x i-#endif-{-# INLINE shiftRL #-}-{-# INLINE shiftLL #-}
Data/Graph.hs view
@@ -244,7 +244,7 @@                                    EQ -> Just mid                                    GT -> findVertex (mid+1) b                               where-                                mid = (a + b) `div` 2+                                mid = a + (b - a) `div` 2  ------------------------------------------------------------------------- --                                                                      -
Data/IntMap.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Safe #-} #endif ----------------------------------------------------------------------------- -- |
Data/IntMap/Base.hs view
@@ -5,6 +5,17 @@ #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Trustworthy #-} #endif+{-# LANGUAGE ScopedTypeVariables #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE TypeFamilies #-}+#endif+-- 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.+#ifndef MIN_VERSION_base+#define MIN_VERSION_base(major1,major2,minor) 0+#endif+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.IntMap.Base@@ -207,7 +218,6 @@     , shorter     , branchMask     , highestBitMask-    , foldlStrict     ) where  import Control.Applicative (Applicative(pure, (<*>)), (<$>))@@ -222,17 +232,24 @@ import Data.Word (Word) import Prelude hiding (lookup, map, filter, foldr, foldl, null) -import Data.BitUtil import Data.IntSet.Base (Key) import qualified Data.IntSet.Base as IntSet-import Data.StrictPair+import Data.Utils.BitUtil+import Data.Utils.StrictFold+import Data.Utils.StrictPair  #if __GLASGOW_HASKELL__ import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix),                   DataType, mkDataType) import GHC.Exts (build)+#if __GLASGOW_HASKELL__ >= 708+import qualified GHC.Exts as GHCExts+#endif import Text.Read #endif+#if __GLASGOW_HASKELL__ >= 709+import Data.Coerce+#endif  -- Use macros to define strictness of functions. -- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.@@ -240,6 +257,7 @@ -- want the compilers to be compiled by as many compilers as possible. #define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined + -- A "Nat" is a natural machine word (an unsigned Int) type Nat = Word @@ -298,7 +316,7 @@     mconcat = unions  instance Foldable.Foldable IntMap where-  fold t = go t+  fold = go     where go Nil = mempty           go (Tip _ v) = v           go (Bin _ _ l r) = go l `mappend` go r@@ -313,6 +331,51 @@           go (Bin _ _ l r) = go l `mappend` go r   {-# INLINE foldMap #-} +#if MIN_VERSION_base(4,6,0)+  foldl' = foldl'+  {-# INLINE foldl' #-}+  foldr' = foldr'+  {-# INLINE foldr' #-}+#endif+#if MIN_VERSION_base(4,8,0)+  length = size+  {-# INLINE length #-}+  null   = null+  {-# INLINE null #-}+  toList = elems -- NB: Foldable.toList /= IntMap.toList+  {-# INLINE toList #-}+  elem = go+    where STRICT_1_OF_2(go)+          go _ Nil = False+          go x (Tip _ y) = x == y+          go x (Bin _ _ l r) = go x l || go x r+  {-# INLINABLE elem #-}+  maximum = start+    where start Nil = error "IntMap.Foldable.maximum: called with empty map"+          start (Tip _ y) = y+          start (Bin _ _ l r) = go (start l) r++          STRICT_1_OF_2(go)+          go m Nil = m+          go m (Tip _ y) = max m y+          go m (Bin _ _ l r) = go (go m l) r+  {-# INLINABLE maximum #-}+  minimum = start+    where start Nil = error "IntMap.Foldable.minimum: called with empty map"+          start (Tip _ y) = y+          start (Bin _ _ l r) = go (start l) r++          STRICT_1_OF_2(go)+          go m Nil = m+          go m (Tip _ y) = min m y+          go m (Bin _ _ l r) = go (go m l) r+  {-# INLINABLE minimum #-}+  sum = foldl' (+) 0+  {-# INLINABLE sum #-}+  product = foldl' (*) 1+  {-# INLINABLE product #-}+#endif+ instance Traversable IntMap where     traverse f = traverseWithKey (\_ -> f)     {-# INLINE traverse #-}@@ -1241,6 +1304,19 @@       Tip k x     -> Tip k (f x)       Nil         -> Nil +#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (f . g) xs+ #-}+#endif+#if __GLASGOW_HASKELL__ >= 709+-- Safe coercions were introduced in 7.8, but did not play well with RULES yet.+{-# RULES+"map/coerce" map coerce = coerce+ #-}+#endif+ -- | /O(n)/. Map a function over all values in the map. -- -- > let f key x = (show key) ++ ":" ++ x@@ -1253,6 +1329,18 @@       Tip k x     -> Tip k (f k x)       Nil         -> Nil +#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+  mapWithKey (\k a -> f k (g k a)) xs+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+  mapWithKey (\k a -> f k (g a)) xs+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+  mapWithKey (\k a -> f (g k a)) xs+ #-}+#endif+ -- | /O(n)/. -- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ -- That is, behaves exactly like a regular 'traverse' except that the traversing@@ -1770,6 +1858,13 @@ {--------------------------------------------------------------------   Lists --------------------------------------------------------------------}+#if __GLASGOW_HASKELL__ >= 708+instance GHCExts.IsList (IntMap a) where+  type Item (IntMap a) = (Key,a)+  fromList = fromList+  toList   = toList+#endif+ -- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list -- fusion. --@@ -1907,7 +2002,7 @@ -- -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] -fromDistinctAscList :: [(Key,a)] -> IntMap a+fromDistinctAscList :: forall a. [(Key,a)] -> IntMap a fromDistinctAscList []         = Nil fromDistinctAscList (z0 : zs0) = work z0 zs0 Nada   where@@ -2070,13 +2165,6 @@ {--------------------------------------------------------------------   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 #-}  -- | /O(1)/.  Decompose a map into pieces based on the structure of the underlying -- tree.  This function is useful for consuming a map in parallel.
Data/IntMap/Lazy.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Safe #-} #endif ----------------------------------------------------------------------------- -- |
Data/IntMap/Strict.hs view
@@ -256,9 +256,13 @@     , fromDistinctAscList     ) -import Data.BitUtil import qualified Data.IntSet.Base as IntSet-import Data.StrictPair+import Data.Utils.BitUtil+import Data.Utils.StrictFold+import Data.Utils.StrictPair+#if __GLASGOW_HASKELL__ >= 709+import Data.Coerce+#endif  -- $strictness --@@ -715,6 +719,18 @@       Tip k x     -> Tip k $! f x       Nil         -> Nil +#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (f . g) xs+ #-}+#endif+#if __GLASGOW_HASKELL__ >= 709+{-# RULES+"map/coerce" map coerce = coerce+ #-}+#endif+ -- | /O(n)/. Map a function over all values in the map. -- -- > let f key x = (show key) ++ ":" ++ x@@ -726,6 +742,18 @@       Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)       Tip k x     -> Tip k $! f k x       Nil         -> Nil++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+  mapWithKey (\k a -> f k (g k a)) xs+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+  mapWithKey (\k a -> f k (g a)) xs+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+  mapWithKey (\k a -> f (g k a)) xs+ #-}+#endif  -- | /O(n)/. The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys.
Data/IntSet/Base.hs view
@@ -5,6 +5,9 @@ #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Trustworthy #-} #endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE TypeFamilies #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Data.IntSet.Base@@ -159,27 +162,7 @@     , bitmapOf     ) where --- We want to be able to compile without cabal. Nevertheless--- #if defined(MIN_VERSION_base) && MIN_VERSION_base(4,5,0)--- does not work, because if MIN_VERSION_base is undefined,--- the last condition is syntactically wrong.-#define MIN_VERSION_base_4_5_0 0-#ifdef MIN_VERSION_base-#if MIN_VERSION_base(4,5,0)-#undef MIN_VERSION_base_4_5_0-#define MIN_VERSION_base_4_5_0 1-#endif-#endif--#define MIN_VERSION_base_4_7_0 0-#ifdef MIN_VERSION_base-#if MIN_VERSION_base(4,7,0)-#undef MIN_VERSION_base_4_7_0-#define MIN_VERSION_base_4_7_0 1-#endif-#endif--import Control.DeepSeq (NFData)+import Control.DeepSeq (NFData(rnf)) import Data.Bits import qualified Data.List as List import Data.Maybe (fromMaybe)@@ -188,8 +171,9 @@ import Data.Word (Word) import Prelude hiding (filter, foldr, foldl, null, map) -import Data.BitUtil-import Data.StrictPair+import Data.Utils.BitUtil+import Data.Utils.StrictFold+import Data.Utils.StrictPair  #if __GLASGOW_HASKELL__ import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix), DataType, mkDataType)@@ -198,6 +182,9 @@  #if __GLASGOW_HASKELL__ import GHC.Exts (Int(..), build)+#if __GLASGOW_HASKELL__ >= 708+import qualified GHC.Exts as GHCExts+#endif import GHC.Prim (indexInt8OffAddr#) #endif @@ -215,6 +202,14 @@ #define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined #define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefined +-- 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.+#ifndef MIN_VERSION_base+#define MIN_VERSION_base(major1,major2,minor) 0+#endif++ infixl 9 \\{-This comment teaches CPP correct behaviour -}  -- A "Nat" is a natural machine word (an unsigned Int)@@ -936,6 +931,13 @@ {--------------------------------------------------------------------   Lists --------------------------------------------------------------------}+#if __GLASGOW_HASKELL__ >= 708+instance GHCExts.IsList IntSet where+  type Item IntSet = Key+  fromList = fromList+  toList   = toList+#endif+ -- | /O(n)/. Convert the set to a list of elements. Subject to list fusion. toList :: IntSet -> [Key] toList@@ -1097,7 +1099,7 @@ -- The IntSet constructors consist only of strict fields of Ints and -- IntSets, thus the default NFData instance which evaluates to whnf -- should suffice-instance NFData IntSet+instance NFData IntSet where rnf x = seq x ()  {--------------------------------------------------------------------   Debugging@@ -1214,7 +1216,7 @@ ----------------------------------------------------------------------}  suffixBitMask :: Int-#if MIN_VERSION_base_4_7_0+#if MIN_VERSION_base(4,7,0) suffixBitMask = finiteBitSize (undefined::Word) - 1 #else suffixBitMask = bitSize (undefined::Word) - 1@@ -1465,7 +1467,7 @@ ----------------------------------------------------------------------}  bitcount :: Int -> Word -> Int-#if MIN_VERSION_base_4_5_0+#if MIN_VERSION_base(4,5,0) bitcount a x = a + popCount x #else bitcount a0 x0 = go a0 x0@@ -1478,12 +1480,6 @@ {--------------------------------------------------------------------   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 #-}  -- | /O(1)/.  Decompose a set into pieces based on the structure of the underlying -- tree.  This function is useful for consuming a set in parallel.
Data/Map/Base.hs view
@@ -5,6 +5,16 @@ #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Trustworthy #-} #endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TypeFamilies #-}+#endif+-- 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.+#ifndef MIN_VERSION_base+#define MIN_VERSION_base(major1,major2,minor) 0+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Data.Map.Base@@ -258,7 +268,6 @@     , glue     , trim     , trimLookupLo-    , foldlStrict     , MaybeS(..)     , filterGt     , filterLt@@ -269,18 +278,25 @@ import Data.Bits (shiftL, shiftR) import qualified Data.Foldable as Foldable import Data.Monoid (Monoid(..))-import Data.StrictPair import Data.Traversable (Traversable(traverse)) import Data.Typeable import Prelude hiding (lookup, map, filter, foldr, foldl, null)  import qualified Data.Set.Base as Set+import Data.Utils.StrictFold+import Data.Utils.StrictPair  #if __GLASGOW_HASKELL__ import GHC.Exts ( build )+#if __GLASGOW_HASKELL__ >= 708+import qualified GHC.Exts as GHCExts+#endif import Text.Read import Data.Data #endif+#if __GLASGOW_HASKELL__ >= 709+import Data.Coerce+#endif  -- Use macros to define strictness of functions. -- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.@@ -292,6 +308,7 @@ #define STRICT_1_OF_4(fn) fn arg _ _ _ | arg `seq` False = undefined #define STRICT_2_OF_4(fn) fn _ arg _ _ | arg `seq` False = undefined + {--------------------------------------------------------------------   Operators --------------------------------------------------------------------}@@ -1164,6 +1181,7 @@  -- | /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+-- empty map. -- -- > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b") -- > maxView empty == Nothing@@ -1644,6 +1662,18 @@ map :: (a -> b) -> Map k a -> Map k b map _ Tip = Tip map f (Bin sx kx x l r) = Bin sx kx (f x) (map f l) (map f r)+#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (f . g) xs+ #-}+#endif+#if __GLASGOW_HASKELL__ >= 709+-- Safe coercions were introduced in 7.8, but did not work well with RULES yet.+{-# RULES+"map/coerce" map coerce = coerce+ #-}+#endif  -- | /O(n)/. Map a function over all values in the map. --@@ -1654,6 +1684,18 @@ mapWithKey _ Tip = Tip mapWithKey f (Bin sx kx x l r) = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r) +#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+  mapWithKey (\k a -> f k (g k a)) xs+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+  mapWithKey (\k a -> f k (g a)) xs+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+  mapWithKey (\k a -> f (g k a)) xs+ #-}+#endif+ -- | /O(n)/. -- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ -- That is, behaves exactly like a regular 'traverse' except that the traversing@@ -1948,6 +1990,13 @@   Lists   use [foldlStrict] to reduce demand on the control-stack --------------------------------------------------------------------}+#if __GLASGOW_HASKELL__ >= 708+instance (Ord k) => GHCExts.IsList (Map k v) where+  type Item (Map k v) = (k,v)+  fromList = fromList+  toList   = toList+#endif+ -- | /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.@@ -2624,7 +2673,7 @@   {-# INLINE traverse #-}  instance Foldable.Foldable (Map k) where-  fold t = go t+  fold = go     where go Tip = mempty           go (Bin 1 _ v _ _) = v           go (Bin _ _ v l r) = go l `mappend` (v `mappend` go r)@@ -2639,6 +2688,46 @@           go (Bin _ _ v l r) = go l `mappend` (f v `mappend` go r)   {-# INLINE foldMap #-} +#if MIN_VERSION_base(4,6,0)+  foldl' = foldl'+  {-# INLINE foldl' #-}+  foldr' = foldr'+  {-# INLINE foldr' #-}+#endif+#if MIN_VERSION_base(4,8,0)+  length = size+  {-# INLINE length #-}+  null   = null+  {-# INLINE null #-}+  toList = elems -- NB: Foldable.toList /= Map.toList+  {-# INLINE toList #-}+  elem = go+    where STRICT_1_OF_2(go)+          go _ Tip = False+          go x (Bin _ _ v l r) = x == v || go x l || go x r+  {-# INLINABLE elem #-}+  maximum = start+    where start Tip = error "Map.Foldable.maximum: called with empty map"+          start (Bin _ _ v l r) = go (go v l) r++          STRICT_1_OF_2(go)+          go m Tip = m+          go m (Bin _ _ v l r) = go (go (max m v) l) r+  {-# INLINABLE maximum #-}+  minimum = start+    where start Tip = error "Map.Foldable.minumum: called with empty map"+          start (Bin _ _ v l r) = go (go v l) r++          STRICT_1_OF_2(go)+          go m Tip = m+          go m (Bin _ _ v l r) = go (go (min m v) l) r+  {-# INLINABLE minimum #-}+  sum = foldl' (+) 0+  {-# INLINABLE sum #-}+  product = foldl' (*) 1+  {-# INLINABLE product #-}+#endif+ instance (NFData k, NFData a) => NFData (Map k a) where     rnf Tip = ()     rnf (Bin _ kx x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r@@ -2812,13 +2901,6 @@ {--------------------------------------------------------------------   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 #-}-  -- | /O(1)/.  Decompose a map into pieces based on the structure of the underlying -- tree.  This function is useful for consuming a map in parallel.
Data/Map/Strict.hs view
@@ -1,7 +1,13 @@ {-# LANGUAGE CPP #-} #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703-{-# LANGUAGE Safe #-}+{-# LANGUAGE Trustworthy #-} #endif+-- 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.+#ifndef MIN_VERSION_base+#define MIN_VERSION_base(major1,major2,minor) 0+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Data.Map.Strict@@ -269,8 +275,13 @@     , updateMaxWithKey     ) import qualified Data.Set.Base as Set-import Data.StrictPair+import Data.Utils.StrictFold+import Data.Utils.StrictPair+ import Data.Bits (shiftL, shiftR)+#if __GLASGOW_HASKELL__ >= 709+import Data.Coerce+#endif  -- Use macros to define strictness of functions.  STRICT_x_OF_y -- denotes an y-ary function strict in the x-th parameter. Similarly@@ -924,6 +935,18 @@ map :: (a -> b) -> Map k a -> Map k b map _ Tip = Tip map f (Bin sx kx x l r) = let x' = f x in x' `seq` Bin sx kx x' (map f l) (map f r)+#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (f . g) xs+ #-}+#endif+#if __GLASGOW_HASKELL__ >= 709+-- Safe coercions were introduced in 7.8, but did not work well with RULES yet.+{-# RULES+"mapSeq/coerce" map coerce = coerce+ #-}+#endif  -- | /O(n)/. Map a function over all values in the map. --@@ -932,8 +955,21 @@  mapWithKey :: (k -> a -> b) -> Map k a -> Map k b mapWithKey _ Tip = Tip-mapWithKey f (Bin sx kx x l r) = let x' = f kx x-                                 in x' `seq` Bin sx kx x' (mapWithKey f l) (mapWithKey f r)+mapWithKey f (Bin sx kx x l r) =+  let x' = f kx x+  in x' `seq` Bin sx kx x' (mapWithKey f l) (mapWithKey f r)++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+  mapWithKey (\k a -> f k (g k a)) xs+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+  mapWithKey (\k a -> f k (g a)) xs+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+  mapWithKey (\k a -> f (g k a)) xs+ #-}+#endif  -- | /O(n)/. The function 'mapAccum' threads an accumulating -- argument through the map in ascending order of keys.
Data/Sequence.hs view
@@ -5,11 +5,21 @@ #if __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Trustworthy #-} #endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE TypeFamilies #-}+#endif+-- 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.+#ifndef MIN_VERSION_base+#define MIN_VERSION_base(major1,major2,minor) 0+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Data.Sequence -- Copyright   :  (c) Ross Paterson 2005 --                (c) Louis Wasserman 2009+--                (c) David Feuer and Milan Straka 2014 -- License     :  BSD-style -- Maintainer  :  libraries@haskell.org -- Stability   :  experimental@@ -30,7 +40,7 @@ --    * Ralf Hinze and Ross Paterson, --      \"Finger trees: a simple general-purpose data structure\", --      /Journal of Functional Programming/ 16:2 (2006) pp 197-217.---      <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>+--      <http://staff.city.ac.uk/~ross/papers/FingerTree.html> -- -- /Note/: Many of these operations have the same names as similar -- operations on lists in the "Prelude".  The ambiguity may be resolved@@ -51,6 +61,8 @@     (|>),           -- :: Seq a -> a -> Seq a     (><),           -- :: Seq a -> Seq a -> Seq a     fromList,       -- :: [a] -> Seq a+    fromFunction,   -- :: Int -> (Int -> a) -> Seq a+    fromArray,      -- :: Ix i => Array i a -> Seq a     -- ** Repetition     replicate,      -- :: Int -> a -> Seq a     replicateA,     -- :: Applicative f => Int -> f a -> f (Seq a)@@ -149,10 +161,19 @@ import Control.Monad (MonadPlus(..), ap) import Data.Monoid (Monoid(..)) import Data.Functor (Functor(..))-import Data.Foldable+#if MIN_VERSION_base(4,8,0)+import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, foldl', foldr', toList))+#else+#if MIN_VERSION_base(4,6,0)+import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, foldl'), toList)+#else+import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap), foldl', toList)+#endif+#endif import Data.Traversable import Data.Typeable +-- GHC specific stuff #ifdef __GLASGOW_HASKELL__ import GHC.Exts (build) import Text.Read (Lexeme(Ident), lexP, parens, prec,@@ -160,6 +181,25 @@ import Data.Data #endif +-- Array stuff, with GHC.Arr on GHC+import Data.Array (Ix, Array)+import qualified Data.Array+#ifdef __GLASGOW_HASKELL__+import qualified GHC.Arr+#endif++-- Coercion on GHC 7.8++#if __GLASGOW_HASKELL__ >= 708+import Data.Coerce+import qualified GHC.Exts+#else+#endif++-- Identity functor on base 4.8 (GHC 7.10+)+#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity(..))+#endif+ infixr 5 `consTree` infixl 5 `snocTree` @@ -174,12 +214,28 @@ newtype Seq a = Seq (FingerTree (Elem a))  instance Functor Seq where-    fmap f (Seq xs) = Seq (fmap (fmap f) xs)+    fmap = fmapSeq #ifdef __GLASGOW_HASKELL__     x <$ s = replicate (length s) x #endif +fmapSeq :: (a -> b) -> Seq a -> Seq b+fmapSeq f (Seq xs) = Seq (fmap (fmap f) xs)+#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] fmapSeq #-}+{-# RULES+"fmapSeq/fmapSeq" forall f g xs . fmapSeq f (fmapSeq g xs) = fmapSeq (f . g) xs+ #-}+#endif+#if __GLASGOW_HASKELL__ >= 709+-- Safe coercions were introduced in 7.8, but did not work well with RULES yet.+{-# RULES+"fmapSeq/coerce" fmapSeq coerce = coerce+ #-}+#endif+ instance Foldable Seq where+    foldMap f (Seq xs) = foldMap (foldMap f) xs     foldr f z (Seq xs) = foldr (flip (foldr f)) z xs     foldl f z (Seq xs) = foldl (foldl f) z xs @@ -189,6 +245,15 @@     foldl1 f (Seq xs) = getElem (foldl1 f' xs)       where f' (Elem x) (Elem y) = Elem (f x y) +#if MIN_VERSION_base(4,8,0)+    length = length+    {-# INLINE length #-}+    null   = null+    {-# INLINE null #-}+    toList   = toList+    {-# INLINE toList #-}+#endif+ instance Traversable Seq where     traverse f (Seq xs) = Seq <$> traverse (traverse f) xs @@ -199,11 +264,13 @@     return = singleton     xs >>= f = foldl' add empty xs       where add ys x = ys >< f x+    (>>) = (*>)  instance Applicative Seq where     pure = singleton     fs <*> xs = foldl' add empty fs       where add ys f = ys >< fmap f xs+    xs *> ys = replicateSeq (length xs) ys  instance MonadPlus Seq where     mzero = empty@@ -295,6 +362,11 @@     size (Deep v _ _ _)     = v  instance Foldable FingerTree where+    foldMap _ Empty = mempty+    foldMap f (Single x) = f x+    foldMap f (Deep _ pr m sf) =+        foldMap f pr `mappend` (foldMap (foldMap f) m `mappend` foldMap f sf)+     foldr _ z Empty = z     foldr f z (Single x) = x `f` z     foldr f z (Deep _ pr m sf) =@@ -331,7 +403,7 @@ instance NFData a => NFData (FingerTree a) where     rnf (Empty) = ()     rnf (Single x) = rnf x-    rnf (Deep _ pr m sf) = rnf pr `seq` rnf m `seq` rnf sf+    rnf (Deep _ pr m sf) = rnf pr `seq` rnf sf `seq` rnf m  {-# INLINE deep #-} deep            :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a@@ -373,6 +445,11 @@ #endif  instance Foldable Digit where+    foldMap f (One a) = f a+    foldMap f (Two a b) = f a `mappend` f b+    foldMap f (Three a b c) = f a `mappend` (f b `mappend` f c)+    foldMap f (Four a b c d) = f a `mappend` (f b `mappend` (f c `mappend` f d))+     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))@@ -443,6 +520,9 @@ #endif  instance Foldable Node where+    foldMap f (Node2 _ a b) = f a `mappend` f b+    foldMap f (Node3 _ a b c) = f a `mappend` (f b `mappend` f c)+     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)) @@ -493,6 +573,7 @@     fmap f (Elem x) = Elem (f x)  instance Foldable Elem where+    foldMap f (Elem x) = f x     foldr f z (Elem x) = f x z     foldl f z (Elem x) = f z x @@ -505,19 +586,16 @@ ------------------------------------------------------- -- Applicative construction ---------------------------------------------------------newtype Id a = Id {runId :: a}--instance Functor Id where-    fmap f (Id x) = Id (f x)+#if !MIN_VERSION_base(4,8,0)+newtype Identity a = Identity {runIdentity :: a} -instance Monad Id where-    return = Id-    m >>= k = k (runId m)+instance Functor Identity where+    fmap f (Identity x) = Identity (f x) -instance Applicative Id where-    pure = return-    (<*>) = ap+instance Applicative Identity where+    pure = Identity+    Identity f <*> Identity x = Identity (f x)+#endif  -- | This is essentially a clone of Control.Monad.State.Strict. newtype State s a = State {runState :: s -> (s, a)}@@ -539,23 +617,19 @@ 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,+{-# SPECIALIZE applicativeTree :: Int -> Int -> Identity a -> Identity (FingerTree a) #-}+-- Special note: the Identity 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+    1 -> fmap Single m     2 -> deepA one emptyTree one     3 -> deepA two emptyTree one     4 -> deepA two emptyTree two@@ -563,12 +637,12 @@     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+    _ -> case n `quotRem` 3 of+           (q,0) -> deepA three (applicativeTree (q - 2) mSize' n3) three+           (q,1) -> deepA four  (applicativeTree (q - 2) mSize' n3) three+           (q,_) -> deepA four  (applicativeTree (q - 2) mSize' n3) four   where-    one = liftA One m+    one = fmap One m     two = liftA2 Two m m     three = liftA3 Three m m m     four = liftA3 Four m m m <*> m@@ -592,7 +666,7 @@ -- | /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))+  | n >= 0      = runIdentity (replicateA n (Identity x))   | otherwise   = error "replicate takes a nonnegative integer argument"  -- | 'replicateA' is an 'Applicative' version of 'replicate', and makes@@ -612,6 +686,19 @@   | 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"+  | 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)+ -- | /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@@ -994,6 +1081,9 @@     fmap f (xs :> x)    = fmap f xs :> f x  instance Foldable ViewR where+    foldMap _ EmptyR = mempty+    foldMap f (xs :> x) = foldMap f xs `mappend` f x+     foldr _ z EmptyR = z     foldr f z (xs :> x) = foldr f (f x z) xs @@ -1002,7 +1092,15 @@      foldr1 _ EmptyR = error "foldr1: empty view"     foldr1 f (xs :> x) = foldr f x xs+#if MIN_VERSION_base(4,8,0)+    -- The default definitions are sensible for ViewL, but not so much for+    -- ViewR.+    null EmptyR = True+    null (_ :> _) = False +    length = foldr' (\_ k -> k+1) 0+#endif+ instance Traversable ViewR where     traverse _ EmptyR       = pure EmptyR     traverse f (xs :> x)    = (:>) <$> traverse f xs <*> f x@@ -1086,14 +1184,14 @@ 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)+lookupTree i (Deep totalSize 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+    spm     = totalSize - size sf  {-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-} {-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}@@ -1205,12 +1303,121 @@     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+-- | /O(n)/. 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)+mapWithIndex f' (Seq xs') = Seq $ mapWithIndexTree (\s (Elem a) -> Elem (f' s a)) 0 xs'+ where+  {-# SPECIALIZE mapWithIndexTree :: (Int -> Elem y -> b) -> Int -> FingerTree (Elem y) -> FingerTree b #-}+  {-# SPECIALIZE mapWithIndexTree :: (Int -> Node y -> b) -> Int -> FingerTree (Node y) -> FingerTree b #-}+  mapWithIndexTree :: Sized a => (Int -> a -> b) -> Int -> FingerTree a -> FingerTree b+  mapWithIndexTree _ s Empty = s `seq` Empty+  mapWithIndexTree f s (Single xs) = Single $ f s xs+  mapWithIndexTree f s (Deep n pr m sf) = sPspr `seq` sPsprm `seq`+          Deep n+               (mapWithIndexDigit f s pr)+               (mapWithIndexTree (mapWithIndexNode f) sPspr m)+               (mapWithIndexDigit f sPsprm sf)+    where+      sPspr = s + size pr+      sPsprm = s + n - size sf +  {-# SPECIALIZE mapWithIndexDigit :: (Int -> Elem y -> b) -> Int -> Digit (Elem y) -> Digit b #-}+  {-# SPECIALIZE mapWithIndexDigit :: (Int -> Node y -> b) -> Int -> Digit (Node y) -> Digit b #-}+  mapWithIndexDigit :: Sized a => (Int -> a -> b) -> Int -> Digit a -> Digit b+  mapWithIndexDigit f s (One a) = One (f s a)+  mapWithIndexDigit f s (Two a b) = sPsa `seq` Two (f s a) (f sPsa b)+    where+      sPsa = s + size a+  mapWithIndexDigit f s (Three a b c) = sPsa `seq` sPsab `seq`+                                      Three (f s a) (f sPsa b) (f sPsab c)+    where+      sPsa = s + size a+      sPsab = sPsa + size b+  mapWithIndexDigit f s (Four a b c d) = sPsa `seq` sPsab `seq` sPsabc `seq`+                          Four (f s a) (f sPsa b) (f sPsab c) (f sPsabc d)+    where+      sPsa = s + size a+      sPsab = sPsa + size b+      sPsabc = sPsab + size c++  {-# SPECIALIZE mapWithIndexNode :: (Int -> Elem y -> b) -> Int -> Node (Elem y) -> Node b #-}+  {-# SPECIALIZE mapWithIndexNode :: (Int -> Node y -> b) -> Int -> Node (Node y) -> Node b #-}+  mapWithIndexNode :: Sized a => (Int -> a -> b) -> Int -> Node a -> Node b+  mapWithIndexNode f s (Node2 ns a b) = sPsa `seq` Node2 ns (f s a) (f sPsa b)+    where+      sPsa = s + size a+  mapWithIndexNode f s (Node3 ns a b c) = sPsa `seq` sPsab `seq`+                                     Node3 ns (f s a) (f sPsa b) (f sPsab c)+    where+      sPsa = s + size a+      sPsab = sPsa + size b++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] mapWithIndex #-}+{-# RULES+"mapWithIndex/mapWithIndex" forall f g xs . mapWithIndex f (mapWithIndex g xs) =+  mapWithIndex (\k a -> f k (g k a)) xs+"mapWithIndex/fmapSeq" forall f g xs . mapWithIndex f (fmapSeq g xs) =+  mapWithIndex (\k a -> f k (g a)) xs+"fmapSeq/mapWithIndex" forall f g xs . fmapSeq f (mapWithIndex g xs) =+  mapWithIndex (\k a -> f (g k a)) xs+ #-}+#endif++-- | /O(n)/. Convert a given sequence length and a function representing that+-- sequence into a sequence.+fromFunction :: Int -> (Int -> a) -> Seq a+fromFunction len f | len < 0 = error "Data.Sequence.fromFunction called with negative len"+                   | len == 0 = empty+                   | otherwise = Seq $ create (lift_elem f) 1 0 len+  where+    create :: (Int -> a) -> Int -> Int -> Int -> FingerTree a+    create b{-tree_builder-} s{-tree_size-} i{-start_index-} trees = i `seq` s `seq` case trees of+       1 -> Single $ b i+       2 -> Deep (2*s) (One (b i)) Empty (One (b (i+s)))+       3 -> Deep (3*s) (createTwo i) Empty (One (b (i+2*s)))+       4 -> Deep (4*s) (createTwo i) Empty (createTwo (i+2*s))+       5 -> Deep (5*s) (createThree i) Empty (createTwo (i+3*s))+       6 -> Deep (6*s) (createThree i) Empty (createThree (i+3*s))+       _ -> case trees `quotRem` 3 of+           (trees', 1) -> Deep (trees*s) (createTwo i)+                              (create mb (3*s) (i+2*s) (trees'-1))+                              (createTwo (i+(2+3*(trees'-1))*s))+           (trees', 2) -> Deep (trees*s) (createThree i)+                              (create mb (3*s) (i+3*s) (trees'-1))+                              (createTwo (i+(3+3*(trees'-1))*s))+           (trees', _) -> Deep (trees*s) (createThree i)+                              (create mb (3*s) (i+3*s) (trees'-2))+                              (createThree (i+(3+3*(trees'-2))*s))+      where+        createTwo j = Two (b j) (b (j + s))+        {-# INLINE createTwo #-}+        createThree j = Three (b j) (b (j + s)) (b (j + 2*s))+        {-# INLINE createThree #-}+        mb j = Node3 (3*s) (b j) (b (j + s)) (b (j + 2*s))+        {-# INLINE mb #-}++    lift_elem :: (Int -> a) -> (Int -> Elem a)+#if __GLASGOW_HASKELL__ >= 708+    lift_elem g = coerce g+#else+    lift_elem g = Elem . g+#endif+    {-# INLINE lift_elem #-}++-- | /O(n)/. Create a sequence consisting of the elements of an 'Array'.+-- Note that the resulting sequence elements may be evaluated lazily (as on GHC),+-- so you must force the entire structure to be sure that the original array+-- can be garbage-collected.+fromArray :: Ix i => Array i a -> Seq a+#ifdef __GLASGOW_HASKELL__+fromArray a = fromFunction (GHC.Arr.numElements a) (GHC.Arr.unsafeAt a)+#else+fromArray a = fromList2 (Data.Array.rangeSize (Data.Array.bounds a)) (Data.Array.elems a)+#endif+ -- Splitting  -- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.@@ -1218,14 +1425,14 @@ -- If the sequence contains fewer than @i@ elements, the whole sequence -- is returned. take            :: Int -> Seq a -> Seq a-take i          =  fst . splitAt i+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+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)@.@@ -1233,13 +1440,18 @@ splitAt i (Seq xs)      =  (Seq l, Seq r)   where (l, r)          =  split i xs +-- | /O(log(min(i,n-i))) A strict version of 'splitAt'.+splitAt'                 :: Int -> Seq a -> (Seq a, Seq a)+splitAt' i (Seq xs)      = case split i xs of+                             (l, r) -> (Seq l, Seq r)+ 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)+  | size xs > i = case splitTree i xs of+                    Split l x r -> (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@@ -1564,12 +1776,50 @@ -- Lists ------------------------------------------------------------------------ +-- The implementation below, by Ross Paterson, avoids the rebuilding+-- the previous (|>)-based implementation suffered from.+ -- | /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+fromList xs = Seq $ mkTree 1 $ map_elem xs+  where+    {-# SPECIALIZE mkTree :: Int -> [Elem a] -> FingerTree (Elem a) #-}+    {-# SPECIALIZE mkTree :: Int -> [Node a] -> FingerTree (Node a) #-}+    mkTree :: (Sized a) => Int -> [a] -> FingerTree a+    mkTree s [] = s `seq` Empty+    mkTree s [x1] = s `seq` Single x1+    mkTree s [x1, x2] = Deep (2*s) (One x1) Empty (One x2)+    mkTree s [x1, x2, x3] = Deep (3*s) (One x1) Empty (Two x2 x3)+    mkTree s (x1:x2:x3:xs) = s `seq` case getNodes (3*s) xs of+                                       (ns, sf) -> m `seq` deep' (Three x1 x2 x3) m sf+                                           where m = mkTree (3*s) ns +    deep' pr@(Three x1 _ _) m sf = Deep (3*size x1 + size m + size sf) pr m sf++    getNodes :: Int -> [a] -> ([Node a], Digit a)+    getNodes s [x1] = s `seq` ([], One x1)+    getNodes s [x1, x2] = s `seq` ([], Two x1 x2)+    getNodes s [x1, x2, x3] = s `seq` ([], Three x1 x2 x3)+    getNodes s (x1:x2:x3:xs) = s `seq` (Node3 s x1 x2 x3:ns, d)+       where (ns, d) = getNodes s xs++    map_elem :: [a] -> [Elem a]+#if __GLASGOW_HASKELL__ >= 708+    map_elem xs = coerce xs+#else+    map_elem xs = Data.List.map Elem xs+#endif+    {-# INLINE map_elem #-}++#if __GLASGOW_HASKELL__ >= 708+instance GHC.Exts.IsList (Seq a) where+    type Item (Seq a) = a+    fromList = fromList+    toList = toList+#endif+ ------------------------------------------------------------------------ -- Reverse ------------------------------------------------------------------------@@ -1598,6 +1848,136 @@ reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)  ------------------------------------------------------------------------+-- Mapping with a splittable value+------------------------------------------------------------------------++-- For zipping, and probably also for (<*>), it is useful to build a result by+-- traversing a sequence while splitting up something else.  For zipping, we+-- traverse the first sequence while splitting up the second [and third [and+-- fourth]]. For fs <*> xs, we hope to traverse+--+-- > replicate (length fs * length xs) ()+--+-- while splitting something essentially equivalent to+--+-- > fmap (\f -> fmap f xs) fs+--+-- What makes all this crazy code a good idea:+--+-- Suppose we zip together two sequences of the same length:+--+-- zs = zip xs ys+--+-- We want to get reasonably fast indexing into zs immediately, rather than+-- needing to construct the entire thing first, as the previous implementation+-- required. The first aspect is that we build the result "outside-in" or+-- "top-down", rather than left to right. That gives us access to both ends+-- quickly. But that's not enough, by itself, to give immediate access to the+-- center of zs. For that, we need to be able to skip over larger segments of+-- zs, delaying their construction until we actually need them. The way we do+-- this is to traverse xs, while splitting up ys according to the structure of+-- xs. If we have a Deep _ pr m sf, we split ys into three pieces, and hand off+-- one piece to the prefix, one to the middle, and one to the suffix of the+-- result. The key point is that we don't need to actually do anything further+-- with those pieces until we actually need them; the computations to split+-- them up further and zip them with their matching pieces can be delayed until+-- they're actually needed. We do the same thing for Digits (splitting into+-- between one and four pieces) and Nodes (splitting into two or three). The+-- ultimate result is that we can index, or split at, any location in zs in+-- O(log(min{i,n-i})) time *immediately*, with only a constant-factor slowdown+-- as thunks are forced along the path.+--+-- Benchmark info, and alternatives:+--+-- The old zipping code used mapAccumL to traverse the first sequence while+-- cutting down the second sequence one piece at a time.+--+-- An alternative way to express that basic idea is to convert both sequences+-- to lists, zip the lists, and then convert the result back to a sequence.+-- I'll call this the "listy" implementation.+--+-- I benchmarked two operations: Each started by zipping two sequences+-- constructed with replicate and/or fromList. The first would then immediately+-- index into the result. The second would apply deepseq to force the entire+-- result.  The new implementation worked much better than either of the others+-- on the immediate indexing test, as expected. It also worked better than the+-- old implementation for all the deepseq tests. For short sequences, the listy+-- implementation outperformed all the others on the deepseq test. However, the+-- splitting implementation caught up and surpassed it once the sequences grew+-- long enough. It seems likely that by avoiding rebuilding, it interacts+-- better with the cache hierarchy.+--+-- David Feuer, with excellent guidance from Carter Schonwald, December 2014++-- | /O(n)/. Constructs a new sequence with the same structure as an existing+-- sequence using a user-supplied mapping function along with a splittable+-- value and a way to split it. The value is split up lazily according to the+-- structure of the sequence, so one piece of the value is distributed to each+-- element of the sequence. The caller should provide a splitter function that+-- takes a number, @n@, and a splittable value, breaks off a chunk of size @n@+-- from the value, and returns that chunk and the remainder as a pair. The+-- following examples will hopefully make the usage clear:+--+-- > zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+-- > zipWith f s1 s2 = splitMap splitAt (\b a -> f a (b `index` 0)) s2' s1'+-- >   where+-- >     minLen = min (length s1) (length s2)+-- >     s1' = take minLen s1+-- >     s2' = take minLen s2+--+-- > mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b+-- > mapWithIndex f = splitMap (\n i -> (i, n+i)) f 0+splitMap :: (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Seq a -> Seq b+splitMap splt' = go+ where+  go f s (Seq xs) = Seq $ splitMapTree splt' (\s' (Elem a) -> Elem (f s' a)) s xs++  {-# SPECIALIZE splitMapTree :: (Int -> s -> (s,s)) -> (s -> Elem y -> b) -> s -> FingerTree (Elem y) -> FingerTree b #-}+  {-# SPECIALIZE splitMapTree :: (Int -> s -> (s,s)) -> (s -> Node y -> b) -> s -> FingerTree (Node y) -> FingerTree b #-}+  splitMapTree :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> FingerTree a -> FingerTree b+  splitMapTree _    _ _ Empty = Empty+  splitMapTree _    f s (Single xs) = Single $ f s xs+  splitMapTree splt f s (Deep n pr m sf) = Deep n (splitMapDigit splt f prs pr) (splitMapTree splt (splitMapNode splt f) ms m) (splitMapDigit splt f sfs sf)+    where+      (prs, r) = splt (size pr) s+      (ms, sfs) = splt (n - size pr - size sf) r++  {-# SPECIALIZE splitMapDigit :: (Int -> s -> (s,s)) -> (s -> Elem y -> b) -> s -> Digit (Elem y) -> Digit b #-}+  {-# SPECIALIZE splitMapDigit :: (Int -> s -> (s,s)) -> (s -> Node y -> b) -> s -> Digit (Node y) -> Digit b #-}+  splitMapDigit :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Digit a -> Digit b+  splitMapDigit _    f s (One a) = One (f s a)+  splitMapDigit splt f s (Two a b) = Two (f first a) (f second b)+    where+      (first, second) = splt (size a) s+  splitMapDigit splt f s (Three a b c) = Three (f first a) (f second b) (f third c)+    where+      (first, r) = splt (size a) s+      (second, third) = splt (size b) r+  splitMapDigit splt f s (Four a b c d) = Four (f first a) (f second b) (f third c) (f fourth d)+    where+      (first, s') = splt (size a) s+      (middle, fourth) = splt (size b + size c) s'+      (second, third) = splt (size b) middle++  {-# SPECIALIZE splitMapNode :: (Int -> s -> (s,s)) -> (s -> Elem y -> b) -> s -> Node (Elem y) -> Node b #-}+  {-# SPECIALIZE splitMapNode :: (Int -> s -> (s,s)) -> (s -> Node y -> b) -> s -> Node (Node y) -> Node b #-}+  splitMapNode :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Node a -> Node b+  splitMapNode splt f s (Node2 ns a b) = Node2 ns (f first a) (f second b)+    where+      (first, second) = splt (size a) s+  splitMapNode splt f s (Node3 ns a b c) = Node3 ns (f first a) (f second b) (f third c)+    where+      (first, r) = splt (size a) s+      (second, third) = splt (size b) r++{-# INLINE splitMap #-}++getSingleton :: Seq a -> a+getSingleton (Seq (Single (Elem a))) = a+getSingleton (Seq Empty) = error "getSingleton: Empty"+getSingleton _ = error "getSingleton: Not a singleton."++------------------------------------------------------------------------ -- Zipping ------------------------------------------------------------------------ @@ -1612,17 +1992,15 @@ -- 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+zipWith f s1 s2 = zipWith' f s1' s2'+  where+    minLen = min (length s1) (length s2)+    s1' = take minLen s1+    s2' = take minLen s2 --- like 'zipWith', but assumes length xs <= length ys+-- | A version of zipWith that assumes the sequences have the same length. 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"+zipWith' f s1 s2 = splitMap splitAt' (\s a -> f a (getSingleton s)) s2 s1  -- | /O(min(n1,n2,n3))/.  'zip3' takes three sequences and returns a -- sequence of triples, analogous to 'zip'.@@ -1633,8 +2011,16 @@ -- 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+zipWith3 f s1 s2 s3 = zipWith' ($) (zipWith' f s1' s2') s3'+  where+    minLen = minimum [length s1, length s2, length s3]+    s1' = take minLen s1+    s2' = take minLen s2+    s3' = take minLen s3 +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)@@ -1644,7 +2030,13 @@ -- 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+zipWith4 f s1 s2 s3 s4 = zipWith' ($) (zipWith3' f s1' s2' s3') s4'+  where+    minLen = minimum [length s1, length s2, length s3, length s4]+    s1' = take minLen s1+    s2' = take minLen s2+    s3' = take minLen s3+    s4' = take minLen s4  ------------------------------------------------------------------------ -- Sorting
Data/Set/Base.hs view
@@ -5,6 +5,10 @@ #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Trustworthy #-} #endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TypeFamilies #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Data.Set.Base@@ -190,10 +194,14 @@ import Data.Typeable import Control.DeepSeq (NFData(rnf)) -import Data.StrictPair+import Data.Utils.StrictFold+import Data.Utils.StrictPair  #if __GLASGOW_HASKELL__ import GHC.Exts ( build )+#if __GLASGOW_HASKELL__ >= 708+import qualified GHC.Exts as GHCExts+#endif import Text.Read import Data.Data #endif@@ -206,6 +214,14 @@ #define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined #define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefined +-- 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.+#ifndef MIN_VERSION_base+#define MIN_VERSION_base(major1,major2,minor) 0+#endif++ {--------------------------------------------------------------------   Operators --------------------------------------------------------------------}@@ -239,7 +255,7 @@     mconcat = unions  instance Foldable.Foldable Set where-    fold t = go t+    fold = go       where go Tip = mempty             go (Bin 1 k _ _) = k             go (Bin _ k l r) = go l `mappend` (k `mappend` go r)@@ -254,6 +270,35 @@             go (Bin _ k l r) = go l `mappend` (f k `mappend` go r)     {-# INLINE foldMap #-} +#if MIN_VERSION_base(4,6,0)+    foldl' = foldl'+    {-# INLINE foldl' #-}+    foldr' = foldr'+    {-# INLINE foldr' #-}+#endif+#if MIN_VERSION_base(4,8,0)+    length = size+    {-# INLINE length #-}+    null   = null+    {-# INLINE null #-}+    toList = toList+    {-# INLINE toList #-}+    elem = go+      where STRICT_1_OF_2(go)+            go _ Tip = False+            go x (Bin _ y l r) = x == y || go x l || go x r+    {-# INLINABLE elem #-}+    minimum = findMin+    {-# INLINE minimum #-}+    maximum = findMax+    {-# INLINE maximum #-}+    sum = foldl' (+) 0+    {-# INLINABLE sum #-}+    product = foldl' (*) 1+    {-# INLINABLE product #-}+#endif++ #if __GLASGOW_HASKELL__  {--------------------------------------------------------------------@@ -763,6 +808,13 @@ {--------------------------------------------------------------------   Lists --------------------------------------------------------------------}+#if __GLASGOW_HASKELL__ >= 708+instance (Ord a) => GHCExts.IsList (Set a) where+  type Item (Set a) = a+  fromList = fromList+  toList   = toList+#endif+ -- | /O(n)/. Convert the set to a list of elements. Subject to list fusion. toList :: Set a -> [a] toList = toAscList@@ -1402,12 +1454,6 @@ {--------------------------------------------------------------------   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 #-}  -- | /O(1)/.  Decompose a set into pieces based on the structure of the underlying -- tree.  This function is useful for consuming a set in parallel.
− Data/StrictPair.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE CPP #-}-#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703-{-# LANGUAGE Trustworthy #-}-#endif-module Data.StrictPair (StrictPair(..), toPair) where---- | Same as regular Haskell pairs, but (x :*: _|_) = (_|_ :*: y) =--- _|_-data StrictPair a b = !a :*: !b--toPair :: StrictPair a b -> (a, b)-toPair (x :*: y) = (x, y)-{-# INLINE toPair #-}
Data/Tree.hs view
@@ -3,8 +3,15 @@ {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} #endif #if __GLASGOW_HASKELL__ >= 703-{-# LANGUAGE Safe #-}+{-# LANGUAGE Trustworthy #-} #endif+-- 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.+#ifndef MIN_VERSION_base+#define MIN_VERSION_base(major1,major2,minor) 0+#endif+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Tree@@ -32,7 +39,7 @@     ) where  import Control.Applicative (Applicative(..), (<$>))-import Control.Monad+import Control.Monad (liftM) import Data.Monoid (Monoid(..)) import Data.Sequence (Seq, empty, singleton, (<|), (|>), fromList,             ViewL(..), ViewR(..), viewl, viewr)@@ -45,6 +52,11 @@ import Data.Data (Data) #endif +#if MIN_VERSION_base(4,8,0)+import Data.Coerce+#endif++ -- | Multi-way trees, also known as /rose trees/. data Tree a = Node {         rootLabel :: a,         -- ^ label value@@ -61,8 +73,19 @@ INSTANCE_TYPEABLE1(Tree,treeTc,"Tree")  instance Functor Tree where-    fmap f (Node x ts) = Node (f x) (map (fmap f) ts)+    fmap = fmapTree +fmapTree :: (a -> b) -> Tree a -> Tree b+fmapTree f (Node x ts) = Node (f x) (map (fmapTree f) ts)+#if MIN_VERSION_base(4,8,0)+-- Safe coercions were introduced in 4.7.0, but I am not sure if they played+-- well enough with RULES to do what we want.+{-# NOINLINE [1] fmapTree #-}+{-# RULES+"fmapTree/coerce" fmapTree coerce = coerce+ #-}+#endif+ instance Applicative Tree where     pure x = Node x []     Node f tfs <*> tx@(Node x txs) =@@ -78,6 +101,13 @@  instance Foldable Tree where     foldMap f (Node x ts) = f x `mappend` foldMap (foldMap f) ts++#if MIN_VERSION_base(4,8,0)+    null _ = False+    {-# INLINE null #-}+    toList = flatten+    {-# INLINE toList #-}+#endif  instance NFData a => NFData (Tree a) where     rnf (Node x ts) = rnf x `seq` rnf ts
+ Data/Utils/BitUtil.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__+{-# LANGUAGE MagicHash #-}+#endif+#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Utils.BitUtil+-- Copyright   :  (c) Clark Gaebel 2012+--                (c) Johan Tibel 2012+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+-----------------------------------------------------------------------------++module Data.Utils.BitUtil+    ( highestBitMask+    , shiftLL+    , shiftRL+    ) where++-- On GHC, include MachDeps.h to get WORD_SIZE_IN_BITS macro.+#if defined(__GLASGOW_HASKELL__)+# include "MachDeps.h"+#endif++import Data.Bits ((.|.), xor)++#if __GLASGOW_HASKELL__+import GHC.Exts (Word(..), Int(..))+import GHC.Prim (uncheckedShiftL#, uncheckedShiftRL#)+#else+import Data.Word (shiftL, shiftR)+#endif++-- The highestBitMask implementation is based on+-- http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2+-- which has been put in the public domain.++-- | Return a word where only the highest bit is set.+highestBitMask :: Word -> Word+highestBitMask x1 = let x2 = x1 .|. x1 `shiftRL` 1+                        x3 = x2 .|. x2 `shiftRL` 2+                        x4 = x3 .|. x3 `shiftRL` 4+                        x5 = x4 .|. x4 `shiftRL` 8+                        x6 = x5 .|. x5 `shiftRL` 16+#if !(defined(__GLASGOW_HASKELL__) && WORD_SIZE_IN_BITS==32)+                        x7 = x6 .|. x6 `shiftRL` 32+                     in x7 `xor` (x7 `shiftRL` 1)+#else+                     in x6 `xor` (x6 `shiftRL` 1)+#endif+{-# INLINE highestBitMask #-}++-- Right and left logical shifts.+shiftRL, shiftLL :: Word -> Int -> Word+#if __GLASGOW_HASKELL__+{--------------------------------------------------------------------+  GHC: use unboxing to get @shiftRL@ inlined.+--------------------------------------------------------------------}+shiftRL (W# x) (I# i) = W# (uncheckedShiftRL# x i)+shiftLL (W# x) (I# i) = W# (uncheckedShiftL#  x i)+#else+shiftRL x i   = shiftR x i+shiftLL x i   = shiftL x i+#endif+{-# INLINE shiftRL #-}+{-# INLINE shiftLL #-}
+ Data/Utils/StrictFold.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE CPP #-}+#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703+{-# LANGUAGE Safe #-}+#endif+module Data.Utils.StrictFold (foldlStrict) where++-- | Same as regular 'Data.List.foldl'', but marked INLINE so that it is always+-- inlined. This allows further optimization of the call to f, which can be+-- optimized/specialised/inlined.++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 #-}
+ Data/Utils/StrictPair.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE CPP #-}+#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703+{-# LANGUAGE Safe #-}+#endif+module Data.Utils.StrictPair (StrictPair(..), toPair) where++-- | Same as regular Haskell pairs, but (x :*: _|_) = (_|_ :*: y) =+-- _|_+data StrictPair a b = !a :*: !b++toPair :: StrictPair a b -> (a, b)+toPair (x :*: y) = (x, y)+{-# INLINE toPair #-}
benchmarks/Sequence.hs view
@@ -12,18 +12,39 @@     let s10 = S.fromList [1..10] :: S.Seq Int         s100 = S.fromList [1..100] :: S.Seq Int         s1000 = S.fromList [1..1000] :: S.Seq Int-    rnf [s10, s100, s1000] `seq` return ()+        s10000 = S.fromList [1..10000] :: S.Seq Int+    rnf [s10, s100, s1000, s10000] `seq` return ()     let g = mkStdGen 1     let rlist n = map (`mod` (n+1)) (take 10000 (randoms g)) :: [Int]         r10 = rlist 10         r100 = rlist 100         r1000 = rlist 1000-    rnf [r10, r100, r1000] `seq` return ()+        r10000 = rlist 10000+    rnf [r10, r100, r1000, r10000] `seq` return ()+    let u10 = S.replicate 10 () :: S.Seq ()+        u100 = S.replicate 100 () :: S.Seq ()+        u1000 = S.replicate 1000 () :: S.Seq ()+        u10000 = S.replicate 10000 () :: S.Seq ()+    rnf [u10, u100, u1000, u10000] `seq` return ()     defaultMain-        [ bench "splitAt/append 10" $ nf (shuffle r10) s10-        , bench "splitAt/append 100" $ nf (shuffle r100) s100-        , bench "splitAt/append 1000" $ nf (shuffle r1000) s1000-        ]+      [ bgroup "splitAt/append"+         [ bench "10" $ nf (shuffle r10) s10+         , bench "100" $ nf (shuffle r100) s100+         , bench "1000" $ nf (shuffle r1000) s1000+         ]+      , bgroup "zip"+         [ bench "ix10000/5000" $ nf (\(xs,ys) -> S.zip xs ys `S.index` 5000) (s10000, u10000)+         , bench "nf100" $ nf (uncurry S.zip) (s100, u100)+         , bench "nf10000" $ nf (uncurry S.zip) (s10000, u10000)+         ]+      , bgroup "fromFunction"+         [ bench "ix10000/5000" $ nf (\s -> S.fromFunction s (+1) `S.index` (s `div` 2)) 10000+         , bench "nf10" $ nf (\s -> S.fromFunction s (+1)) 10+         , bench "nf100" $ nf (\s -> S.fromFunction s (+1)) 100+         , bench "nf1000" $ nf (\s -> S.fromFunction s (+1)) 1000+         , bench "nf10000" $ nf (\s -> S.fromFunction s (+1)) 10000+         ]+      ]  -- splitAt+append: repeatedly cut the sequence at a random point -- and rejoin the pieces in the opposite order.
containers.cabal view
@@ -1,5 +1,5 @@ name: containers-version: 0.5.5.1+version: 0.5.6.0 license: BSD3 license-file: LICENSE maintainer: fox@ucw.cz@@ -31,7 +31,7 @@     location: http://github.com/haskell/containers.git  Library-    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4+    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.5     if impl(ghc>=6.10)         build-depends: ghc-prim @@ -52,19 +52,18 @@             Data.Sequence             Data.Tree     other-modules:-        Data.BitUtil         Data.IntMap.Base         Data.IntSet.Base         Data.Map.Base         Data.Set.Base-        Data.StrictPair+        Data.Utils.BitUtil+        Data.Utils.StrictFold+        Data.Utils.StrictPair      include-dirs: include      if impl(ghc<7.0)         extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types-    if impl(ghc >= 7.8)-        extensions: RoleAnnotations  ------------------- -- T E S T I N G --@@ -84,7 +83,7 @@     type: exitcode-stdio-1.0     cpp-options: -DTESTING -    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4, ghc-prim+    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim     ghc-options: -O2     extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types @@ -101,7 +100,7 @@     type: exitcode-stdio-1.0     cpp-options: -DTESTING -DSTRICT -    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4, ghc-prim+    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim     ghc-options: -O2     extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types @@ -118,7 +117,7 @@     type: exitcode-stdio-1.0     cpp-options: -DTESTING -    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4, ghc-prim+    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim     ghc-options: -O2     extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types @@ -135,7 +134,7 @@     type: exitcode-stdio-1.0     cpp-options: -DTESTING -    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4, ghc-prim+    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim     ghc-options: -O2     extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types @@ -152,7 +151,7 @@     type: exitcode-stdio-1.0     cpp-options: -DTESTING -DSTRICT -    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4, ghc-prim+    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim     ghc-options: -O2     extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types @@ -169,7 +168,7 @@     type: exitcode-stdio-1.0     cpp-options: -DTESTING -    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4, ghc-prim+    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim     ghc-options: -O2     extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types @@ -186,7 +185,7 @@     type: exitcode-stdio-1.0     cpp-options: -DTESTING -    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4, ghc-prim+    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim     ghc-options: -O2     extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types @@ -201,7 +200,7 @@     type: exitcode-stdio-1.0     cpp-options: -DTESTING -    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.4, ghc-prim+    build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim     ghc-options: -O2     extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types @@ -211,30 +210,34 @@         test-framework-quickcheck2  test-suite map-strictness-properties-  hs-source-dirs: tests-  main-is: MapStrictness.hs+  hs-source-dirs: tests, .+  main-is: map-strictness.hs   type: exitcode-stdio-1.0    build-depends:-    base,+    array,+    base >= 4.2 && < 5,     ChasingBottoms,-    containers,+    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  test-suite intmap-strictness-properties-  hs-source-dirs: tests-  main-is: IntMapStrictness.hs+  hs-source-dirs: tests, .+  main-is: intmap-strictness.hs   type: exitcode-stdio-1.0    build-depends:-    base,+    array,+    base >= 4.2 && < 5,     ChasingBottoms,-    containers,+    deepseq >= 1.2 && < 1.5,     QuickCheck >= 2.4.0.1,+    ghc-prim,     test-framework >= 0.3.3,     test-framework-quickcheck2 >= 0.2.9
− tests/IntMapStrictness.hs 
@@ -1,127 +0,0 @@-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Main (main) where--import Test.ChasingBottoms.IsBottom-import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck (Arbitrary(arbitrary))--import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as M--instance Arbitrary v => Arbitrary (IntMap v) where-    arbitrary = M.fromList `fmap` arbitrary--instance Show (Int -> Int) where-    show _ = "<function>"--instance Show (Int -> Int -> Int) where-    show _ = "<function>"--instance Show (Int -> Int -> Int -> Int) where-    show _ = "<function>"----------------------------------------------------------------------------- * Properties----------------------------------------------------------------------------- ** Strict module--pSingletonKeyStrict :: Int -> Bool-pSingletonKeyStrict v = isBottom $ M.singleton (bottom :: Int) v--pSingletonValueStrict :: Int -> Bool-pSingletonValueStrict k = isBottom $ (M.singleton k (bottom :: Int))--pFindWithDefaultKeyStrict :: Int -> IntMap Int -> Bool-pFindWithDefaultKeyStrict def m = isBottom $ M.findWithDefault def bottom m--pFindWithDefaultValueStrict :: Int -> IntMap Int -> Bool-pFindWithDefaultValueStrict k m =-    M.member k m || (isBottom $ M.findWithDefault bottom k m)--pAdjustKeyStrict :: (Int -> Int) -> IntMap Int -> Bool-pAdjustKeyStrict f m = isBottom $ M.adjust f bottom m--pAdjustValueStrict :: Int -> IntMap Int -> Bool-pAdjustValueStrict k m-    | k `M.member` m = isBottom $ M.adjust (const bottom) k m-    | otherwise       = case M.keys m of-        []     -> True-        (k':_) -> isBottom $ M.adjust (const bottom) k' m--pInsertKeyStrict :: Int -> IntMap Int -> Bool-pInsertKeyStrict v m = isBottom $ M.insert bottom v m--pInsertValueStrict :: Int -> IntMap Int -> Bool-pInsertValueStrict k m = isBottom $ M.insert k bottom m--pInsertWithKeyStrict :: (Int -> Int -> Int) -> Int -> IntMap Int -> Bool-pInsertWithKeyStrict f v m = isBottom $ M.insertWith f bottom v m--pInsertWithValueStrict :: (Int -> Int -> Int) -> Int -> Int -> IntMap Int-                       -> Bool-pInsertWithValueStrict f k v m-    | M.member k m = (isBottom $ M.insertWith (const2 bottom) k v m) &&-                     not (isBottom $ M.insertWith (const2 1) k bottom m)-    | otherwise    = isBottom $ M.insertWith f k bottom m--pInsertLookupWithKeyKeyStrict :: (Int -> Int -> Int -> Int) -> Int -> IntMap Int-                              -> Bool-pInsertLookupWithKeyKeyStrict f v m = isBottom $ M.insertLookupWithKey f bottom v m--pInsertLookupWithKeyValueStrict :: (Int -> Int -> Int -> Int) -> Int -> Int-                                -> IntMap Int -> Bool-pInsertLookupWithKeyValueStrict f k v m-    | M.member k m = (isBottom $ M.insertLookupWithKey (const3 bottom) k v m) &&-                     not (isBottom $ M.insertLookupWithKey (const3 1) k bottom m)-    | otherwise    = isBottom $ M.insertLookupWithKey f k bottom m----------------------------------------------------------------------------- * Test list--tests :: [Test]-tests =-    [-    -- Basic interface-      testGroup "IntMap.Strict"-      [ testProperty "singleton is key-strict" pSingletonKeyStrict-      , testProperty "singleton is value-strict" pSingletonValueStrict-      , testProperty "member is key-strict" $ keyStrict M.member-      , testProperty "lookup is key-strict" $ keyStrict M.lookup-      , testProperty "findWithDefault is key-strict" pFindWithDefaultKeyStrict-      , testProperty "findWithDefault is value-strict" pFindWithDefaultValueStrict-      , testProperty "! is key-strict" $ keyStrict (flip (M.!))-      , testProperty "delete is key-strict" $ keyStrict M.delete-      , testProperty "adjust is key-strict" pAdjustKeyStrict-      , testProperty "adjust is value-strict" pAdjustValueStrict-      , testProperty "insert is key-strict" pInsertKeyStrict-      , testProperty "insert is value-strict" pInsertValueStrict-      , testProperty "insertWith is key-strict" pInsertWithKeyStrict-      , testProperty "insertWith is value-strict" pInsertWithValueStrict-      , testProperty "insertLookupWithKey is key-strict"-        pInsertLookupWithKeyKeyStrict-      , testProperty "insertLookupWithKey is value-strict"-        pInsertLookupWithKeyValueStrict-      ]-    ]----------------------------------------------------------------------------- * Test harness--main :: IO ()-main = defaultMain tests----------------------------------------------------------------------------- * Utilities--keyStrict :: (Int -> IntMap Int -> a) -> IntMap Int -> Bool-keyStrict f m = isBottom $ f bottom m--const2 :: a -> b -> c -> a-const2 x _ _ = x--const3 :: a -> b -> c -> d -> a-const3 x _ _ _ = x
− tests/MapStrictness.hs 
@@ -1,128 +0,0 @@-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Main (main) where--import Test.ChasingBottoms.IsBottom-import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck (Arbitrary(arbitrary))--import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M--instance (Arbitrary k, Arbitrary v, Eq k, Ord k) =>-         Arbitrary (Map k v) where-    arbitrary = M.fromList `fmap` arbitrary--instance Show (Int -> Int) where-    show _ = "<function>"--instance Show (Int -> Int -> Int) where-    show _ = "<function>"--instance Show (Int -> Int -> Int -> Int) where-    show _ = "<function>"----------------------------------------------------------------------------- * Properties----------------------------------------------------------------------------- ** Strict module--pSingletonKeyStrict :: Int -> Bool-pSingletonKeyStrict v = isBottom $ M.singleton (bottom :: Int) v--pSingletonValueStrict :: Int -> Bool-pSingletonValueStrict k = isBottom $ (M.singleton k (bottom :: Int))--pFindWithDefaultKeyStrict :: Int -> Map Int Int -> Bool-pFindWithDefaultKeyStrict def m = isBottom $ M.findWithDefault def bottom m--pFindWithDefaultValueStrict :: Int -> Map Int Int -> Bool-pFindWithDefaultValueStrict k m =-    M.member k m || (isBottom $ M.findWithDefault bottom k m)--pAdjustKeyStrict :: (Int -> Int) -> Map Int Int -> Bool-pAdjustKeyStrict f m = isBottom $ M.adjust f bottom m--pAdjustValueStrict :: Int -> Map Int Int -> Bool-pAdjustValueStrict k m-    | k `M.member` m = isBottom $ M.adjust (const bottom) k m-    | otherwise       = case M.keys m of-        []     -> True-        (k':_) -> isBottom $ M.adjust (const bottom) k' m--pInsertKeyStrict :: Int -> Map Int Int -> Bool-pInsertKeyStrict v m = isBottom $ M.insert bottom v m--pInsertValueStrict :: Int -> Map Int Int -> Bool-pInsertValueStrict k m = isBottom $ M.insert k bottom m--pInsertWithKeyStrict :: (Int -> Int -> Int) -> Int -> Map Int Int -> Bool-pInsertWithKeyStrict f v m = isBottom $ M.insertWith f bottom v m--pInsertWithValueStrict :: (Int -> Int -> Int) -> Int -> Int -> Map Int Int-                       -> Bool-pInsertWithValueStrict f k v m-    | M.member k m = (isBottom $ M.insertWith (const2 bottom) k v m) &&-                     not (isBottom $ M.insertWith (const2 1) k bottom m)-    | otherwise    = isBottom $ M.insertWith f k bottom m--pInsertLookupWithKeyKeyStrict :: (Int -> Int -> Int -> Int) -> Int-                              -> Map Int Int -> Bool-pInsertLookupWithKeyKeyStrict f v m = isBottom $ M.insertLookupWithKey f bottom v m--pInsertLookupWithKeyValueStrict :: (Int -> Int -> Int -> Int) -> Int -> Int-                                -> Map Int Int -> Bool-pInsertLookupWithKeyValueStrict f k v m-    | M.member k m = (isBottom $ M.insertLookupWithKey (const3 bottom) k v m) &&-                     not (isBottom $ M.insertLookupWithKey (const3 1) k bottom m)-    | otherwise    = isBottom $ M.insertLookupWithKey f k bottom m----------------------------------------------------------------------------- * Test list--tests :: [Test]-tests =-    [-    -- Basic interface-      testGroup "Map.Strict"-      [ testProperty "singleton is key-strict" pSingletonKeyStrict-      , testProperty "singleton is value-strict" pSingletonValueStrict-      , testProperty "member is key-strict" $ keyStrict M.member-      , testProperty "lookup is key-strict" $ keyStrict M.lookup-      , testProperty "findWithDefault is key-strict" pFindWithDefaultKeyStrict-      , testProperty "findWithDefault is value-strict" pFindWithDefaultValueStrict-      , testProperty "! is key-strict" $ keyStrict (flip (M.!))-      , testProperty "delete is key-strict" $ keyStrict M.delete-      , testProperty "adjust is key-strict" pAdjustKeyStrict-      , testProperty "adjust is value-strict" pAdjustValueStrict-      , testProperty "insert is key-strict" pInsertKeyStrict-      , testProperty "insert is value-strict" pInsertValueStrict-      , testProperty "insertWith is key-strict" pInsertWithKeyStrict-      , testProperty "insertWith is value-strict" pInsertWithValueStrict-      , testProperty "insertLookupWithKey is key-strict"-        pInsertLookupWithKeyKeyStrict-      , testProperty "insertLookupWithKey is value-strict"-        pInsertLookupWithKeyValueStrict-      ]-    ]----------------------------------------------------------------------------- * Test harness--main :: IO ()-main = defaultMain tests----------------------------------------------------------------------------- * Utilities--keyStrict :: (Int -> Map Int Int -> a) -> Map Int Int -> Bool-keyStrict f m = isBottom $ f bottom m--const2 :: a -> b -> c -> a-const2 x _ _ = x--const3 :: a -> b -> c -> d -> a-const3 x _ _ _ = x
+ tests/intmap-strictness.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main (main) where++import Test.ChasingBottoms.IsBottom+import Test.Framework (Test, defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary(arbitrary))++import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as M++instance Arbitrary v => Arbitrary (IntMap v) where+    arbitrary = M.fromList `fmap` arbitrary++instance Show (Int -> Int) where+    show _ = "<function>"++instance Show (Int -> Int -> Int) where+    show _ = "<function>"++instance Show (Int -> Int -> Int -> Int) where+    show _ = "<function>"++------------------------------------------------------------------------+-- * Properties++------------------------------------------------------------------------+-- ** Strict module++pSingletonKeyStrict :: Int -> Bool+pSingletonKeyStrict v = isBottom $ M.singleton (bottom :: Int) v++pSingletonValueStrict :: Int -> Bool+pSingletonValueStrict k = isBottom $ (M.singleton k (bottom :: Int))++pFindWithDefaultKeyStrict :: Int -> IntMap Int -> Bool+pFindWithDefaultKeyStrict def m = isBottom $ M.findWithDefault def bottom m++pFindWithDefaultValueStrict :: Int -> IntMap Int -> Bool+pFindWithDefaultValueStrict k m =+    M.member k m || (isBottom $ M.findWithDefault bottom k m)++pAdjustKeyStrict :: (Int -> Int) -> IntMap Int -> Bool+pAdjustKeyStrict f m = isBottom $ M.adjust f bottom m++pAdjustValueStrict :: Int -> IntMap Int -> Bool+pAdjustValueStrict k m+    | k `M.member` m = isBottom $ M.adjust (const bottom) k m+    | otherwise       = case M.keys m of+        []     -> True+        (k':_) -> isBottom $ M.adjust (const bottom) k' m++pInsertKeyStrict :: Int -> IntMap Int -> Bool+pInsertKeyStrict v m = isBottom $ M.insert bottom v m++pInsertValueStrict :: Int -> IntMap Int -> Bool+pInsertValueStrict k m = isBottom $ M.insert k bottom m++pInsertWithKeyStrict :: (Int -> Int -> Int) -> Int -> IntMap Int -> Bool+pInsertWithKeyStrict f v m = isBottom $ M.insertWith f bottom v m++pInsertWithValueStrict :: (Int -> Int -> Int) -> Int -> Int -> IntMap Int+                       -> Bool+pInsertWithValueStrict f k v m+    | M.member k m = (isBottom $ M.insertWith (const2 bottom) k v m) &&+                     not (isBottom $ M.insertWith (const2 1) k bottom m)+    | otherwise    = isBottom $ M.insertWith f k bottom m++pInsertLookupWithKeyKeyStrict :: (Int -> Int -> Int -> Int) -> Int -> IntMap Int+                              -> Bool+pInsertLookupWithKeyKeyStrict f v m = isBottom $ M.insertLookupWithKey f bottom v m++pInsertLookupWithKeyValueStrict :: (Int -> Int -> Int -> Int) -> Int -> Int+                                -> IntMap Int -> Bool+pInsertLookupWithKeyValueStrict f k v m+    | M.member k m = (isBottom $ M.insertLookupWithKey (const3 bottom) k v m) &&+                     not (isBottom $ M.insertLookupWithKey (const3 1) k bottom m)+    | otherwise    = isBottom $ M.insertLookupWithKey f k bottom m++------------------------------------------------------------------------+-- * Test list++tests :: [Test]+tests =+    [+    -- Basic interface+      testGroup "IntMap.Strict"+      [ testProperty "singleton is key-strict" pSingletonKeyStrict+      , testProperty "singleton is value-strict" pSingletonValueStrict+      , testProperty "member is key-strict" $ keyStrict M.member+      , testProperty "lookup is key-strict" $ keyStrict M.lookup+      , testProperty "findWithDefault is key-strict" pFindWithDefaultKeyStrict+      , testProperty "findWithDefault is value-strict" pFindWithDefaultValueStrict+      , testProperty "! is key-strict" $ keyStrict (flip (M.!))+      , testProperty "delete is key-strict" $ keyStrict M.delete+      , testProperty "adjust is key-strict" pAdjustKeyStrict+      , testProperty "adjust is value-strict" pAdjustValueStrict+      , testProperty "insert is key-strict" pInsertKeyStrict+      , testProperty "insert is value-strict" pInsertValueStrict+      , testProperty "insertWith is key-strict" pInsertWithKeyStrict+      , testProperty "insertWith is value-strict" pInsertWithValueStrict+      , testProperty "insertLookupWithKey is key-strict"+        pInsertLookupWithKeyKeyStrict+      , testProperty "insertLookupWithKey is value-strict"+        pInsertLookupWithKeyValueStrict+      ]+    ]++------------------------------------------------------------------------+-- * Test harness++main :: IO ()+main = defaultMain tests++------------------------------------------------------------------------+-- * Utilities++keyStrict :: (Int -> IntMap Int -> a) -> IntMap Int -> Bool+keyStrict f m = isBottom $ f bottom m++const2 :: a -> b -> c -> a+const2 x _ _ = x++const3 :: a -> b -> c -> d -> a+const3 x _ _ _ = x
+ tests/map-strictness.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main (main) where++import Test.ChasingBottoms.IsBottom+import Test.Framework (Test, defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary(arbitrary))++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M++instance (Arbitrary k, Arbitrary v, Eq k, Ord k) =>+         Arbitrary (Map k v) where+    arbitrary = M.fromList `fmap` arbitrary++instance Show (Int -> Int) where+    show _ = "<function>"++instance Show (Int -> Int -> Int) where+    show _ = "<function>"++instance Show (Int -> Int -> Int -> Int) where+    show _ = "<function>"++------------------------------------------------------------------------+-- * Properties++------------------------------------------------------------------------+-- ** Strict module++pSingletonKeyStrict :: Int -> Bool+pSingletonKeyStrict v = isBottom $ M.singleton (bottom :: Int) v++pSingletonValueStrict :: Int -> Bool+pSingletonValueStrict k = isBottom $ (M.singleton k (bottom :: Int))++pFindWithDefaultKeyStrict :: Int -> Map Int Int -> Bool+pFindWithDefaultKeyStrict def m = isBottom $ M.findWithDefault def bottom m++pFindWithDefaultValueStrict :: Int -> Map Int Int -> Bool+pFindWithDefaultValueStrict k m =+    M.member k m || (isBottom $ M.findWithDefault bottom k m)++pAdjustKeyStrict :: (Int -> Int) -> Map Int Int -> Bool+pAdjustKeyStrict f m = isBottom $ M.adjust f bottom m++pAdjustValueStrict :: Int -> Map Int Int -> Bool+pAdjustValueStrict k m+    | k `M.member` m = isBottom $ M.adjust (const bottom) k m+    | otherwise       = case M.keys m of+        []     -> True+        (k':_) -> isBottom $ M.adjust (const bottom) k' m++pInsertKeyStrict :: Int -> Map Int Int -> Bool+pInsertKeyStrict v m = isBottom $ M.insert bottom v m++pInsertValueStrict :: Int -> Map Int Int -> Bool+pInsertValueStrict k m = isBottom $ M.insert k bottom m++pInsertWithKeyStrict :: (Int -> Int -> Int) -> Int -> Map Int Int -> Bool+pInsertWithKeyStrict f v m = isBottom $ M.insertWith f bottom v m++pInsertWithValueStrict :: (Int -> Int -> Int) -> Int -> Int -> Map Int Int+                       -> Bool+pInsertWithValueStrict f k v m+    | M.member k m = (isBottom $ M.insertWith (const2 bottom) k v m) &&+                     not (isBottom $ M.insertWith (const2 1) k bottom m)+    | otherwise    = isBottom $ M.insertWith f k bottom m++pInsertLookupWithKeyKeyStrict :: (Int -> Int -> Int -> Int) -> Int+                              -> Map Int Int -> Bool+pInsertLookupWithKeyKeyStrict f v m = isBottom $ M.insertLookupWithKey f bottom v m++pInsertLookupWithKeyValueStrict :: (Int -> Int -> Int -> Int) -> Int -> Int+                                -> Map Int Int -> Bool+pInsertLookupWithKeyValueStrict f k v m+    | M.member k m = (isBottom $ M.insertLookupWithKey (const3 bottom) k v m) &&+                     not (isBottom $ M.insertLookupWithKey (const3 1) k bottom m)+    | otherwise    = isBottom $ M.insertLookupWithKey f k bottom m++------------------------------------------------------------------------+-- * Test list++tests :: [Test]+tests =+    [+    -- Basic interface+      testGroup "Map.Strict"+      [ testProperty "singleton is key-strict" pSingletonKeyStrict+      , testProperty "singleton is value-strict" pSingletonValueStrict+      , testProperty "member is key-strict" $ keyStrict M.member+      , testProperty "lookup is key-strict" $ keyStrict M.lookup+      , testProperty "findWithDefault is key-strict" pFindWithDefaultKeyStrict+      , testProperty "findWithDefault is value-strict" pFindWithDefaultValueStrict+      , testProperty "! is key-strict" $ keyStrict (flip (M.!))+      , testProperty "delete is key-strict" $ keyStrict M.delete+      , testProperty "adjust is key-strict" pAdjustKeyStrict+      , testProperty "adjust is value-strict" pAdjustValueStrict+      , testProperty "insert is key-strict" pInsertKeyStrict+      , testProperty "insert is value-strict" pInsertValueStrict+      , testProperty "insertWith is key-strict" pInsertWithKeyStrict+      , testProperty "insertWith is value-strict" pInsertWithValueStrict+      , testProperty "insertLookupWithKey is key-strict"+        pInsertLookupWithKeyKeyStrict+      , testProperty "insertLookupWithKey is value-strict"+        pInsertLookupWithKeyValueStrict+      ]+    ]++------------------------------------------------------------------------+-- * Test harness++main :: IO ()+main = defaultMain tests++------------------------------------------------------------------------+-- * Utilities++keyStrict :: (Int -> Map Int Int -> a) -> Map Int Int -> Bool+keyStrict f m = isBottom $ f bottom m++const2 :: a -> b -> c -> a+const2 x _ _ = x++const3 :: a -> b -> c -> d -> a+const3 x _ _ _ = x
tests/seq-properties.hs view
@@ -2,6 +2,7 @@  import Control.Applicative (Applicative(..)) import Control.Arrow ((***))+import Data.Array (listArray) import Data.Foldable (Foldable(..), toList, all, sum) import Data.Functor ((<$>), (<$)) import Data.Maybe@@ -36,6 +37,8 @@        , testProperty "(|>)" prop_snoc        , testProperty "(><)" prop_append        , testProperty "fromList" prop_fromList+       , testProperty "fromFunction" prop_fromFunction+       , testProperty "fromArray" prop_fromArray        , testProperty "replicate" prop_replicate        , testProperty "replicateA" prop_replicateA        , testProperty "replicateM" prop_replicateM@@ -269,6 +272,14 @@ prop_fromList :: [A] -> Bool prop_fromList xs =     toList' (fromList xs) ~= xs++prop_fromFunction :: [A] -> Bool+prop_fromFunction xs =+    toList' (fromFunction (Prelude.length xs) (xs!!)) ~= xs++prop_fromArray :: [A] -> Bool+prop_fromArray xs =+    toList' (fromArray (listArray (42, 42+Prelude.length xs-1) xs)) ~= xs  -- ** Repetition