diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for strict-containers +## 0.2 -- 2022-12-12 + +- Update to containers v0.6.6, unordered-containers v0.2.19.1, vector + v0.13.0.0. Includes support for GHC 9.4. + ## 0.1 -- 2021-04-20 - Initial release, defining strict versions of `Data.HashMap`, `Data.IntMap`, diff --git a/include/containers.h b/include/containers.h --- a/include/containers.h +++ b/include/containers.h @@ -12,30 +12,19 @@ #include "MachDeps.h" #endif -/* - * Define INSTANCE_TYPEABLE[0-2] - */ -#if __GLASGOW_HASKELL__ >= 707 -#define INSTANCE_TYPEABLE0(tycon) deriving instance Typeable tycon -#define INSTANCE_TYPEABLE1(tycon) deriving instance Typeable tycon -#define INSTANCE_TYPEABLE2(tycon) deriving instance Typeable tycon -#elif defined(__GLASGOW_HASKELL__) -#define INSTANCE_TYPEABLE0(tycon) deriving instance Typeable tycon -#define INSTANCE_TYPEABLE1(tycon) deriving instance Typeable1 tycon -#define INSTANCE_TYPEABLE2(tycon) deriving instance Typeable2 tycon -#else -#define INSTANCE_TYPEABLE0(tycon) -#define INSTANCE_TYPEABLE1(tycon) -#define INSTANCE_TYPEABLE2(tycon) -#endif - -#if __GLASGOW_HASKELL__ >= 800 +#ifdef __GLASGOW_HASKELL__ #define DEFINE_PATTERN_SYNONYMS 1 #endif #ifdef __GLASGOW_HASKELL__ # define USE_ST_MONAD 1 +#ifndef WORDS_BIGENDIAN +/* + * Unboxed arrays are broken on big-endian architectures. + * See https://gitlab.haskell.org/ghc/ghc/-/issues/16998 + */ # define USE_UNBOXED_ARRAYS 1 +#endif #endif #endif diff --git a/include/vector.h b/include/vector.h new file mode 100644 --- /dev/null +++ b/include/vector.h @@ -0,0 +1,8 @@ +#define PHASE_FUSED [1] +#define PHASE_INNER [0] + +#define INLINE_FUSED INLINE PHASE_FUSED +#define INLINE_INNER INLINE PHASE_INNER + +#define PHASE_STREAM Please use "PHASE_FUSED" instead +#define INLINE_STREAM Please use "INLINE_FUSED" instead diff --git a/src/Data/Strict/ContainersUtils/Autogen/BitQueue.hs b/src/Data/Strict/ContainersUtils/Autogen/BitQueue.hs --- a/src/Data/Strict/ContainersUtils/Autogen/BitQueue.hs +++ b/src/Data/Strict/ContainersUtils/Autogen/BitQueue.hs @@ -44,23 +44,10 @@ , toListQ ) where -#if !MIN_VERSION_base(4,8,0) -import Data.Word (Word) -#endif import Data.Strict.ContainersUtils.Autogen.BitUtil (shiftLL, shiftRL, wordSize) import Data.Bits ((.|.), (.&.), testBit) -#if MIN_VERSION_base(4,8,0) import Data.Bits (countTrailingZeros) -#else -import Data.Bits (popCount) -#endif -#if !MIN_VERSION_base(4,8,0) -countTrailingZeros :: Word -> Int -countTrailingZeros x = popCount ((x .&. (-x)) - 1) -{-# INLINE countTrailingZeros #-} -#endif - -- A bit queue builder. We represent a double word using two words -- because we don't currently have access to proper double words. data BitQueueB = BQB {-# UNPACK #-} !Word @@ -109,7 +96,7 @@ lo' = (lo1 `shiftRL` zeros) .|. (hi1 `shiftLL` (wordSize - zeros)) hi' = hi1 `shiftRL` zeros --- Test if the queue is empty, which occurs when theres +-- Test if the queue is empty, which occurs when there's -- nothing left but a guard bit in the least significant -- place. nullQ :: BitQueue -> Bool diff --git a/src/Data/Strict/ContainersUtils/Autogen/BitUtil.hs b/src/Data/Strict/ContainersUtils/Autogen/BitUtil.hs --- a/src/Data/Strict/ContainersUtils/Autogen/BitUtil.hs +++ b/src/Data/Strict/ContainersUtils/Autogen/BitUtil.hs @@ -38,23 +38,10 @@ , wordSize ) where -#if !MIN_VERSION_base(4,8,0) -import Data.Bits ((.|.), xor) -#endif import Data.Bits (popCount, unsafeShiftL, unsafeShiftR -#if MIN_VERSION_base(4,8,0) - , countLeadingZeros -#endif + , countLeadingZeros, finiteBitSize ) -#if MIN_VERSION_base(4,7,0) -import Data.Bits (finiteBitSize) -#else -import Data.Bits (bitSize) -#endif -#if !MIN_VERSION_base (4,8,0) -import Data.Word (Word) -#endif {---------------------------------------------------------------------- [bitcount] as posted by David F. Place to haskell-cafe on April 11, 2006, @@ -78,21 +65,7 @@ -- | Return a word where only the highest bit is set. highestBitMask :: Word -> Word -#if MIN_VERSION_base(4,8,0) highestBitMask w = shiftLL 1 (wordSize - 1 - countLeadingZeros w) -#else -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 -#endif {-# INLINE highestBitMask #-} -- Right and left logical shifts. @@ -102,8 +75,4 @@ {-# INLINE wordSize #-} wordSize :: Int -#if MIN_VERSION_base(4,7,0) wordSize = finiteBitSize (0 :: Word) -#else -wordSize = bitSize (0 :: Word) -#endif diff --git a/src/Data/Strict/ContainersUtils/Autogen/Coercions.hs b/src/Data/Strict/ContainersUtils/Autogen/Coercions.hs --- a/src/Data/Strict/ContainersUtils/Autogen/Coercions.hs +++ b/src/Data/Strict/ContainersUtils/Autogen/Coercions.hs @@ -5,12 +5,12 @@ module Data.Strict.ContainersUtils.Autogen.Coercions where -#if __GLASGOW_HASKELL__ >= 708 +#ifdef __GLASGOW_HASKELL__ import Data.Coerce #endif infixl 8 .# -#if __GLASGOW_HASKELL__ >= 708 +#ifdef __GLASGOW_HASKELL__ (.#) :: Coercible b a => (b -> c) -> (a -> b) -> a -> c (.#) f _ = coerce f #else @@ -34,7 +34,7 @@ -- @ -- foldl f b . fmap g = foldl (f .^# g) b -- @ -#if __GLASGOW_HASKELL__ >= 708 +#ifdef __GLASGOW_HASKELL__ (.^#) :: Coercible c b => (a -> c -> d) -> (b -> c) -> (a -> b -> d) (.^#) f _ = coerce f #else diff --git a/src/Data/Strict/ContainersUtils/Autogen/PtrEquality.hs b/src/Data/Strict/ContainersUtils/Autogen/PtrEquality.hs --- a/src/Data/Strict/ContainersUtils/Autogen/PtrEquality.hs +++ b/src/Data/Strict/ContainersUtils/Autogen/PtrEquality.hs @@ -11,11 +11,7 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Exts ( reallyUnsafePtrEquality# ) import Unsafe.Coerce ( unsafeCoerce ) -#if __GLASGOW_HASKELL__ < 707 -import GHC.Exts ( (==#) ) -#else -import GHC.Exts ( isTrue# ) -#endif +import GHC.Exts ( Int#, isTrue# ) #endif -- | Checks if two pointers are equal. Yes means yes; @@ -30,13 +26,8 @@ hetPtrEq :: a -> b -> Bool #ifdef __GLASGOW_HASKELL__ -#if __GLASGOW_HASKELL__ < 707 -ptrEq x y = reallyUnsafePtrEquality# x y ==# 1# -hetPtrEq x y = unsafeCoerce reallyUnsafePtrEquality# x y ==# 1# -#else ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y) -hetPtrEq x y = isTrue# (unsafeCoerce reallyUnsafePtrEquality# x y) -#endif +hetPtrEq x y = isTrue# (unsafeCoerce (reallyUnsafePtrEquality# :: x -> x -> Int#) x y) #else -- Not GHC diff --git a/src/Data/Strict/ContainersUtils/Autogen/State.hs b/src/Data/Strict/ContainersUtils/Autogen/State.hs --- a/src/Data/Strict/ContainersUtils/Autogen/State.hs +++ b/src/Data/Strict/ContainersUtils/Autogen/State.hs @@ -5,13 +5,7 @@ -- | A clone of Control.Monad.State.Strict. module Data.Strict.ContainersUtils.Autogen.State where -import Prelude hiding ( -#if MIN_VERSION_base(4,8,0) - Applicative -#endif - ) - -import Control.Monad (ap) +import Control.Monad (ap, liftM2) import Control.Applicative (Applicative(..), liftA) newtype State s a = State {runState :: s -> (s, a)} @@ -30,6 +24,11 @@ {-# INLINE pure #-} pure x = State $ \ s -> (s, x) (<*>) = ap + m *> n = State $ \s -> case runState m s of + (s', _) -> runState n s' +#if MIN_VERSION_base(4,10,0) + liftA2 = liftM2 +#endif execState :: State s a -> s -> a execState m x = snd (runState m x) diff --git a/src/Data/Strict/ContainersUtils/Autogen/StrictMaybe.hs b/src/Data/Strict/ContainersUtils/Autogen/StrictMaybe.hs --- a/src/Data/Strict/ContainersUtils/Autogen/StrictMaybe.hs +++ b/src/Data/Strict/ContainersUtils/Autogen/StrictMaybe.hs @@ -7,11 +7,6 @@ module Data.Strict.ContainersUtils.Autogen.StrictMaybe (MaybeS (..), maybeS, toMaybe, toMaybeS) where -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable (Foldable (..)) -import Data.Monoid (Monoid (..)) -#endif - data MaybeS a = NothingS | JustS !a instance Foldable MaybeS where diff --git a/src/Data/Strict/ContainersUtils/Autogen/TypeError.hs b/src/Data/Strict/ContainersUtils/Autogen/TypeError.hs --- a/src/Data/Strict/ContainersUtils/Autogen/TypeError.hs +++ b/src/Data/Strict/ContainersUtils/Autogen/TypeError.hs @@ -2,23 +2,17 @@ KindSignatures, TypeFamilies, CPP #-} #if !defined(TESTING) -# if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE Safe #-} -# else -{-# LANGUAGE Trustworthy #-} #endif -#endif -- | Unsatisfiable constraints for functions being removed. module Data.Strict.ContainersUtils.Autogen.TypeError where import GHC.TypeLits --- | The constraint @Whoops s@ is unsatisfiable for every 'Symbol' @s@. --- Under GHC 8.0 and above, trying to use a function with a @Whoops s@ --- constraint will lead to a pretty type error explaining how to fix --- the problem. Under earlier GHC versions, it will produce an extremely --- ugly type error within which the desired message is buried. +-- | The constraint @Whoops s@ is unsatisfiable for every 'Symbol' @s@. Trying +-- to use a function with a @Whoops s@ constraint will lead to a pretty type +-- error explaining how to fix the problem. -- -- ==== Example -- @@ -28,9 +22,7 @@ -- @ class Whoops (a :: Symbol) -#if __GLASGOW_HASKELL__ >= 800 instance TypeError ('Text a) => Whoops a -#endif -- Why don't we just use -- diff --git a/src/Data/Strict/HashMap/Autogen/Internal.hs b/src/Data/Strict/HashMap/Autogen/Internal.hs --- a/src/Data/Strict/HashMap/Autogen/Internal.hs +++ b/src/Data/Strict/HashMap/Autogen/Internal.hs @@ -1,14 +1,17 @@ -{-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable, MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE LambdaCase #-} -#if __GLASGOW_HASKELL__ >= 802 -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE UnboxedSums #-} -#endif +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} {-# OPTIONS_HADDOCK not-home #-} @@ -67,6 +70,7 @@ , map , mapWithKey , traverseWithKey + , mapKeys -- * Difference and intersection , difference @@ -74,6 +78,7 @@ , intersection , intersectionWith , intersectionWithKey + , intersectionWithKey# -- * Folds , foldr' @@ -115,10 +120,9 @@ , sparseIndex , two , unionArrayBy - , update16 - , update16M - , update16With' - , updateOrConcatWith + , update32 + , update32M + , update32With' , updateOrConcatWithKey , filterMapAux , equalKeys @@ -136,56 +140,37 @@ , adjust# ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), Applicative(pure)) -import Data.Monoid (Monoid(mempty, mappend)) -import Data.Traversable (Traversable(..)) -import Data.Word (Word) -#endif -#if __GLASGOW_HASKELL__ >= 711 -import Data.Semigroup (Semigroup((<>))) -#endif -import Control.DeepSeq (NFData(rnf)) -import Control.Monad.ST (ST) -import Data.Bits ((.&.), (.|.), complement, popCount, unsafeShiftL, unsafeShiftR) -import Data.Data hiding (Typeable) -import qualified Data.Foldable as Foldable -#if MIN_VERSION_base(4,10,0) -import Data.Bifoldable -#endif -import qualified Data.List as L -import GHC.Exts ((==#), build, reallyUnsafePtrEquality#, inline) -import Prelude hiding (filter, foldl, foldr, lookup, map, null, pred) -import Text.Read hiding (step) - -import qualified Data.Strict.HashMap.Autogen.Internal.Array as A -import qualified Data.Hashable as H -import Data.Hashable (Hashable) -import Data.Strict.HashMap.Autogen.Internal.Unsafe (runST) +import Control.Applicative (Const (..)) +import Control.DeepSeq (NFData (..), NFData1 (..), NFData2 (..)) +import Control.Monad.ST (ST, runST) +import Data.Bifoldable (Bifoldable (..)) +import Data.Bits (complement, countTrailingZeros, popCount, + shiftL, unsafeShiftL, unsafeShiftR, (.&.), + (.|.)) +import Data.Coerce (coerce) +import Data.Data (Constr, Data (..), DataType) +import Data.Functor.Classes (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), + Read1 (..), Show1 (..), Show2 (..)) +import Data.Functor.Identity (Identity (..)) +import Data.Hashable (Hashable) +import Data.Hashable.Lifted (Hashable1, Hashable2) import Data.Strict.HashMap.Autogen.Internal.List (isPermutationBy, unorderedCompare) -import Data.Typeable (Typeable) - -import GHC.Exts (isTrue#) -import qualified GHC.Exts as Exts - -#if MIN_VERSION_base(4,9,0) -import Data.Functor.Classes -import GHC.Stack -#endif - -#if MIN_VERSION_hashable(1,2,5) -import qualified Data.Hashable.Lifted as H -#endif - -#if __GLASGOW_HASKELL__ >= 802 -import GHC.Exts (TYPE, Int (..), Int#) -#endif +import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid) +import GHC.Exts (Int (..), Int#, TYPE, (==#)) +import GHC.Stack (HasCallStack) +import Prelude hiding (filter, foldl, foldr, lookup, map, + null, pred) +import Text.Read hiding (step) -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity (..)) -#endif -import Control.Applicative (Const (..)) -import Data.Coerce (coerce) +import qualified Data.Data as Data +import qualified Data.Foldable as Foldable +import qualified Data.Functor.Classes as FC +import qualified Data.Hashable as H +import qualified Data.Hashable.Lifted as H +import qualified Data.Strict.HashMap.Autogen.Internal.Array as A +import qualified Data.List as List +import qualified GHC.Exts as Exts +import qualified Language.Haskell.TH.Syntax as TH -- | A set of values. A set cannot contain duplicate values. ------------------------------------------------------------------------ @@ -200,6 +185,22 @@ instance (NFData k, NFData v) => NFData (Leaf k v) where rnf (L k v) = rnf k `seq` rnf v +-- | @since 0.2.17.0 +instance (TH.Lift k, TH.Lift v) => TH.Lift (Leaf k v) where +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped (L k v) = [|| L k $! v ||] +#else + lift (L k v) = [| L k $! v |] +#endif + +-- | @since 0.2.14.0 +instance NFData k => NFData1 (Leaf k) where + liftRnf = liftRnf2 rnf + +-- | @since 0.2.14.0 +instance NFData2 Leaf where + liftRnf2 rnf1 rnf2 (L k v) = rnf1 k `seq` rnf2 v + -- Invariant: The length of the 1st argument to 'Full' is -- 2^bitsPerSubkey @@ -211,10 +212,12 @@ | Leaf !Hash !(Leaf k v) | Full !(A.Array (HashMap k v)) | Collision !Hash !(A.Array (Leaf k v)) - deriving (Typeable) type role HashMap nominal representational +-- | @since 0.2.17.0 +deriving instance (TH.Lift k, TH.Lift v) => TH.Lift (HashMap k v) + instance (NFData k, NFData v) => NFData (HashMap k v) where rnf Empty = () rnf (BitmapIndexed _ ary) = rnf ary @@ -222,6 +225,18 @@ rnf (Full ary) = rnf ary rnf (Collision _ ary) = rnf ary +-- | @since 0.2.14.0 +instance NFData k => NFData1 (HashMap k) where + liftRnf = liftRnf2 rnf + +-- | @since 0.2.14.0 +instance NFData2 HashMap where + liftRnf2 _ _ Empty = () + liftRnf2 rnf1 rnf2 (BitmapIndexed _ ary) = liftRnf (liftRnf2 rnf1 rnf2) ary + liftRnf2 rnf1 rnf2 (Leaf _ l) = liftRnf2 rnf1 rnf2 l + liftRnf2 rnf1 rnf2 (Full ary) = liftRnf (liftRnf2 rnf1 rnf2) ary + liftRnf2 rnf1 rnf2 (Collision _ ary) = liftRnf (liftRnf2 rnf1 rnf2) ary + instance Functor (HashMap k) where fmap = map @@ -236,14 +251,11 @@ {-# INLINE foldr' #-} foldl' = foldl' {-# INLINE foldl' #-} -#if MIN_VERSION_base(4,8,0) null = null {-# INLINE null #-} length = size {-# INLINE length #-} -#endif -#if MIN_VERSION_base(4,10,0) -- | @since 0.2.11 instance Bifoldable HashMap where bifoldMap f g = foldMapWithKey (\ k v -> f k `mappend` g v) @@ -252,9 +264,7 @@ {-# INLINE bifoldr #-} bifoldl f g = foldlWithKey (\ acc k v -> (acc `f` k) `g` v) {-# INLINE bifoldl #-} -#endif -#if __GLASGOW_HASKELL__ >= 711 -- | '<>' = 'union' -- -- If a key occurs in both maps, the mapping from the first will be the mapping in the result. @@ -266,7 +276,8 @@ instance (Eq k, Hashable k) => Semigroup (HashMap k v) where (<>) = union {-# INLINE (<>) #-} -#endif + stimes = stimesIdempotentMonoid + {-# INLINE stimes #-} -- | 'mempty' = 'empty' -- @@ -281,36 +292,44 @@ instance (Eq k, Hashable k) => Monoid (HashMap k v) where mempty = empty {-# INLINE mempty #-} -#if __GLASGOW_HASKELL__ >= 711 mappend = (<>) -#else - mappend = union -#endif {-# INLINE mappend #-} instance (Data k, Data v, Eq k, Hashable k) => Data (HashMap k v) where gfoldl f z m = z fromList `f` toList m toConstr _ = fromListConstr - gunfold k z c = case constrIndex c of + gunfold k z c = case Data.constrIndex c of 1 -> k (z fromList) _ -> error "gunfold" dataTypeOf _ = hashMapDataType - dataCast2 f = gcast2 f + dataCast1 f = Data.gcast1 f + dataCast2 f = Data.gcast2 f fromListConstr :: Constr -fromListConstr = mkConstr hashMapDataType "fromList" [] Prefix +fromListConstr = Data.mkConstr hashMapDataType "fromList" [] Data.Prefix hashMapDataType :: DataType -hashMapDataType = mkDataType "Data.Strict.HashMap.Autogen.Internal.HashMap" [fromListConstr] +hashMapDataType = Data.mkDataType "Data.Strict.HashMap.Autogen.Internal.HashMap" [fromListConstr] +-- | This type is used to store the hash of a key, as produced with 'hash'. type Hash = Word + +-- | A bitmap as contained by a 'BitmapIndexed' node, or a 'fullNodeMask' +-- corresponding to a 'Full' node. +-- +-- Only the lower 'maxChildren' bits are used. The remaining bits must be zeros. type Bitmap = Word + +-- | 'Shift' values correspond to the level of the tree that we're currently +-- operating at. At the root level the 'Shift' is @0@. For the subsequent +-- levels the 'Shift' values are 'bitsPerSubkey', @2*'bitsPerSubkey'@ etc. +-- +-- Valid values are non-negative and less than @bitSize (0 :: Word)@. type Shift = Int -#if MIN_VERSION_base(4,9,0) instance Show2 HashMap where liftShowsPrec2 spk slk spv slv d m = - showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m) + FC.showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m) where sp = liftShowsPrec2 spk slk spv slv sl = liftShowList2 spk slk spv slv @@ -319,18 +338,16 @@ liftShowsPrec = liftShowsPrec2 showsPrec showList instance (Eq k, Hashable k, Read k) => Read1 (HashMap k) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList + liftReadsPrec rp rl = FC.readsData $ + FC.readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList where rp' = liftReadsPrec rp rl rl' = liftReadList rp rl -#endif instance (Eq k, Hashable k, Read k, Read e) => Read (HashMap k e) where readPrec = parens $ prec 10 $ do Ident "fromList" <- lexP - xs <- readPrec - return (fromList xs) + fromList <$> readPrec readListPrec = readListPrecDefault @@ -342,13 +359,11 @@ traverse f = traverseWithKey (const f) {-# INLINABLE traverse #-} -#if MIN_VERSION_base(4,9,0) instance Eq2 HashMap where liftEq2 = equal2 instance Eq k => Eq1 (HashMap k) where liftEq = equal1 -#endif -- | Note that, in the presence of hash collisions, equal @HashMap@s may -- behave differently, i.e. substitutivity may be violated: @@ -392,7 +407,7 @@ equal2 :: (k -> k' -> Bool) -> (v -> v' -> Bool) -> HashMap k v -> HashMap k' v' -> Bool -equal2 eqk eqv t1 t2 = go (toList' t1 []) (toList' t2 []) +equal2 eqk eqv t1 t2 = go (leavesAndCollisions t1 []) (leavesAndCollisions t2 []) where -- If the two trees are the same, then their lists of 'Leaf's and -- 'Collision's read from left to right should be the same (modulo the @@ -412,13 +427,11 @@ leafEq (L k v) (L k' v') = eqk k k' && eqv v v' -#if MIN_VERSION_base(4,9,0) instance Ord2 HashMap where liftCompare2 = cmp instance Ord k => Ord1 (HashMap k) where liftCompare = cmp compare -#endif -- | The ordering is total and consistent with the `Eq` instance. However, -- nothing else about the ordering is specified, and it may change from @@ -428,7 +441,7 @@ cmp :: (k -> k' -> Ordering) -> (v -> v' -> Ordering) -> HashMap k v -> HashMap k' v' -> Ordering -cmp cmpk cmpv t1 t2 = go (toList' t1 []) (toList' t2 []) +cmp cmpk cmpv t1 t2 = go (leavesAndCollisions t1 []) (leavesAndCollisions t2 []) where go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2) = compare k1 k2 `mappend` @@ -444,13 +457,13 @@ go [] [] = EQ go [] _ = LT go _ [] = GT - go _ _ = error "cmp: Should never happen, toList' includes non Leaf / Collision" + go _ _ = error "cmp: Should never happen, leavesAndCollisions includes non Leaf / Collision" leafCompare (L k v) (L k' v') = cmpk k k' `mappend` cmpv v v' --- Same as 'equal' but doesn't compare the values. +-- Same as 'equal2' but doesn't compare the values. equalKeys1 :: (k -> k' -> Bool) -> HashMap k v -> HashMap k' v' -> Bool -equalKeys1 eq t1 t2 = go (toList' t1 []) (toList' t2 []) +equalKeys1 eq t1 t2 = go (leavesAndCollisions t1 []) (leavesAndCollisions t2 []) where go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2) | k1 == k2 && leafEq l1 l2 @@ -480,9 +493,8 @@ leafEq (L k1 _) (L k2 _) = k1 == k2 -#if MIN_VERSION_hashable(1,2,5) -instance H.Hashable2 HashMap where - liftHashWithSalt2 hk hv salt hm = go salt (toList' hm []) +instance Hashable2 HashMap where + liftHashWithSalt2 hk hv salt hm = go salt (leavesAndCollisions hm []) where -- go :: Int -> [HashMap k v] -> Int go s [] = s @@ -499,14 +511,13 @@ -- hashCollisionWithSalt :: Int -> A.Array (Leaf k v) -> Int hashCollisionWithSalt s - = L.foldl' H.hashWithSalt s . arrayHashesSorted s + = List.foldl' H.hashWithSalt s . arrayHashesSorted s -- arrayHashesSorted :: Int -> A.Array (Leaf k v) -> [Int] - arrayHashesSorted s = L.sort . L.map (hashLeafWithSalt s) . A.toList + arrayHashesSorted s = List.sort . List.map (hashLeafWithSalt s) . A.toList -instance (Hashable k) => H.Hashable1 (HashMap k) where +instance (Hashable k) => Hashable1 (HashMap k) where liftHashWithSalt = H.liftHashWithSalt2 H.hashWithSalt -#endif instance (Hashable k, Hashable v) => Hashable (HashMap k v) where hashWithSalt salt hm = go salt hm @@ -527,20 +538,20 @@ hashCollisionWithSalt :: Int -> A.Array (Leaf k v) -> Int hashCollisionWithSalt s - = L.foldl' H.hashWithSalt s . arrayHashesSorted s + = List.foldl' H.hashWithSalt s . arrayHashesSorted s arrayHashesSorted :: Int -> A.Array (Leaf k v) -> [Int] - arrayHashesSorted s = L.sort . L.map (hashLeafWithSalt s) . A.toList + arrayHashesSorted s = List.sort . List.map (hashLeafWithSalt s) . A.toList - -- Helper to get 'Leaf's and 'Collision's as a list. -toList' :: HashMap k v -> [HashMap k v] -> [HashMap k v] -toList' (BitmapIndexed _ ary) a = A.foldr toList' a ary -toList' (Full ary) a = A.foldr toList' a ary -toList' l@(Leaf _ _) a = l : a -toList' c@(Collision _ _) a = c : a -toList' Empty a = a +-- | Helper to get 'Leaf's and 'Collision's as a list. +leavesAndCollisions :: HashMap k v -> [HashMap k v] -> [HashMap k v] +leavesAndCollisions (BitmapIndexed _ ary) a = A.foldr leavesAndCollisions a ary +leavesAndCollisions (Full ary) a = A.foldr leavesAndCollisions a ary +leavesAndCollisions l@(Leaf _ _) a = l : a +leavesAndCollisions c@(Collision _ _) a = c : a +leavesAndCollisions Empty a = a --- Helper function to detect 'Leaf's and 'Collision's. +-- | Helper function to detect 'Leaf's and 'Collision's. isLeafOrCollision :: HashMap k v -> Bool isLeafOrCollision (Leaf _ _) = True isLeafOrCollision (Collision _ _) = True @@ -549,23 +560,23 @@ ------------------------------------------------------------------------ -- * Construction --- | /O(1)/ Construct an empty map. +-- | \(O(1)\) Construct an empty map. empty :: HashMap k v empty = Empty --- | /O(1)/ Construct a map with a single element. +-- | \(O(1)\) Construct a map with a single element. singleton :: (Hashable k) => k -> v -> HashMap k v singleton k v = Leaf (hash k) (L k v) ------------------------------------------------------------------------ -- * Basic interface --- | /O(1)/ Return 'True' if this map is empty, 'False' otherwise. +-- | \(O(1)\) Return 'True' if this map is empty, 'False' otherwise. null :: HashMap k v -> Bool null Empty = True null _ = False --- | /O(n)/ Return the number of key-value mappings in this map. +-- | \(O(n)\) Return the number of key-value mappings in this map. size :: HashMap k v -> Int size t = go t 0 where @@ -575,7 +586,7 @@ go (Full ary) n = A.foldl' (flip go) n ary go (Collision _ ary) n = n + A.length ary --- | /O(log n)/ Return 'True' if the specified key is present in the +-- | \(O(\log n)\) Return 'True' if the specified key is present in the -- map, 'False' otherwise. member :: (Eq k, Hashable k) => k -> HashMap k a -> Bool member k m = case lookup k m of @@ -583,10 +594,9 @@ Just _ -> True {-# INLINABLE member #-} --- | /O(log n)/ Return the value to which the specified key is mapped, +-- | \(O(\log n)\) Return the value to which the specified key is mapped, -- or 'Nothing' if this map contains no mapping for the key. lookup :: (Eq k, Hashable k) => k -> HashMap k v -> Maybe v -#if __GLASGOW_HASKELL__ >= 802 -- GHC does not yet perform a worker-wrapper transformation on -- unboxed sums automatically. That seems likely to happen at some -- point (possibly as early as GHC 8.6) but for now we do it manually. @@ -599,16 +609,9 @@ lookup# k m = lookupCont (\_ -> (# (# #) | #)) (\v _i -> (# | v #)) (hash k) k 0 m {-# INLINABLE lookup# #-} -#else - -lookup k m = lookupCont (\_ -> Nothing) (\v _i -> Just v) (hash k) k 0 m -{-# INLINABLE lookup #-} -#endif - -- | lookup' is a version of lookup that takes the hash separately. -- It is used to implement alterF. lookup' :: Eq k => Hash -> k -> HashMap k v -> Maybe v -#if __GLASGOW_HASKELL__ >= 802 -- GHC does not yet perform a worker-wrapper transformation on -- unboxed sums automatically. That seems likely to happen at some -- point (possibly as early as GHC 8.6) but for now we do it manually. @@ -619,10 +622,6 @@ (# (# #) | #) -> Nothing (# | (# a, _i #) #) -> Just a {-# INLINE lookup' #-} -#else -lookup' h k m = lookupCont (\_ -> Nothing) (\v _i -> Just v) h k 0 m -{-# INLINABLE lookup' #-} -#endif -- The result of a lookup, keeping track of if a hash collision occured. -- If a collision did not occur then it will have the Int value (-1). @@ -642,7 +641,6 @@ -- Key in map, no collision => Present v (-1) -- Key in map, collision => Present v position lookupRecordCollision :: Eq k => Hash -> k -> HashMap k v -> LookupRes v -#if __GLASGOW_HASKELL__ >= 802 lookupRecordCollision h k m = case lookupRecordCollision# h k m of (# (# #) | #) -> Absent (# | (# a, i #) #) -> Present a (I# i) -- GHC will eliminate the I# @@ -659,12 +657,6 @@ -- INLINABLE to specialize to the Eq instance. {-# INLINABLE lookupRecordCollision# #-} -#else /* GHC < 8.2 so there are no unboxed sums */ - -lookupRecordCollision h k m = lookupCont (\_ -> Absent) Present h k 0 m -{-# INLINABLE lookupRecordCollision #-} -#endif - -- A two-continuation version of lookupRecordCollision. This lets us -- share source code between lookup and lookupRecordCollision without -- risking any performance degradation. @@ -678,11 +670,7 @@ -- keys at the top-level of a hashmap, the offset should be 0. When looking up -- keys at level @n@ of a hashmap, the offset should be @n * bitsPerSubkey@. lookupCont :: -#if __GLASGOW_HASKELL__ >= 802 forall rep (r :: TYPE rep) k v. -#else - forall r k v. -#endif Eq k => ((# #) -> r) -- Absent continuation -> (v -> Int -> r) -- Present continuation @@ -709,7 +697,7 @@ | otherwise = absent (# #) {-# INLINE lookupCont #-} --- | /O(log n)/ Return the value to which the specified key is mapped, +-- | \(O(\log n)\) Return the value to which the specified key is mapped, -- or 'Nothing' if this map contains no mapping for the key. -- -- This is a flipped version of 'lookup'. @@ -720,7 +708,7 @@ {-# INLINE (!?) #-} --- | /O(log n)/ Return the value to which the specified key is mapped, +-- | \(O(\log n)\) Return the value to which the specified key is mapped, -- or the default value if this map contains no mapping for the key. -- -- @since 0.2.11 @@ -733,7 +721,7 @@ {-# INLINABLE findWithDefault #-} --- | /O(log n)/ Return the value to which the specified key is mapped, +-- | \(O(\log n)\) Return the value to which the specified key is mapped, -- or the default value if this map contains no mapping for the key. -- -- DEPRECATED: lookupDefault is deprecated as of version 0.2.11, replaced @@ -741,16 +729,12 @@ lookupDefault :: (Eq k, Hashable k) => v -- ^ Default value to return. -> k -> HashMap k v -> v -lookupDefault def k t = findWithDefault def k t +lookupDefault = findWithDefault {-# INLINE lookupDefault #-} --- | /O(log n)/ Return the value to which the specified key is mapped. +-- | \(O(\log n)\) Return the value to which the specified key is mapped. -- Calls 'error' if this map contains no mapping for the key. -#if MIN_VERSION_base(4,9,0) (!) :: (Eq k, Hashable k, HasCallStack) => HashMap k v -> k -> v -#else -(!) :: (Eq k, Hashable k) => HashMap k v -> k -> v -#endif (!) m k = case lookup k m of Just v -> v Nothing -> error "Data.Strict.HashMap.Autogen.Internal.(!): key not found" @@ -769,12 +753,15 @@ -- | Create a 'BitmapIndexed' or 'Full' node. bitmapIndexedOrFull :: Bitmap -> A.Array (HashMap k v) -> HashMap k v -bitmapIndexedOrFull b ary +-- The strictness in @ary@ helps achieve a nice code size reduction in +-- @unionWith[Key]@ with GHC 9.2.2. See the Core diffs in +-- https://github.com/haskell-unordered-containers/unordered-containers/pull/376. +bitmapIndexedOrFull b !ary | b == fullNodeMask = Full ary | otherwise = BitmapIndexed b ary {-# INLINE bitmapIndexedOrFull #-} --- | /O(log n)/ Associate the specified value with the specified +-- | \(O(\log n)\) Associate the specified value with the specified -- key in this map. If this map previously contained a mapping for -- the key, the old value is replaced. insert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v @@ -809,7 +796,7 @@ !st' = go h k x (s+bitsPerSubkey) st in if st' `ptrEq` st then t - else Full (update16 ary i st') + else Full (update32 ary i st') where i = index h s go h k x s t@(Collision hy v) | h == hy = Collision h (updateOrSnocWith (\a _ -> (# a #)) k x v) @@ -843,20 +830,12 @@ go h k x s (Full ary) = let !st = A.index ary i !st' = go h k x (s+bitsPerSubkey) st - in Full (update16 ary i st') + in Full (update32 ary i st') where i = index h s go h k x s t@(Collision hy v) - | h == hy = Collision h (snocNewLeaf (L k x) v) + | h == hy = Collision h (A.snoc v (L k x)) | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) - where - snocNewLeaf :: Leaf k v -> A.Array (Leaf k v) -> A.Array (Leaf k v) - snocNewLeaf leaf ary = A.run $ do - let n = A.length ary - mary <- A.new_ (n + 1) - A.copy ary 0 mary 0 n - A.write mary n leaf - return mary {-# NOINLINE insertNewKey #-} @@ -887,7 +866,7 @@ go collPos h k x s (Full ary) = let !st = A.index ary i !st' = go collPos h k x (s+bitsPerSubkey) st - in Full (update16 ary i st') + in Full (update32 ary i st') where i = index h s go collPos h k x _s (Collision _hy v) | collPos >= 0 = Collision h (setAtPosition collPos k x v) @@ -967,7 +946,7 @@ | otherwise = 0 {-# INLINE two #-} --- | /O(log n)/ Associate the value with the key in this map. If +-- | \(O(\log n)\) Associate the value with the key in this map. If -- this map previously contained a mapping for the key, the old value -- is replaced by the result of applying the given function to the new -- and old value. Example: @@ -996,7 +975,7 @@ | hy == h = if ky == k then case f y of (# v' #) | ptrEq y v' -> t - | otherwise -> Leaf h (L k (v')) + | otherwise -> Leaf h (L k v') else collision h l (L k x) | otherwise = runST (two s h k x hy t) go h k s t@(BitmapIndexed b ary) @@ -1015,7 +994,7 @@ go h k s t@(Full ary) = let !st = A.index ary i !st' = go h k (s+bitsPerSubkey) st - ary' = update16 ary i $! st' + ary' = update32 ary i $! st' in if ptrEq st st' then t else Full ary' @@ -1035,12 +1014,8 @@ insertModifyingArr x f k0 ary0 = go k0 ary0 0 (A.length ary0) where go !k !ary !i !n - | i >= n = A.run $ do - -- Not found, append to the end. - mary <- A.new_ (n + 1) - A.copy ary 0 mary 0 n - A.write mary n (L k x) - return mary + -- Not found, append to the end. + | i >= n = A.snoc ary $ L k x | otherwise = case A.index ary i of (L kx y) | k == kx -> case f y of (# y' #) -> if ptrEq y y' @@ -1053,11 +1028,11 @@ unsafeInsertWith :: forall k v. (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v -unsafeInsertWith f k0 v0 m0 = unsafeInsertWithKey (const f) k0 v0 m0 +unsafeInsertWith f k0 v0 m0 = unsafeInsertWithKey (\_ a b -> (# f a b #)) k0 v0 m0 {-# INLINABLE unsafeInsertWith #-} unsafeInsertWithKey :: forall k v. (Eq k, Hashable k) - => (k -> v -> v -> v) -> k -> v -> HashMap k v + => (k -> v -> v -> (# v #)) -> k -> v -> HashMap k v -> HashMap k v unsafeInsertWithKey f k0 v0 m0 = runST (go h0 k0 v0 0 m0) where @@ -1066,7 +1041,8 @@ go !h !k x !_ Empty = return $! Leaf h (L k x) go h k x s t@(Leaf hy l@(L ky y)) | hy == h = if ky == k - then return $! Leaf h (L k (f k x y)) + then case f k x y of + (# v #) -> return $! Leaf h (L k v) else return $! collision h l (L k x) | otherwise = two s h k x hy t go h k x s t@(BitmapIndexed b ary) @@ -1087,11 +1063,11 @@ return t where i = index h s go h k x s t@(Collision hy v) - | h == hy = return $! Collision h (updateOrSnocWithKey (\key a b -> (# f key a b #) ) k x v) + | h == hy = return $! Collision h (updateOrSnocWithKey f k x v) | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) {-# INLINABLE unsafeInsertWithKey #-} --- | /O(log n)/ Remove the mapping for the specified key from this map +-- | \(O(\log n)\) Remove the mapping for the specified key from this map -- if present. delete :: (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v delete k m = delete' (hash k) k m @@ -1198,7 +1174,7 @@ go !_ !_ !_ !_ Empty = Empty -- error "Internal error: deleteKeyExists empty" {-# NOINLINE deleteKeyExists #-} --- | /O(log n)/ Adjust the value tied to a given key in this map only +-- | \(O(\log n)\) Adjust the value tied to a given key in this map only -- if it is present. Otherwise, leave the map alone. adjust :: (Eq k, Hashable k) => (v -> v) -> k -> HashMap k v -> HashMap k v -- This operation really likes to leak memory, so using this @@ -1236,7 +1212,7 @@ let i = index h s !st = A.index ary i !st' = go h k (s+bitsPerSubkey) st - ary' = update16 ary i $! st' + ary' = update32 ary i $! st' in if ptrEq st st' then t else Full ary' @@ -1248,7 +1224,7 @@ | otherwise = t {-# INLINABLE adjust# #-} --- | /O(log n)/ The expression @('update' f k map)@ updates the value @x@ at @k@ +-- | \(O(\log n)\) The expression @('update' f k map)@ updates the value @x@ at @k@ -- (if it is in the map). If @(f x)@ is 'Nothing', the element is deleted. -- If it is @('Just' y)@, the key @k@ is bound to the new value @y@. update :: (Eq k, Hashable k) => (a -> Maybe a) -> k -> HashMap k a -> HashMap k a @@ -1256,7 +1232,7 @@ {-# INLINABLE update #-} --- | /O(log n)/ The expression @('alter' f k map)@ alters the value @x@ at @k@, or +-- | \(O(\log n)\) The expression @('alter' f k map)@ alters the value @x@ at @k@, or -- absence thereof. -- -- 'alter' can be used to insert, delete, or update a value in a map. In short: @@ -1272,7 +1248,7 @@ Just v -> insert k v m {-# INLINABLE alter #-} --- | /O(log n)/ The expression @('alterF' f k map)@ alters the value @x@ at +-- | \(O(\log n)\) The expression @('alterF' f k map)@ alters the value @x@ at -- @k@, or absence thereof. -- -- 'alterF' can be used to insert, delete, or update a value in a map. @@ -1292,17 +1268,15 @@ let !h = hash k mv = lookup' h k m - in (<$> f mv) $ \fres -> - case fres of - Nothing -> maybe m (const (delete' h k m)) mv - Just v' -> insert' h k v' m + in (<$> f mv) $ \case + Nothing -> maybe m (const (delete' h k m)) mv + Just v' -> insert' h k v' m -- We unconditionally rewrite alterF in RULES, but we expose an -- unfolding just in case it's used in some way that prevents the -- rule from firing. {-# INLINABLE [0] alterF #-} -#if MIN_VERSION_base(4,8,0) -- This is just a bottom value. See the comment on the "alterFWeird" -- rule. test_bottom :: a @@ -1385,8 +1359,7 @@ -- eagerly, whether or not the given function requires that information. alterFEager :: (Functor f, Eq k, Hashable k) => (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v) -alterFEager f !k m = (<$> f mv) $ \fres -> - case fres of +alterFEager f !k m = (<$> f mv) $ \case ------------------------------ -- Delete the key from the map. @@ -1419,9 +1392,8 @@ Absent -> Nothing Present v _ -> Just v {-# INLINABLE alterFEager #-} -#endif --- | /O(n*log m)/ Inclusion of maps. A map is included in another map if the keys +-- | \(O(n \log m)\) Inclusion of maps. A map is included in another map if the keys -- are subsets and the corresponding values are equal: -- -- > isSubmapOf m1 m2 = keys m1 `isSubsetOf` keys m2 && @@ -1437,10 +1409,10 @@ -- -- @since 0.2.12 isSubmapOf :: (Eq k, Hashable k, Eq v) => HashMap k v -> HashMap k v -> Bool -isSubmapOf = (inline isSubmapOfBy) (==) +isSubmapOf = Exts.inline isSubmapOfBy (==) {-# INLINABLE isSubmapOf #-} --- | /O(n*log m)/ Inclusion of maps with value comparison. A map is included in +-- | \(O(n \log m)\) Inclusion of maps with value comparison. A map is included in -- another map if the keys are subsets and if the comparison function is true -- for the corresponding values: -- @@ -1512,7 +1484,7 @@ go _ (Full {}) (BitmapIndexed {}) = False {-# INLINABLE isSubmapOfBy #-} --- | /O(min n m))/ Checks if a bitmap indexed node is a submap of another. +-- | \(O(\min n m))\) Checks if a bitmap indexed node is a submap of another. submapBitmapIndexed :: (HashMap k v1 -> HashMap k v2 -> Bool) -> Bitmap -> A.Array (HashMap k v1) -> Bitmap -> A.Array (HashMap k v2) -> Bool submapBitmapIndexed comp !b1 !ary1 !b2 !ary2 = subsetBitmaps && go 0 0 (b1Orb2 .&. negate b1Orb2) where @@ -1539,7 +1511,7 @@ ------------------------------------------------------------------------ -- * Combine --- | /O(n+m)/ The union of two maps. If a key occurs in both maps, the +-- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, the -- mapping from the first will be the mapping in the result. -- -- ==== __Examples__ @@ -1550,7 +1522,7 @@ union = unionWith const {-# INLINABLE union #-} --- | /O(n+m)/ The union of two maps. If a key occurs in both maps, +-- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the -- result. unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> HashMap k v -> HashMap k v @@ -1558,7 +1530,7 @@ unionWith f = unionWithKey (const f) {-# INLINE unionWith #-} --- | /O(n+m)/ The union of two maps. If a key occurs in both maps, +-- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the -- result. unionWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> HashMap k v -> HashMap k v @@ -1581,7 +1553,7 @@ | h1 == h2 = Collision h1 (updateOrSnocWithKey (\k a b -> (# f k b a #)) k2 v2 ls1) | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Collision h1 ls1) t2@(Collision h2 ls2) - | h1 == h2 = Collision h1 (updateOrConcatWithKey f ls1 ls2) + | h1 == h2 = Collision h1 (updateOrConcatWithKey (\k a b -> (# f k a b #)) ls1 ls2) | otherwise = goDifferentHash s h1 h2 t1 t2 -- branch vs. branch go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) = @@ -1624,12 +1596,12 @@ go s (Full ary1) t2 = let h2 = leafHashCode t2 i = index h2 s - ary' = update16With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 + ary' = update32With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 in Full ary' go s t1 (Full ary2) = let h1 = leafHashCode t1 i = index h1 s - ary' = update16With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 + ary' = update32With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 in Full ary' leafHashCode (Leaf h _) = h @@ -1637,7 +1609,7 @@ leafHashCode _ = error "leafHashCode" goDifferentHash s h1 h2 t1 t2 - | m1 == m2 = BitmapIndexed m1 (A.singleton $! go (s+bitsPerSubkey) t1 t2) + | m1 == m2 = BitmapIndexed m1 (A.singleton $! goDifferentHash (s+bitsPerSubkey) h1 h2 t1 t2) | m1 < m2 = BitmapIndexed (m1 .|. m2) (A.pair t1 t2) | otherwise = BitmapIndexed (m1 .|. m2) (A.pair t2 t1) where @@ -1648,27 +1620,31 @@ -- | Strict in the result of @f@. unionArrayBy :: (a -> a -> a) -> Bitmap -> Bitmap -> A.Array a -> A.Array a -> A.Array a -unionArrayBy f b1 b2 ary1 ary2 = A.run $ do - let b' = b1 .|. b2 - mary <- A.new_ (popCount b') +-- The manual forcing of @b1@, @b2@, @ary1@ and @ary2@ results in handsome +-- Core size reductions with GHC 9.2.2. See the Core diffs in +-- https://github.com/haskell-unordered-containers/unordered-containers/pull/376. +unionArrayBy f !b1 !b2 !ary1 !ary2 = A.run $ do + let bCombined = b1 .|. b2 + mary <- A.new_ (popCount bCombined) -- iterate over nonzero bits of b1 .|. b2 - -- it would be nice if we could shift m by more than 1 each time - let ba = b1 .&. b2 - go !i !i1 !i2 !m - | m > b' = return () - | b' .&. m == 0 = go i i1 i2 (m `unsafeShiftL` 1) - | ba .&. m /= 0 = do + let go !i !i1 !i2 !b + | b == 0 = return () + | testBit (b1 .&. b2) = do x1 <- A.indexM ary1 i1 x2 <- A.indexM ary2 i2 A.write mary i $! f x1 x2 - go (i+1) (i1+1) (i2+1) (m `unsafeShiftL` 1) - | b1 .&. m /= 0 = do + go (i+1) (i1+1) (i2+1) b' + | testBit b1 = do A.write mary i =<< A.indexM ary1 i1 - go (i+1) (i1+1) (i2 ) (m `unsafeShiftL` 1) - | otherwise = do + go (i+1) (i1+1) i2 b' + | otherwise = do A.write mary i =<< A.indexM ary2 i2 - go (i+1) (i1 ) (i2+1) (m `unsafeShiftL` 1) - go 0 0 0 (b' .&. negate b') -- XXX: b' must be non-zero + go (i+1) i1 (i2+1) b' + where + m = 1 `unsafeShiftL` countTrailingZeros b + testBit x = x .&. m /= 0 + b' = b .&. complement m + go 0 0 0 bCombined return mary -- TODO: For the case where b1 .&. b2 == b1, i.e. when one is a -- subset of the other, we could use a slightly simpler algorithm, @@ -1679,7 +1655,7 @@ -- | Construct a set containing all elements from a list of sets. unions :: (Eq k, Hashable k) => [HashMap k v] -> HashMap k v -unions = L.foldl' union empty +unions = List.foldl' union empty {-# INLINE unions #-} @@ -1699,7 +1675,7 @@ -- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?') -- @ -- --- @since UNRELEASED +-- @since 0.2.13.0 compose :: (Eq b, Hashable b) => HashMap b c -> HashMap a b -> HashMap a c compose bc !ab | null bc = empty @@ -1708,7 +1684,7 @@ ------------------------------------------------------------------------ -- * Transformations --- | /O(n)/ Transform this map by applying a function to every value. +-- | \(O(n)\) Transform this map by applying a function to every value. mapWithKey :: (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2 mapWithKey f = go where @@ -1722,7 +1698,7 @@ A.map' (\ (L k v) -> L k (f k v)) ary {-# INLINE mapWithKey #-} --- | /O(n)/ Transform this map by applying a function to every value. +-- | \(O(n)\) Transform this map by applying a function to every value. map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2 map f = mapWithKey (const f) {-# INLINE map #-} @@ -1730,7 +1706,7 @@ -- TODO: We should be able to use mutation to create the new -- 'HashMap'. --- | /O(n)/ Perform an 'Applicative' action for each key-value pair +-- | \(O(n)\) Perform an 'Applicative' action for each key-value pair -- in a 'HashMap' and produce a 'HashMap' of all the results. -- -- Note: the order in which the actions occur is unspecified. In particular, @@ -1751,20 +1727,38 @@ Collision h <$> A.traverse' (\ (L k v) -> L k <$> f k v) ary {-# INLINE traverseWithKey #-} +-- | \(O(n)\). +-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- keys to the same new key. In this case there is no guarantee which of the +-- associated values is chosen for the conflicting key. +-- +-- >>> mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) +-- fromList [(4,"b"),(6,"a")] +-- >>> mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) +-- fromList [(1,"c")] +-- >>> mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) +-- fromList [(3,"c")] +-- +-- @since 0.2.14.0 +mapKeys :: (Eq k2, Hashable k2) => (k1 -> k2) -> HashMap k1 v -> HashMap k2 v +mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) [] + ------------------------------------------------------------------------ -- * Difference and intersection --- | /O(n*log m)/ Difference of two maps. Return elements of the first map +-- | \(O(n \log m)\) Difference of two maps. Return elements of the first map -- not existing in the second. difference :: (Eq k, Hashable k) => HashMap k v -> HashMap k w -> HashMap k v difference a b = foldlWithKey' go empty a where go m k v = case lookup k b of - Nothing -> insert k v m + Nothing -> unsafeInsert k v m _ -> m {-# INLINABLE difference #-} --- | /O(n*log m)/ Difference with a combining function. When two equal keys are +-- | \(O(n \log m)\) Difference with a combining function. When two equal keys are -- encountered, the combining function is applied to the values of these keys. -- If it returns 'Nothing', the element is discarded (proper set difference). If -- it returns (@'Just' y@), the element is updated with a new value @y@. @@ -1772,48 +1766,175 @@ differenceWith f a b = foldlWithKey' go empty a where go m k v = case lookup k b of - Nothing -> insert k v m - Just w -> maybe m (\y -> insert k y m) (f v w) + Nothing -> unsafeInsert k v m + Just w -> maybe m (\y -> unsafeInsert k y m) (f v w) {-# INLINABLE differenceWith #-} --- | /O(n*log m)/ Intersection of two maps. Return elements of the first +-- | \(O(n \log m)\) Intersection of two maps. Return elements of the first -- map for keys existing in the second. intersection :: (Eq k, Hashable k) => HashMap k v -> HashMap k w -> HashMap k v -intersection a b = foldlWithKey' go empty a - where - go m k v = case lookup k b of - Just _ -> insert k v m - _ -> m +intersection = Exts.inline intersectionWith const {-# INLINABLE intersection #-} --- | /O(n*log m)/ Intersection of two maps. If a key occurs in both maps +-- | \(O(n \log m)\) Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps. -intersectionWith :: (Eq k, Hashable k) => (v1 -> v2 -> v3) -> HashMap k v1 - -> HashMap k v2 -> HashMap k v3 -intersectionWith f a b = foldlWithKey' go empty a - where - go m k v = case lookup k b of - Just w -> insert k (f v w) m - _ -> m +intersectionWith :: (Eq k, Hashable k) => (v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 +intersectionWith f = Exts.inline intersectionWithKey $ const f {-# INLINABLE intersectionWith #-} --- | /O(n*log m)/ Intersection of two maps. If a key occurs in both maps +-- | \(O(n \log m)\) Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps. -intersectionWithKey :: (Eq k, Hashable k) => (k -> v1 -> v2 -> v3) - -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 -intersectionWithKey f a b = foldlWithKey' go empty a - where - go m k v = case lookup k b of - Just w -> insert k (f k v w) m - _ -> m +intersectionWithKey :: (Eq k, Hashable k) => (k -> v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 +intersectionWithKey f = intersectionWithKey# $ \k v1 v2 -> (# f k v1 v2 #) {-# INLINABLE intersectionWithKey #-} +intersectionWithKey# :: Eq k => (k -> v1 -> v2 -> (# v3 #)) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 +intersectionWithKey# f = go 0 + where + -- empty vs. anything + go !_ _ Empty = Empty + go _ Empty _ = Empty + -- leaf vs. anything + go s (Leaf h1 (L k1 v1)) t2 = + lookupCont + (\_ -> Empty) + (\v _ -> case f k1 v1 v of (# v' #) -> Leaf h1 $ L k1 v') + h1 k1 s t2 + go s t1 (Leaf h2 (L k2 v2)) = + lookupCont + (\_ -> Empty) + (\v _ -> case f k2 v v2 of (# v' #) -> Leaf h2 $ L k2 v') + h2 k2 s t1 + -- collision vs. collision + go _ (Collision h1 ls1) (Collision h2 ls2) = intersectionCollisions f h1 h2 ls1 ls2 + -- branch vs. branch + go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) = + intersectionArrayBy (go (s + bitsPerSubkey)) b1 b2 ary1 ary2 + go s (BitmapIndexed b1 ary1) (Full ary2) = + intersectionArrayBy (go (s + bitsPerSubkey)) b1 fullNodeMask ary1 ary2 + go s (Full ary1) (BitmapIndexed b2 ary2) = + intersectionArrayBy (go (s + bitsPerSubkey)) fullNodeMask b2 ary1 ary2 + go s (Full ary1) (Full ary2) = + intersectionArrayBy (go (s + bitsPerSubkey)) fullNodeMask fullNodeMask ary1 ary2 + -- collision vs. branch + go s (BitmapIndexed b1 ary1) t2@(Collision h2 _ls2) + | b1 .&. m2 == 0 = Empty + | otherwise = go (s + bitsPerSubkey) (A.index ary1 i) t2 + where + m2 = mask h2 s + i = sparseIndex b1 m2 + go s t1@(Collision h1 _ls1) (BitmapIndexed b2 ary2) + | b2 .&. m1 == 0 = Empty + | otherwise = go (s + bitsPerSubkey) t1 (A.index ary2 i) + where + m1 = mask h1 s + i = sparseIndex b2 m1 + go s (Full ary1) t2@(Collision h2 _ls2) = go (s + bitsPerSubkey) (A.index ary1 i) t2 + where + i = index h2 s + go s t1@(Collision h1 _ls1) (Full ary2) = go (s + bitsPerSubkey) t1 (A.index ary2 i) + where + i = index h1 s +{-# INLINE intersectionWithKey# #-} + +intersectionArrayBy :: + ( HashMap k v1 -> + HashMap k v2 -> + HashMap k v3 + ) -> + Bitmap -> + Bitmap -> + A.Array (HashMap k v1) -> + A.Array (HashMap k v2) -> + HashMap k v3 +intersectionArrayBy f !b1 !b2 !ary1 !ary2 + | b1 .&. b2 == 0 = Empty + | otherwise = runST $ do + mary <- A.new_ $ popCount bIntersect + -- iterate over nonzero bits of b1 .|. b2 + let go !i !i1 !i2 !b !bFinal + | b == 0 = pure (i, bFinal) + | testBit $ b1 .&. b2 = do + x1 <- A.indexM ary1 i1 + x2 <- A.indexM ary2 i2 + case f x1 x2 of + Empty -> go i (i1 + 1) (i2 + 1) b' (bFinal .&. complement m) + _ -> do + A.write mary i $! f x1 x2 + go (i + 1) (i1 + 1) (i2 + 1) b' bFinal + | testBit b1 = go i (i1 + 1) i2 b' bFinal + | otherwise = go i i1 (i2 + 1) b' bFinal + where + m = 1 `unsafeShiftL` countTrailingZeros b + testBit x = x .&. m /= 0 + b' = b .&. complement m + (len, bFinal) <- go 0 0 0 bCombined bIntersect + case len of + 0 -> pure Empty + 1 -> do + l <- A.read mary 0 + if isLeafOrCollision l + then pure l + else BitmapIndexed bFinal <$> (A.unsafeFreeze =<< A.shrink mary 1) + _ -> bitmapIndexedOrFull bFinal <$> (A.unsafeFreeze =<< A.shrink mary len) + where + bCombined = b1 .|. b2 + bIntersect = b1 .&. b2 +{-# INLINE intersectionArrayBy #-} + +intersectionCollisions :: Eq k => (k -> v1 -> v2 -> (# v3 #)) -> Hash -> Hash -> A.Array (Leaf k v1) -> A.Array (Leaf k v2) -> HashMap k v3 +intersectionCollisions f h1 h2 ary1 ary2 + | h1 == h2 = runST $ do + mary2 <- A.thaw ary2 0 $ A.length ary2 + mary <- A.new_ $ min (A.length ary1) (A.length ary2) + let go i j + | i >= A.length ary1 || j >= A.lengthM mary2 = pure j + | otherwise = do + L k1 v1 <- A.indexM ary1 i + searchSwap k1 j mary2 >>= \case + Just (L _k2 v2) -> do + let !(# v3 #) = f k1 v1 v2 + A.write mary j $ L k1 v3 + go (i + 1) (j + 1) + Nothing -> do + go (i + 1) j + len <- go 0 0 + case len of + 0 -> pure Empty + 1 -> Leaf h1 <$> A.read mary 0 + _ -> Collision h1 <$> (A.unsafeFreeze =<< A.shrink mary len) + | otherwise = Empty +{-# INLINE intersectionCollisions #-} + +-- | Say we have +-- @ +-- 1 2 3 4 +-- @ +-- and we search for @3@. Then we can mutate the array to +-- @ +-- undefined 2 1 4 +-- @ +-- We don't actually need to write undefined, we just have to make sure that the next search starts 1 after the current one. +searchSwap :: Eq k => k -> Int -> A.MArray s (Leaf k v) -> ST s (Maybe (Leaf k v)) +searchSwap toFind start = go start toFind start + where + go i0 k i mary + | i >= A.lengthM mary = pure Nothing + | otherwise = do + l@(L k' _v) <- A.read mary i + if k == k' + then do + A.write mary i =<< A.read mary i0 + pure $ Just l + else go i0 k (i + 1) mary +{-# INLINE searchSwap #-} + ------------------------------------------------------------------------ -- * Folds --- | /O(n)/ Reduce this map by applying a binary operator to all +-- | \(O(n)\) Reduce this map by applying a binary operator to all -- elements, using the given starting value (typically the -- left-identity of the operator). Each application of the operator -- is evaluated before using the result in the next application. @@ -1822,7 +1943,7 @@ foldl' f = foldlWithKey' (\ z _ v -> f z v) {-# INLINE foldl' #-} --- | /O(n)/ Reduce this map by applying a binary operator to all +-- | \(O(n)\) Reduce this map by applying a binary operator to all -- elements, using the given starting value (typically the -- right-identity of the operator). Each application of the operator -- is evaluated before using the result in the next application. @@ -1831,7 +1952,7 @@ foldr' f = foldrWithKey' (\ _ v z -> f v z) {-# INLINE foldr' #-} --- | /O(n)/ Reduce this map by applying a binary operator to all +-- | \(O(n)\) Reduce this map by applying a binary operator to all -- elements, using the given starting value (typically the -- left-identity of the operator). Each application of the operator -- is evaluated before using the result in the next application. @@ -1846,7 +1967,7 @@ go z (Collision _ ary) = A.foldl' (\ z' (L k v) -> f z' k v) z ary {-# INLINE foldlWithKey' #-} --- | /O(n)/ Reduce this map by applying a binary operator to all +-- | \(O(n)\) Reduce this map by applying a binary operator to all -- elements, using the given starting value (typically the -- right-identity of the operator). Each application of the operator -- is evaluated before using the result in the next application. @@ -1861,21 +1982,21 @@ go (Collision _ ary) !z = A.foldr' (\ (L k v) z' -> f k v z') z ary {-# INLINE foldrWithKey' #-} --- | /O(n)/ Reduce this map by applying a binary operator to all +-- | \(O(n)\) Reduce this map by applying a binary operator to all -- elements, using the given starting value (typically the -- right-identity of the operator). foldr :: (v -> a -> a) -> a -> HashMap k v -> a foldr f = foldrWithKey (const f) {-# INLINE foldr #-} --- | /O(n)/ Reduce this map by applying a binary operator to all +-- | \(O(n)\) Reduce this map by applying a binary operator to all -- elements, using the given starting value (typically the -- left-identity of the operator). foldl :: (a -> v -> a) -> a -> HashMap k v -> a foldl f = foldlWithKey (\a _k v -> f a v) {-# INLINE foldl #-} --- | /O(n)/ Reduce this map by applying a binary operator to all +-- | \(O(n)\) Reduce this map by applying a binary operator to all -- elements, using the given starting value (typically the -- right-identity of the operator). foldrWithKey :: (k -> v -> a -> a) -> a -> HashMap k v -> a @@ -1888,7 +2009,7 @@ go (Collision _ ary) z = A.foldr (\ (L k v) z' -> f k v z') z ary {-# INLINE foldrWithKey #-} --- | /O(n)/ Reduce this map by applying a binary operator to all +-- | \(O(n)\) Reduce this map by applying a binary operator to all -- elements, using the given starting value (typically the -- left-identity of the operator). foldlWithKey :: (a -> k -> v -> a) -> a -> HashMap k v -> a @@ -1901,7 +2022,7 @@ go z (Collision _ ary) = A.foldl (\ z' (L k v) -> f z' k v) z ary {-# INLINE foldlWithKey #-} --- | /O(n)/ Reduce the map by applying a function to each element +-- | \(O(n)\) Reduce the map by applying a function to each element -- and combining the results with a monoid operation. foldMapWithKey :: Monoid m => (k -> v -> m) -> HashMap k v -> m foldMapWithKey f = go @@ -1916,7 +2037,7 @@ ------------------------------------------------------------------------ -- * Filter --- | /O(n)/ Transform this map by applying a function to every value +-- | \(O(n)\) Transform this map by applying a function to every value -- and retaining only some of them. mapMaybeWithKey :: (k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 mapMaybeWithKey f = filterMapAux onLeaf onColl @@ -1927,13 +2048,13 @@ | otherwise = Nothing {-# INLINE mapMaybeWithKey #-} --- | /O(n)/ Transform this map by applying a function to every value +-- | \(O(n)\) Transform this map by applying a function to every value -- and retaining only some of them. mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 mapMaybe f = mapMaybeWithKey (const f) {-# INLINE mapMaybe #-} --- | /O(n)/ Filter this map by retaining only elements satisfying a +-- | \(O(n)\) Filter this map by retaining only elements satisfying a -- predicate. filterWithKey :: forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v filterWithKey pred = filterMapAux onLeaf onColl @@ -2014,7 +2135,7 @@ | otherwise = step ary mary (i+1) j n {-# INLINE filterMapAux #-} --- | /O(n)/ Filter this map by retaining only elements which values +-- | \(O(n)\) Filter this map by retaining only elements which values -- satisfy a predicate. filter :: (v -> Bool) -> HashMap k v -> HashMap k v filter p = filterWithKey (\_ v -> p v) @@ -2026,34 +2147,34 @@ -- TODO: Improve fusion rules by modelled them after the Prelude ones -- on lists. --- | /O(n)/ Return a list of this map's keys. The list is produced +-- | \(O(n)\) Return a list of this map's keys. The list is produced -- lazily. keys :: HashMap k v -> [k] -keys = L.map fst . toList +keys = List.map fst . toList {-# INLINE keys #-} --- | /O(n)/ Return a list of this map's values. The list is produced +-- | \(O(n)\) Return a list of this map's values. The list is produced -- lazily. elems :: HashMap k v -> [v] -elems = L.map snd . toList +elems = List.map snd . toList {-# INLINE elems #-} ------------------------------------------------------------------------ -- ** Lists --- | /O(n)/ Return a list of this map's elements. The list is +-- | \(O(n)\) Return a list of this map's elements. The list is -- produced lazily. The order of its elements is unspecified. toList :: HashMap k v -> [(k, v)] -toList t = build (\ c z -> foldrWithKey (curry c) z t) +toList t = Exts.build (\ c z -> foldrWithKey (curry c) z t) {-# INLINE toList #-} --- | /O(n)/ Construct a map with the supplied mappings. If the list +-- | \(O(n)\) Construct a map with the supplied mappings. If the list -- contains duplicate mappings, the later mappings take precedence. fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v -fromList = L.foldl' (\ m (k, v) -> unsafeInsert k v m) empty +fromList = List.foldl' (\ m (k, v) -> unsafeInsert k v m) empty {-# INLINABLE fromList #-} --- | /O(n*log n)/ Construct a map from a list of elements. Uses +-- | \(O(n \log n)\) Construct a map from a list of elements. Uses -- the provided function @f@ to merge duplicate entries with -- @(f newVal oldVal)@. -- @@ -2084,10 +2205,10 @@ -- > fromListWith f [(k, a), (k, b), (k, c), (k, d)] -- > = fromList [(k, f d (f c (f b a)))] fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v -fromListWith f = L.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty +fromListWith f = List.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty {-# INLINE fromListWith #-} --- | /O(n*log n)/ Construct a map from a list of elements. Uses +-- | \(O(n \log n)\) Construct a map from a list of elements. Uses -- the provided function to merge duplicate entries. -- -- === Examples @@ -2114,20 +2235,16 @@ -- -- @since 0.2.11 fromListWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> [(k, v)] -> HashMap k v -fromListWithKey f = L.foldl' (\ m (k, v) -> unsafeInsertWithKey f k v m) empty +fromListWithKey f = List.foldl' (\ m (k, v) -> unsafeInsertWithKey (\k' a b -> (# f k' a b #)) k v m) empty {-# INLINE fromListWithKey #-} ------------------------------------------------------------------------ -- Array operations --- | /O(n)/ Look up the value associated with the given key in an +-- | \(O(n)\) Look up the value associated with the given key in an -- array. lookupInArrayCont :: -#if __GLASGOW_HASKELL__ >= 802 forall rep (r :: TYPE rep) k v. -#else - forall r k v. -#endif Eq k => ((# #) -> r) -> (v -> Int -> r) -> k -> A.Array (Leaf k v) -> r lookupInArrayCont absent present k0 ary0 = go k0 ary0 0 (A.length ary0) where @@ -2140,7 +2257,7 @@ | otherwise -> go k ary (i+1) n {-# INLINE lookupInArrayCont #-} --- | /O(n)/ Lookup the value associated with the given key in this +-- | \(O(n)\) Lookup the value associated with the given key in this -- array. Returns 'Nothing' if the key wasn't found. indexOf :: Eq k => k -> A.Array (Leaf k v) -> Maybe Int indexOf k0 ary0 = go k0 ary0 0 (A.length ary0) @@ -2176,12 +2293,8 @@ updateOrSnocWithKey f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0) where go !k v !ary !i !n - | i >= n = A.run $ do - -- Not found, append to the end. - mary <- A.new_ (n + 1) - A.copy ary 0 mary 0 n - A.write mary n (L k v) - return mary + -- Not found, append to the end. + | i >= n = A.snoc ary $ L k v | L kx y <- A.index ary i , k == kx , (# v2 #) <- f k v y @@ -2190,11 +2303,7 @@ = go k v ary (i+1) n {-# INLINABLE updateOrSnocWithKey #-} -updateOrConcatWith :: Eq k => (v -> v -> v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) -updateOrConcatWith f = updateOrConcatWithKey (const f) -{-# INLINABLE updateOrConcatWith #-} - -updateOrConcatWithKey :: Eq k => (k -> v -> v -> v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) +updateOrConcatWithKey :: Eq k => (k -> v -> v -> (# v #)) -> A.Array (Leaf k v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) updateOrConcatWithKey f ary1 ary2 = A.run $ do -- TODO: instead of mapping and then folding, should we traverse? -- We'll have to be careful to avoid allocating pairs or similar. @@ -2216,7 +2325,7 @@ Just i1 -> do -- key occurs in both arrays, store combination in position i1 L k v1 <- A.indexM ary1 i1 L _ v2 <- A.indexM ary2 i2 - A.write mary i1 (L k (f k v1 v2)) + case f k v1 v2 of (# v3 #) -> A.write mary i1 (L k v3) go iEnd (i2+1) Nothing -> do -- key is only in ary2, append to end A.write mary iEnd =<< A.indexM ary2 i2 @@ -2225,7 +2334,7 @@ return mary {-# INLINABLE updateOrConcatWithKey #-} --- | /O(n*m)/ Check if the first array is a subset of the second array. +-- | \(O(n*m)\) Check if the first array is a subset of the second array. subsetArray :: Eq k => (v1 -> v2 -> Bool) -> A.Array (Leaf k v1) -> A.Array (Leaf k v2) -> Bool subsetArray cmpV ary1 ary2 = A.length ary1 <= A.length ary2 && A.all inAry2 ary1 where @@ -2235,66 +2344,105 @@ ------------------------------------------------------------------------ -- Manually unrolled loops --- | /O(n)/ Update the element at the given position in this array. -update16 :: A.Array e -> Int -> e -> A.Array e -update16 ary idx b = runST (update16M ary idx b) -{-# INLINE update16 #-} +-- | \(O(n)\) Update the element at the given position in this array. +update32 :: A.Array e -> Int -> e -> A.Array e +update32 ary idx b = runST (update32M ary idx b) +{-# INLINE update32 #-} --- | /O(n)/ Update the element at the given position in this array. -update16M :: A.Array e -> Int -> e -> ST s (A.Array e) -update16M ary idx b = do - mary <- clone16 ary +-- | \(O(n)\) Update the element at the given position in this array. +update32M :: A.Array e -> Int -> e -> ST s (A.Array e) +update32M ary idx b = do + mary <- clone ary A.write mary idx b A.unsafeFreeze mary -{-# INLINE update16M #-} +{-# INLINE update32M #-} --- | /O(n)/ Update the element at the given position in this array, by applying a function to it. -update16With' :: A.Array e -> Int -> (e -> e) -> A.Array e -update16With' ary idx f +-- | \(O(n)\) Update the element at the given position in this array, by applying a function to it. +update32With' :: A.Array e -> Int -> (e -> e) -> A.Array e +update32With' ary idx f | (# x #) <- A.index# ary idx - = update16 ary idx $! f x -{-# INLINE update16With' #-} + = update32 ary idx $! f x +{-# INLINE update32With' #-} --- | Unsafely clone an array of 16 elements. The length of the input +-- | Unsafely clone an array of (2^bitsPerSubkey) elements. The length of the input -- array is not checked. -clone16 :: A.Array e -> ST s (A.MArray s e) -clone16 ary = - A.thaw ary 0 16 +clone :: A.Array e -> ST s (A.MArray s e) +clone ary = + A.thaw ary 0 (2^bitsPerSubkey) ------------------------------------------------------------------------ -- Bit twiddling +-- TODO: Name this 'bitsPerLevel'?! What is a "subkey"? +-- https://github.com/haskell-unordered-containers/unordered-containers/issues/425 + +-- | Number of bits that are inspected at each level of the hash tree. +-- +-- This constant is named /t/ in the original /Ideal Hash Trees/ paper. bitsPerSubkey :: Int -bitsPerSubkey = 4 +bitsPerSubkey = 5 +-- | The size of a 'Full' node, i.e. @2 ^ 'bitsPerSubkey'@. maxChildren :: Int maxChildren = 1 `unsafeShiftL` bitsPerSubkey -subkeyMask :: Bitmap +-- | Bit mask with the lowest 'bitsPerSubkey' bits set, i.e. @0b11111@. +subkeyMask :: Word subkeyMask = 1 `unsafeShiftL` bitsPerSubkey - 1 -sparseIndex :: Bitmap -> Bitmap -> Int -sparseIndex b m = popCount (b .&. (m - 1)) +-- | Given a 'Hash' and a 'Shift' that indicates the level in the tree, compute +-- the index into a 'Full' node or into the bitmap of a `BitmapIndexed` node. +-- +-- >>> index 0b0010_0010 0 +-- 0b0000_0010 +index :: Hash -> Shift -> Int +index w s = fromIntegral $ unsafeShiftR w s .&. subkeyMask +{-# INLINE index #-} -mask :: Word -> Shift -> Bitmap +-- | Given a 'Hash' and a 'Shift' that indicates the level in the tree, compute +-- the bitmap that contains only the 'index' of the hash at this level. +-- +-- The result can be used for constructing one-element 'BitmapIndexed' nodes or +-- to check whether a 'BitmapIndexed' node may possibly contain the given 'Hash'. +-- +-- >>> mask 0b0010_0010 0 +-- 0b0100 +mask :: Hash -> Shift -> Bitmap mask w s = 1 `unsafeShiftL` index w s {-# INLINE mask #-} --- | Mask out the 'bitsPerSubkey' bits used for indexing at this level --- of the tree. -index :: Hash -> Shift -> Int -index w s = fromIntegral $ (unsafeShiftR w s) .&. subkeyMask -{-# INLINE index #-} +-- | This array index is computed by counting the number of bits below the +-- 'index' represented by the mask. +-- +-- >>> sparseIndex 0b0110_0110 0b0010_0000 +-- 2 +sparseIndex + :: Bitmap + -- ^ Bitmap of a 'BitmapIndexed' node + -> Bitmap + -- ^ One-bit 'mask' corresponding to the 'index' of a hash + -> Int + -- ^ Index into the array of the 'BitmapIndexed' node +sparseIndex b m = popCount (b .&. (m - 1)) +{-# INLINE sparseIndex #-} --- | A bitmask with the 'bitsPerSubkey' least significant bits set. +-- TODO: Should be named _(bit)map_ instead of _mask_ + +-- | A bitmap with the 'maxChildren' least significant bits set, i.e. +-- @0xFF_FF_FF_FF@. fullNodeMask :: Bitmap -fullNodeMask = complement (complement 0 `unsafeShiftL` maxChildren) +-- This needs to use 'shiftL' instead of 'unsafeShiftL', to avoid UB. +-- See issue #412. +fullNodeMask = complement (complement 0 `shiftL` maxChildren) {-# INLINE fullNodeMask #-} +------------------------------------------------------------------------ +-- Pointer equality + -- | Check if two the two arguments are the same value. N.B. This -- function might give false negatives (due to GC moving objects.) ptrEq :: a -> a -> Bool -ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y ==# 1#) +ptrEq x y = Exts.isTrue# (Exts.reallyUnsafePtrEquality# x y ==# 1#) {-# INLINE ptrEq #-} ------------------------------------------------------------------------ diff --git a/src/Data/Strict/HashMap/Autogen/Internal/Array.hs b/src/Data/Strict/HashMap/Autogen/Internal/Array.hs --- a/src/Data/Strict/HashMap/Autogen/Internal/Array.hs +++ b/src/Data/Strict/HashMap/Autogen/Internal/Array.hs @@ -1,4 +1,10 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} {-# OPTIONS_HADDOCK not-home #-} @@ -20,14 +26,15 @@ -- -- Note that no bounds checking are performed. module Data.Strict.HashMap.Autogen.Internal.Array - ( Array - , MArray + ( Array(..) + , MArray(..) -- * Creation , new , new_ , singleton , singletonM + , snoc , pair -- * Basic interface @@ -69,112 +76,34 @@ , traverse' , toList , fromList + , fromList' + , shrink ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative (..), (<$>)) -#endif import Control.Applicative (liftA2) -import Control.DeepSeq -import GHC.Exts(Int(..), Int#, reallyUnsafePtrEquality#, tagToEnum#, unsafeCoerce#, State#) -import GHC.ST (ST(..)) -import Control.Monad.ST (stToIO) - -#if __GLASGOW_HASKELL__ >= 709 -import Prelude hiding (filter, foldMap, foldr, foldl, length, map, read, traverse, all) -#else -import Prelude hiding (filter, foldr, foldl, length, map, read, all) -#endif - -#if __GLASGOW_HASKELL__ >= 710 -import GHC.Exts (SmallArray#, newSmallArray#, readSmallArray#, writeSmallArray#, - indexSmallArray#, unsafeFreezeSmallArray#, unsafeThawSmallArray#, - SmallMutableArray#, sizeofSmallArray#, copySmallArray#, thawSmallArray#, - sizeofSmallMutableArray#, copySmallMutableArray#, cloneSmallMutableArray#) - -#else -import GHC.Exts (Array#, newArray#, readArray#, writeArray#, - indexArray#, unsafeFreezeArray#, unsafeThawArray#, - MutableArray#, sizeofArray#, copyArray#, thawArray#, - sizeofMutableArray#, copyMutableArray#, cloneMutableArray#) -import Data.Monoid (Monoid (..)) -#endif +import Control.DeepSeq (NFData (..), NFData1 (..)) +import Control.Monad ((>=>)) +import Control.Monad.ST (runST, stToIO) +import GHC.Exts (Int (..), SmallArray#, SmallMutableArray#, + cloneSmallMutableArray#, copySmallArray#, + copySmallMutableArray#, indexSmallArray#, + newSmallArray#, readSmallArray#, + reallyUnsafePtrEquality#, sizeofSmallArray#, + sizeofSmallMutableArray#, tagToEnum#, + thawSmallArray#, unsafeCoerce#, + unsafeFreezeSmallArray#, unsafeThawSmallArray#, + writeSmallArray#) +import GHC.ST (ST (..)) +import Prelude hiding (all, filter, foldMap, foldl, foldr, length, + map, read, traverse) +import qualified GHC.Exts as Exts +import qualified Language.Haskell.TH.Syntax as TH #if defined(ASSERTS) import qualified Prelude #endif -import Data.Strict.HashMap.Autogen.Internal.Unsafe (runST) -import Control.Monad ((>=>)) - -#if __GLASGOW_HASKELL__ >= 710 -type Array# a = SmallArray# a -type MutableArray# a = SmallMutableArray# a - -newArray# :: Int# -> a -> State# d -> (# State# d, SmallMutableArray# d a #) -newArray# = newSmallArray# - -unsafeFreezeArray# :: SmallMutableArray# d a - -> State# d -> (# State# d, SmallArray# a #) -unsafeFreezeArray# = unsafeFreezeSmallArray# - -readArray# :: SmallMutableArray# d a - -> Int# -> State# d -> (# State# d, a #) -readArray# = readSmallArray# - -writeArray# :: SmallMutableArray# d a - -> Int# -> a -> State# d -> State# d -writeArray# = writeSmallArray# - -indexArray# :: SmallArray# a -> Int# -> (# a #) -indexArray# = indexSmallArray# - -unsafeThawArray# :: SmallArray# a - -> State# d -> (# State# d, SmallMutableArray# d a #) -unsafeThawArray# = unsafeThawSmallArray# - -sizeofArray# :: SmallArray# a -> Int# -sizeofArray# = sizeofSmallArray# - -copyArray# :: SmallArray# a - -> Int# - -> SmallMutableArray# d a - -> Int# - -> Int# - -> State# d - -> State# d -copyArray# = copySmallArray# - -cloneMutableArray# :: SmallMutableArray# s a - -> Int# - -> Int# - -> State# s - -> (# State# s, SmallMutableArray# s a #) -cloneMutableArray# = cloneSmallMutableArray# - -thawArray# :: SmallArray# a - -> Int# - -> Int# - -> State# d - -> (# State# d, SmallMutableArray# d a #) -thawArray# = thawSmallArray# - -sizeofMutableArray# :: SmallMutableArray# s a -> Int# -sizeofMutableArray# = sizeofSmallMutableArray# - -copyMutableArray# :: SmallMutableArray# d a - -> Int# - -> SmallMutableArray# d a - -> Int# - -> Int# - -> State# d - -> State# d -copyMutableArray# = copySmallMutableArray# -#endif - ------------------------------------------------------------------------- - #if defined(ASSERTS) -- This fugly hack is brought by GHC's apparent reluctance to deal -- with MagicHash and UnboxedTuples when inferring types. Eek! @@ -194,7 +123,7 @@ #endif data Array a = Array { - unArray :: !(Array# a) + unArray :: !(SmallArray# a) } instance Show a => Show (Array a) where @@ -222,15 +151,15 @@ !lenys = length ys0 length :: Array a -> Int -length ary = I# (sizeofArray# (unArray ary)) +length ary = I# (sizeofSmallArray# (unArray ary)) {-# INLINE length #-} data MArray s a = MArray { - unMArray :: !(MutableArray# s a) + unMArray :: !(SmallMutableArray# s a) } lengthM :: MArray s a -> Int -lengthM mary = I# (sizeofMutableArray# (unMArray mary)) +lengthM mary = I# (sizeofSmallMutableArray# (unMArray mary)) {-# INLINE lengthM #-} ------------------------------------------------------------------------ @@ -250,6 +179,20 @@ -- relevant rnf is strict, or in case it actually isn't. {-# INLINE rnfArray #-} +-- | @since 0.2.14.0 +instance NFData1 Array where + liftRnf = liftRnfArray + +liftRnfArray :: (a -> ()) -> Array a -> () +liftRnfArray rnf0 ary0 = go ary0 n0 0 + where + n0 = length ary0 + go !ary !n !i + | i >= n = () + | (# x #) <- index# ary i + = rnf0 x `seq` go ary n (i+1) +{-# INLINE liftRnfArray #-} + -- | Create a new mutable array of specified size, in the specified -- state thread, with each element containing the specified initial -- value. @@ -258,16 +201,30 @@ {-# INLINE new #-} new' :: Int -> a -> ST s (MArray s a) -new' (I# n#) b = - CHECK_GT("new",n,(0 :: Int)) +new' _n@(I# n#) b = + CHECK_GT("new",_n,(0 :: Int)) ST $ \s -> - case newArray# n# b s of + case newSmallArray# n# b s of (# s', ary #) -> (# s', MArray ary #) {-# INLINE new' #-} new_ :: Int -> ST s (MArray s a) new_ n = new' n undefinedElem +-- | When 'Exts.shrinkSmallMutableArray#' is available, the returned array is the same as the array given, as it is shrunk in place. +-- Otherwise a copy is made. +shrink :: MArray s a -> Int -> ST s (MArray s a) +#if __GLASGOW_HASKELL__ >= 810 +shrink mary _n@(I# n#) = + CHECK_GT("shrink", _n, (0 :: Int)) + CHECK_LE("shrink", _n, (lengthM mary)) + ST $ \s -> case Exts.shrinkSmallMutableArray# (unMArray mary) n# s of + s' -> (# s', mary #) +#else +shrink mary n = cloneM mary 0 n +#endif +{-# INLINE shrink #-} + singleton :: a -> Array a singleton !x = runST (singletonM x) {-# INLINE singleton #-} @@ -276,6 +233,15 @@ singletonM !x = new 1 x >>= unsafeFreeze {-# INLINE singletonM #-} +snoc :: Array a -> a -> Array a +snoc ary x = run $ do + mary <- new (n + 1) x + copy ary 0 mary 0 n + pure mary + where + n = length ary +{-# INLINE snoc #-} + pair :: a -> a -> Array a pair !x !y = run $ do ary <- new 2 x @@ -286,43 +252,43 @@ read :: MArray s a -> Int -> ST s a read ary _i@(I# i#) = ST $ \ s -> CHECK_BOUNDS("read", lengthM ary, _i) - readArray# (unMArray ary) i# s + readSmallArray# (unMArray ary) i# s {-# INLINE read #-} write :: MArray s a -> Int -> a -> ST s () write ary _i@(I# i#) !b = ST $ \ s -> CHECK_BOUNDS("write", lengthM ary, _i) - case writeArray# (unMArray ary) i# b s of + case writeSmallArray# (unMArray ary) i# b s of s' -> (# s' , () #) {-# INLINE write #-} index :: Array a -> Int -> a index ary _i@(I# i#) = CHECK_BOUNDS("index", length ary, _i) - case indexArray# (unArray ary) i# of (# b #) -> b + case indexSmallArray# (unArray ary) i# of (# b #) -> b {-# INLINE index #-} index# :: Array a -> Int -> (# a #) index# ary _i@(I# i#) = CHECK_BOUNDS("index#", length ary, _i) - indexArray# (unArray ary) i# + indexSmallArray# (unArray ary) i# {-# INLINE index# #-} indexM :: Array a -> Int -> ST s a indexM ary _i@(I# i#) = CHECK_BOUNDS("indexM", length ary, _i) - case indexArray# (unArray ary) i# of (# b #) -> return b + case indexSmallArray# (unArray ary) i# of (# b #) -> return b {-# INLINE indexM #-} unsafeFreeze :: MArray s a -> ST s (Array a) unsafeFreeze mary - = ST $ \s -> case unsafeFreezeArray# (unMArray mary) s of + = ST $ \s -> case unsafeFreezeSmallArray# (unMArray mary) s of (# s', ary #) -> (# s', Array ary #) {-# INLINE unsafeFreeze #-} unsafeThaw :: Array a -> ST s (MArray s a) unsafeThaw ary - = ST $ \s -> case unsafeThawArray# (unArray ary) s of + = ST $ \s -> case unsafeThawSmallArray# (unArray ary) s of (# s', mary #) -> (# s', MArray mary #) {-# INLINE unsafeThaw #-} @@ -336,7 +302,7 @@ CHECK_LE("copy", _sidx + _n, length src) CHECK_LE("copy", _didx + _n, lengthM dst) ST $ \ s# -> - case copyArray# (unArray src) sidx# (unMArray dst) didx# n# s# of + case copySmallArray# (unArray src) sidx# (unMArray dst) didx# n# s# of s2 -> (# s2, () #) -- | Unsafely copy the elements of an array. Array bounds are not checked. @@ -345,15 +311,15 @@ CHECK_BOUNDS("copyM: src", lengthM src, _sidx + _n - 1) CHECK_BOUNDS("copyM: dst", lengthM dst, _didx + _n - 1) ST $ \ s# -> - case copyMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of + case copySmallMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of s2 -> (# s2, () #) cloneM :: MArray s a -> Int -> Int -> ST s (MArray s a) cloneM _mary@(MArray mary#) _off@(I# off#) _len@(I# len#) = - CHECK_BOUNDS("cloneM_off", lengthM _mary, _off - 1) + CHECK_BOUNDS("cloneM_off", lengthM _mary, _off) CHECK_BOUNDS("cloneM_end", lengthM _mary, _off + _len - 1) ST $ \ s -> - case cloneMutableArray# mary# off# len# s of + case cloneSmallMutableArray# mary# off# len# s of (# s', mary'# #) -> (# s', MArray mary'# #) -- | Create a new array of the @n@ first elements of @mary@. @@ -361,31 +327,30 @@ trim mary n = cloneM mary 0 n >>= unsafeFreeze {-# INLINE trim #-} --- | /O(n)/ Insert an element at the given position in this array, +-- | \(O(n)\) Insert an element at the given position in this array, -- increasing its size by one. insert :: Array e -> Int -> e -> Array e insert ary idx b = runST (insertM ary idx b) {-# INLINE insert #-} --- | /O(n)/ Insert an element at the given position in this array, +-- | \(O(n)\) Insert an element at the given position in this array, -- increasing its size by one. insertM :: Array e -> Int -> e -> ST s (Array e) insertM ary idx b = CHECK_BOUNDS("insertM", count + 1, idx) - do mary <- new_ (count+1) + do mary <- new (count+1) b copy ary 0 mary 0 idx - write mary idx b copy ary idx mary (idx+1) (count-idx) unsafeFreeze mary where !count = length ary {-# INLINE insertM #-} --- | /O(n)/ Update the element at the given position in this array. +-- | \(O(n)\) Update the element at the given position in this array. update :: Array e -> Int -> e -> Array e update ary idx b = runST (updateM ary idx b) {-# INLINE update #-} --- | /O(n)/ Update the element at the given position in this array. +-- | \(O(n)\) Update the element at the given position in this array. updateM :: Array e -> Int -> e -> ST s (Array e) updateM ary idx b = CHECK_BOUNDS("updateM", count, idx) @@ -395,7 +360,7 @@ where !count = length ary {-# INLINE updateM #-} --- | /O(n)/ Update the element at the given positio in this array, by +-- | \(O(n)\) Update the element at the given positio in this array, by -- applying a function to it. Evaluates the element to WHNF before -- inserting it into the array. updateWith' :: Array e -> Int -> (e -> e) -> Array e @@ -404,7 +369,7 @@ = update ary idx $! f x {-# INLINE updateWith' #-} --- | /O(1)/ Update the element at the given position in this array, +-- | \(O(1)\) Update the element at the given position in this array, -- without copying. unsafeUpdateM :: Array e -> Int -> e -> ST s () unsafeUpdateM ary idx b = @@ -477,19 +442,19 @@ {-# NOINLINE undefinedElem #-} thaw :: Array e -> Int -> Int -> ST s (MArray s e) -thaw !ary !_o@(I# o#) (I# n#) = - CHECK_LE("thaw", _o + n, length ary) - ST $ \ s -> case thawArray# (unArray ary) o# n# s of +thaw !ary !_o@(I# o#) _n@(I# n#) = + CHECK_LE("thaw", _o + _n, length ary) + ST $ \ s -> case thawSmallArray# (unArray ary) o# n# s of (# s2, mary# #) -> (# s2, MArray mary# #) {-# INLINE thaw #-} --- | /O(n)/ Delete an element at the given position in this array, +-- | \(O(n)\) Delete an element at the given position in this array, -- decreasing its size by one. delete :: Array e -> Int -> Array e delete ary idx = runST (deleteM ary idx) {-# INLINE delete #-} --- | /O(n)/ Delete an element at the given position in this array, +-- | \(O(n)\) Delete an element at the given position in this array, -- decreasing its size by one. deleteM :: Array e -> Int -> ST s (Array e) deleteM ary idx = do @@ -507,9 +472,10 @@ in run $ do mary <- new_ n go ary mary 0 n + return mary where go ary mary i n - | i >= n = return mary + | i >= n = return () | otherwise = do x <- indexM ary i write mary i $ f x @@ -523,9 +489,10 @@ in run $ do mary <- new_ n go ary mary 0 n + return mary where go ary mary i n - | i >= n = return mary + | i >= n = return () | otherwise = do x <- indexM ary i write mary i $! f x @@ -538,15 +505,39 @@ run $ do mary <- new_ n go xs0 mary 0 + return mary where - go [] !mary !_ = return mary - go (x:xs) mary i = do write mary i x - go xs mary (i+1) + go [] !_ !_ = return () + go (x:xs) mary i = do write mary i x + go xs mary (i+1) +fromList' :: Int -> [a] -> Array a +fromList' n xs0 = + CHECK_EQ("fromList'", n, Prelude.length xs0) + run $ do + mary <- new_ n + go xs0 mary 0 + return mary + where + go [] !_ !_ = return () + go (!x:xs) mary i = do write mary i x + go xs mary (i+1) + +-- | @since 0.2.17.0 +instance TH.Lift a => TH.Lift (Array a) where +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped ar = [|| fromList' arlen arlist ||] +#else + lift ar = [| fromList' arlen arlist |] +#endif + where + arlen = length ar + arlist = toList ar + toList :: Array a -> [a] toList = foldr (:) [] -newtype STA a = STA {_runSTA :: forall s. MutableArray# s a -> ST s (Array a)} +newtype STA a = STA {_runSTA :: forall s. SmallMutableArray# s a -> ST s (Array a)} runSTA :: Int -> STA a -> Array a runSTA !n (STA m) = runST $ new_ n >>= \ (MArray ar) -> m ar diff --git a/src/Data/Strict/HashMap/Autogen/Internal/List.hs b/src/Data/Strict/HashMap/Autogen/Internal/List.hs --- a/src/Data/Strict/HashMap/Autogen/Internal/List.hs +++ b/src/Data/Strict/HashMap/Autogen/Internal/List.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} {-# OPTIONS_HADDOCK not-home #-} @@ -25,10 +26,11 @@ , unorderedCompare ) where +import Data.List (sortBy) import Data.Maybe (fromMaybe) -import Data.List (sortBy) -import Data.Monoid -import Prelude +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup ((<>)) +#endif -- Note: previous implemenation isPermutation = null (as // bs) -- was O(n^2) too. @@ -68,7 +70,7 @@ go [] [] = EQ go [] (_ : _) = LT go (_ : _) [] = GT - go (x : xs) (y : ys) = c x y `mappend` go xs ys + go (x : xs) (y : ys) = c x y <> go xs ys cmpA a a' = compare (inB a) (inB a') cmpB b b' = compare (inA b) (inA b') diff --git a/src/Data/Strict/HashMap/Autogen/Internal/Strict.hs b/src/Data/Strict/HashMap/Autogen/Internal/Strict.hs --- a/src/Data/Strict/HashMap/Autogen/Internal/Strict.hs +++ b/src/Data/Strict/HashMap/Autogen/Internal/Strict.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE BangPatterns, CPP, PatternGuards, MagicHash, UnboxedTuples #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-} ------------------------------------------------------------------------ @@ -34,8 +38,8 @@ -- especially when key comparison is expensive, as in the case of -- strings. -- --- Many operations have a average-case complexity of /O(log n)/. The --- implementation uses a large base (i.e. 16) so in practice these +-- Many operations have a average-case complexity of \(O(\log n)\). The +-- implementation uses a large base (i.e. 32) so in practice these -- operations are constant time. module Data.Strict.HashMap.Autogen.Internal.Strict ( @@ -45,102 +49,110 @@ HashMap -- * Construction - , empty + , HM.empty , singleton -- * Basic interface , HM.null - , size + , HM.size , HM.member , HM.lookup , (HM.!?) , HM.findWithDefault - , lookupDefault - , (!) + , HM.lookupDefault + , (HM.!) , insert , insertWith - , delete + , HM.delete , adjust , update , alter , alterF - , isSubmapOf - , isSubmapOfBy + , HM.isSubmapOf + , HM.isSubmapOfBy -- * Combine -- ** Union - , union + , HM.union , unionWith , unionWithKey - , unions + , HM.unions -- ** Compose - , compose + , HM.compose -- * Transformations , map , mapWithKey , traverseWithKey + , HM.mapKeys -- * Difference and intersection - , difference + , HM.difference , differenceWith - , intersection + , HM.intersection , intersectionWith , intersectionWithKey -- * Folds - , foldMapWithKey - , foldr' - , foldl' - , foldrWithKey' - , foldlWithKey' + , HM.foldMapWithKey + , HM.foldr' + , HM.foldl' + , HM.foldrWithKey' + , HM.foldlWithKey' , HM.foldr , HM.foldl - , foldrWithKey - , foldlWithKey + , HM.foldrWithKey + , HM.foldlWithKey -- * Filter , HM.filter - , filterWithKey + , HM.filterWithKey , mapMaybe , mapMaybeWithKey -- * Conversions - , keys - , elems + , HM.keys + , HM.elems -- ** Lists - , toList + , HM.toList , fromList , fromListWith , fromListWithKey ) where -import Data.Bits ((.&.), (.|.)) - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative (..), (<$>)) -#endif -import qualified Data.List as L -import Data.Hashable (Hashable) -import Prelude hiding (map, lookup) +import Control.Applicative (Const (..)) +import Control.Monad.ST (runST) +import Data.Bits ((.&.), (.|.)) +import Data.Coerce (coerce) +import Data.Functor.Identity (Identity (..)) +-- See Note [Imports from Data.Strict.HashMap.Autogen.Internal] +import Data.Hashable (Hashable) +import Data.Strict.HashMap.Autogen.Internal (Hash, HashMap (..), Leaf (..), LookupRes (..), + bitsPerSubkey, fullNodeMask, hash, index, mask, + ptrEq, sparseIndex) +import Prelude hiding (lookup, map) +-- See Note [Imports from Data.Strict.HashMap.Autogen.Internal] +import qualified Data.Strict.HashMap.Autogen.Internal as HM import qualified Data.Strict.HashMap.Autogen.Internal.Array as A -import qualified Data.Strict.HashMap.Autogen.Internal as HM -import Data.Strict.HashMap.Autogen.Internal hiding ( - alter, alterF, adjust, fromList, fromListWith, fromListWithKey, - insert, insertWith, - differenceWith, intersectionWith, intersectionWithKey, map, mapWithKey, - mapMaybe, mapMaybeWithKey, singleton, update, unionWith, unionWithKey, - traverseWithKey) -import Data.Strict.HashMap.Autogen.Internal.Unsafe (runST) -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity -#endif -import Control.Applicative (Const (..)) -import Data.Coerce +import qualified Data.List as List +import qualified GHC.Exts as Exts +{- +Note [Imports from Data.Strict.HashMap.Autogen.Internal] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is very important for code in this module not to make mistakes about +the strictness properties of any utilities. Mistakes can easily lead to space +leaks, see e.g. #383. + +Therefore nearly all functions imported from Data.Strict.HashMap.Autogen.Internal should be +imported qualified. Only functions that do not manipulate HashMaps or their +values are exempted. +-} + -- $strictness -- -- This module satisfies the following strictness properties: @@ -153,21 +165,21 @@ ------------------------------------------------------------------------ -- * Construction --- | /O(1)/ Construct a map with a single element. +-- | \(O(1)\) Construct a map with a single element. singleton :: (Hashable k) => k -> v -> HashMap k v singleton k !v = HM.singleton k v ------------------------------------------------------------------------ -- * Basic interface --- | /O(log n)/ Associate the specified value with the specified +-- | \(O(\log n)\) Associate the specified value with the specified -- key in this map. If this map previously contained a mapping for -- the key, the old value is replaced. insert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v insert k !v = HM.insert k v {-# INLINABLE insert #-} --- | /O(log n)/ Associate the value with the key in this map. If +-- | \(O(\log n)\) Associate the value with the key in this map. If -- this map previously contained a mapping for the key, the old value -- is replaced by the result of applying the given function to the new -- and old value. Example: @@ -183,12 +195,12 @@ go h k x s t@(Leaf hy l@(L ky y)) | hy == h = if ky == k then leaf h k (f x y) - else x `seq` (collision h l (L k x)) - | otherwise = x `seq` runST (two s h k x hy t) + else x `seq` HM.collision h l (L k x) + | otherwise = x `seq` runST (HM.two s h k x hy t) go h k x s (BitmapIndexed b ary) | b .&. m == 0 = let ary' = A.insert ary i $! leaf h k x - in bitmapIndexedOrFull (b .|. m) ary' + in HM.bitmapIndexedOrFull (b .|. m) ary' | otherwise = let st = A.index ary i st' = go h k x (s+bitsPerSubkey) st @@ -199,7 +211,7 @@ go h k x s (Full ary) = let st = A.index ary i st' = go h k x (s+bitsPerSubkey) st - ary' = update16 ary i $! st' + ary' = HM.update32 ary i $! st' in Full ary' where i = index h s go h k x s t@(Collision hy v) @@ -223,13 +235,13 @@ | hy == h = if ky == k then return $! leaf h k (f k x y) else do - let l' = x `seq` (L k x) - return $! collision h l l' - | otherwise = x `seq` two s h k x hy t + let l' = x `seq` L k x + return $! HM.collision h l l' + | otherwise = x `seq` HM.two s h k x hy t go h k x s t@(BitmapIndexed b ary) | b .&. m == 0 = do ary' <- A.insertM ary i $! leaf h k x - return $! bitmapIndexedOrFull (b .|. m) ary' + return $! HM.bitmapIndexedOrFull (b .|. m) ary' | otherwise = do st <- A.indexM ary i st' <- go h k x (s+bitsPerSubkey) st @@ -248,7 +260,7 @@ | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) {-# INLINABLE unsafeInsertWithKey #-} --- | /O(log n)/ Adjust the value tied to a given key in this map only +-- | \(O(\log n)\) Adjust the value tied to a given key in this map only -- if it is present. Otherwise, leave the map alone. adjust :: (Eq k, Hashable k) => (v -> v) -> k -> HashMap k v -> HashMap k v adjust f k0 m0 = go h0 k0 0 m0 @@ -270,21 +282,21 @@ let i = index h s st = A.index ary i st' = go h k (s+bitsPerSubkey) st - ary' = update16 ary i $! st' + ary' = HM.update32 ary i $! st' in Full ary' go h k _ t@(Collision hy v) | h == hy = Collision h (updateWith f k v) | otherwise = t {-# INLINABLE adjust #-} --- | /O(log n)/ The expression @('update' f k map)@ updates the value @x@ at @k@ +-- | \(O(\log n)\) The expression @('update' f k map)@ updates the value @x@ at @k@ -- (if it is in the map). If @(f x)@ is 'Nothing', the element is deleted. -- If it is @('Just' y)@, the key @k@ is bound to the new value @y@. update :: (Eq k, Hashable k) => (a -> Maybe a) -> k -> HashMap k a -> HashMap k a update f = alter (>>= f) {-# INLINABLE update #-} --- | /O(log n)/ The expression @('alter' f k map)@ alters the value @x@ at @k@, or +-- | \(O(\log n)\) The expression @('alter' f k map)@ alters the value @x@ at @k@, or -- absence thereof. -- -- 'alter' can be used to insert, delete, or update a value in a map. In short: @@ -295,11 +307,11 @@ alter :: (Eq k, Hashable k) => (Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v alter f k m = case f (HM.lookup k m) of - Nothing -> delete k m + Nothing -> HM.delete k m Just v -> insert k v m {-# INLINABLE alter #-} --- | /O(log n)/ The expression (@'alterF' f k map@) alters the value @x@ at +-- | \(O(\log n)\) The expression (@'alterF' f k map@) alters the value @x@ at -- @k@, or absence thereof. -- -- 'alterF' can be used to insert, delete, or update a value in a map. @@ -317,18 +329,16 @@ -- @f@ and a functor that is similar to Const but not actually Const. alterF f = \ !k !m -> let !h = hash k - mv = lookup' h k m - in (<$> f mv) $ \fres -> - case fres of - Nothing -> maybe m (const (delete' h k m)) mv - Just !v' -> insert' h k v' m + mv = HM.lookup' h k m + in (<$> f mv) $ \case + Nothing -> maybe m (const (HM.delete' h k m)) mv + Just !v' -> HM.insert' h k v' m -- We rewrite this function unconditionally in RULES, but we expose -- an unfolding just in case it's used in a context where the rules -- don't fire. {-# INLINABLE [0] alterF #-} -#if MIN_VERSION_base(4,8,0) -- See notes in Data.Strict.HashMap.Autogen.Internal test_bottom :: a test_bottom = error "Data.Strict.HashMap.Autogen.alterF internal error: hit test_bottom" @@ -348,13 +358,13 @@ "alterFconstant" forall (f :: Maybe a -> Identity (Maybe a)) x. alterFWeird x x f = \ !k !m -> - Identity (case runIdentity x of {Nothing -> delete k m; Just a -> insert k a m}) + Identity (case runIdentity x of {Nothing -> HM.delete k m; Just a -> insert k a m}) "alterFinsertWith" [1] forall (f :: Maybe a -> Identity (Maybe a)) x y. alterFWeird (coerce (Just x)) (coerce (Just y)) f = - coerce (insertModifying x (\mold -> case runIdentity (f (Just mold)) of - Nothing -> bogus# (# #) - Just !new -> (# new #))) + coerce (HM.insertModifying x (\mold -> case runIdentity (f (Just mold)) of + Nothing -> bogus# (# #) + Just !new -> (# new #))) -- This rule is written a bit differently than the one for lazy -- maps because the adjust here is strict. We could write it the @@ -366,7 +376,7 @@ Nothing -> impossibleAdjust)) "alterFlookup" forall _ign1 _ign2 (f :: Maybe a -> Const r (Maybe a)) . - alterFWeird _ign1 _ign2 f = \ !k !m -> Const (getConst (f (lookup k m))) + alterFWeird _ign1 _ign2 f = \ !k !m -> Const (getConst (f (HM.lookup k m))) #-} -- This is a very unsafe version of alterF used for RULES. When calling @@ -400,42 +410,41 @@ Absent -> m -- Key did exist, no collision - Present _ collPos -> deleteKeyExists collPos h k m + Present _ collPos -> HM.deleteKeyExists collPos h k m ------------------------------ -- Update value - Just v' -> case lookupRes of + Just !v' -> case lookupRes of -- Key did not exist before, insert v' under a new key - Absent -> insertNewKey h k v' m + Absent -> HM.insertNewKey h k v' m -- Key existed before, no hash collision - Present v collPos -> v' `seq` + Present v collPos -> if v `ptrEq` v' -- If the value is identical, no-op then m -- If the value changed, update the value. - else insertKeyExists collPos h k v' m + else HM.insertKeyExists collPos h k v' m where !h = hash k - !lookupRes = lookupRecordCollision h k m + !lookupRes = HM.lookupRecordCollision h k m !mv = case lookupRes of Absent -> Nothing Present v _ -> Just v {-# INLINABLE alterFEager #-} -#endif ------------------------------------------------------------------------ -- * Combine --- | /O(n+m)/ The union of two maps. If a key occurs in both maps, +-- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the result. unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWith f = unionWithKey (const f) {-# INLINE unionWith #-} --- | /O(n+m)/ The union of two maps. If a key occurs in both maps, +-- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the result. unionWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v @@ -448,7 +457,7 @@ go s t1@(Leaf h1 l1@(L k1 v1)) t2@(Leaf h2 l2@(L k2 v2)) | h1 == h2 = if k1 == k2 then leaf h1 k1 (f k1 v1 v2) - else collision h1 l1 l2 + else HM.collision h1 l1 l2 | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Leaf h1 (L k1 v1)) t2@(Collision h2 ls2) | h1 == h2 = Collision h1 (updateOrSnocWithKey f k1 v1 ls2) @@ -457,28 +466,28 @@ | h1 == h2 = Collision h1 (updateOrSnocWithKey (flip . f) k2 v2 ls1) | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Collision h1 ls1) t2@(Collision h2 ls2) - | h1 == h2 = Collision h1 (updateOrConcatWithKey f ls1 ls2) + | h1 == h2 = Collision h1 (HM.updateOrConcatWithKey (\k a b -> let !v = f k a b in (# v #)) ls1 ls2) | otherwise = goDifferentHash s h1 h2 t1 t2 -- branch vs. branch go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) = let b' = b1 .|. b2 - ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2 - in bitmapIndexedOrFull b' ary' + ary' = HM.unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2 + in HM.bitmapIndexedOrFull b' ary' go s (BitmapIndexed b1 ary1) (Full ary2) = - let ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2 + let ary' = HM.unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2 in Full ary' go s (Full ary1) (BitmapIndexed b2 ary2) = - let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2 + let ary' = HM.unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2 in Full ary' go s (Full ary1) (Full ary2) = - let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask + let ary' = HM.unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask ary1 ary2 in Full ary' -- leaf vs. branch go s (BitmapIndexed b1 ary1) t2 | b1 .&. m2 == 0 = let ary' = A.insert ary1 i t2 b' = b1 .|. m2 - in bitmapIndexedOrFull b' ary' + in HM.bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 in BitmapIndexed b1 ary' @@ -489,7 +498,7 @@ go s t1 (BitmapIndexed b2 ary2) | b2 .&. m1 == 0 = let ary' = A.insert ary2 i $! t1 b' = b2 .|. m1 - in bitmapIndexedOrFull b' ary' + in HM.bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 in BitmapIndexed b2 ary' @@ -500,12 +509,12 @@ go s (Full ary1) t2 = let h2 = leafHashCode t2 i = index h2 s - ary' = update16With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 + ary' = HM.update32With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 in Full ary' go s t1 (Full ary2) = let h1 = leafHashCode t1 i = index h1 s - ary' = update16With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 + ary' = HM.update32With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 in Full ary' leafHashCode (Leaf h _) = h @@ -513,7 +522,7 @@ leafHashCode _ = error "leafHashCode" goDifferentHash s h1 h2 t1 t2 - | m1 == m2 = BitmapIndexed m1 (A.singleton $! go (s+bitsPerSubkey) t1 t2) + | m1 == m2 = BitmapIndexed m1 (A.singleton $! goDifferentHash (s+bitsPerSubkey) h1 h2 t1 t2) | m1 < m2 = BitmapIndexed (m1 .|. m2) (A.pair t1 t2) | otherwise = BitmapIndexed (m1 .|. m2) (A.pair t2 t1) where @@ -524,7 +533,7 @@ ------------------------------------------------------------------------ -- * Transformations --- | /O(n)/ Transform this map by applying a function to every value. +-- | \(O(n)\) Transform this map by applying a function to every value. mapWithKey :: (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2 mapWithKey f = go where @@ -536,7 +545,7 @@ Collision h $ A.map' (\ (L k v) -> let !v' = f k v in L k v') ary {-# INLINE mapWithKey #-} --- | /O(n)/ Transform this map by applying a function to every value. +-- | \(O(n)\) Transform this map by applying a function to every value. map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2 map f = mapWithKey (const f) {-# INLINE map #-} @@ -545,24 +554,24 @@ ------------------------------------------------------------------------ -- * Filter --- | /O(n)/ Transform this map by applying a function to every value +-- | \(O(n)\) Transform this map by applying a function to every value -- and retaining only some of them. mapMaybeWithKey :: (k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 -mapMaybeWithKey f = filterMapAux onLeaf onColl +mapMaybeWithKey f = HM.filterMapAux onLeaf onColl where onLeaf (Leaf h (L k v)) | Just v' <- f k v = Just (leaf h k v') onLeaf _ = Nothing - onColl (L k v) | Just v' <- f k v = Just (L k v') + onColl (L k v) | Just !v' <- f k v = Just (L k v') | otherwise = Nothing {-# INLINE mapMaybeWithKey #-} --- | /O(n)/ Transform this map by applying a function to every value +-- | \(O(n)\) Transform this map by applying a function to every value -- and retaining only some of them. mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 mapMaybe f = mapMaybeWithKey (const f) {-# INLINE mapMaybe #-} --- | /O(n)/ Perform an 'Applicative' action for each key-value pair +-- | \(O(n)\) Perform an 'Applicative' action for each key-value pair -- in a 'HashMap' and produce a 'HashMap' of all the results. Each 'HashMap' -- will be strict in all its values. -- @@ -591,53 +600,45 @@ ------------------------------------------------------------------------ -- * Difference and intersection --- | /O(n*log m)/ Difference with a combining function. When two equal keys are +-- | \(O(n \log m)\) Difference with a combining function. When two equal keys are -- encountered, the combining function is applied to the values of these keys. -- If it returns 'Nothing', the element is discarded (proper set difference). If -- it returns (@'Just' y@), the element is updated with a new value @y@. differenceWith :: (Eq k, Hashable k) => (v -> w -> Maybe v) -> HashMap k v -> HashMap k w -> HashMap k v -differenceWith f a b = foldlWithKey' go empty a +differenceWith f a b = HM.foldlWithKey' go HM.empty a where go m k v = case HM.lookup k b of - Nothing -> insert k v m - Just w -> maybe m (\y -> insert k y m) (f v w) + Nothing -> v `seq` HM.unsafeInsert k v m + Just w -> maybe m (\ !y -> HM.unsafeInsert k y m) (f v w) {-# INLINABLE differenceWith #-} --- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps +-- | \(O(n+m)\) Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps. intersectionWith :: (Eq k, Hashable k) => (v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 -intersectionWith f a b = foldlWithKey' go empty a - where - go m k v = case HM.lookup k b of - Just w -> insert k (f v w) m - _ -> m +intersectionWith f = Exts.inline intersectionWithKey $ const f {-# INLINABLE intersectionWith #-} --- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps +-- | \(O(n+m)\) Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps. intersectionWithKey :: (Eq k, Hashable k) => (k -> v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 -intersectionWithKey f a b = foldlWithKey' go empty a - where - go m k v = case HM.lookup k b of - Just w -> insert k (f k v w) m - _ -> m +intersectionWithKey f = HM.intersectionWithKey# $ \k v1 v2 -> let !v3 = f k v1 v2 in (# v3 #) {-# INLINABLE intersectionWithKey #-} ------------------------------------------------------------------------ -- ** Lists --- | /O(n*log n)/ Construct a map with the supplied mappings. If the +-- | \(O(n \log n)\) Construct a map with the supplied mappings. If the -- list contains duplicate mappings, the later mappings take -- precedence. fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v -fromList = L.foldl' (\ m (k, !v) -> HM.unsafeInsert k v m) empty +fromList = List.foldl' (\ m (k, !v) -> HM.unsafeInsert k v m) HM.empty {-# INLINABLE fromList #-} --- | /O(n*log n)/ Construct a map from a list of elements. Uses +-- | \(O(n \log n)\) Construct a map from a list of elements. Uses -- the provided function @f@ to merge duplicate entries with -- @(f newVal oldVal)@. -- @@ -668,10 +669,10 @@ -- > fromListWith f [(k, a), (k, b), (k, c), (k, d)] -- > = fromList [(k, f d (f c (f b a)))] fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v -fromListWith f = L.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty +fromListWith f = List.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) HM.empty {-# INLINE fromListWith #-} --- | /O(n*log n)/ Construct a map from a list of elements. Uses +-- | \(O(n \log n)\) Construct a map from a list of elements. Uses -- the provided function to merge duplicate entries. -- -- === Examples @@ -698,7 +699,7 @@ -- -- @since 0.2.11 fromListWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> [(k, v)] -> HashMap k v -fromListWithKey f = L.foldl' (\ m (k, v) -> unsafeInsertWithKey f k v m) empty +fromListWithKey f = List.foldl' (\ m (k, v) -> unsafeInsertWithKey f k v m) HM.empty {-# INLINE fromListWithKey #-} ------------------------------------------------------------------------ @@ -734,13 +735,8 @@ updateOrSnocWithKey f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0) where go !k v !ary !i !n - | i >= n = A.run $ do - -- Not found, append to the end. - mary <- A.new_ (n + 1) - A.copy ary 0 mary 0 n - let !l = v `seq` (L k v) - A.write mary n l - return mary + -- Not found, append to the end. + | i >= n = A.snoc ary $! L k $! v | otherwise = case A.index ary i of (L kx y) | k == kx -> let !v' = f k v y in A.update ary i (L k v') | otherwise -> go k v ary (i+1) n diff --git a/src/Data/Strict/HashMap/Autogen/Internal/Unsafe.hs b/src/Data/Strict/HashMap/Autogen/Internal/Unsafe.hs deleted file mode 100644 --- a/src/Data/Strict/HashMap/Autogen/Internal/Unsafe.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE CPP #-} - -#if !MIN_VERSION_base(4,9,0) -{-# LANGUAGE MagicHash, Rank2Types, UnboxedTuples #-} -#endif - -{-# OPTIONS_HADDOCK not-home #-} - --- | = WARNING --- --- This module is considered __internal__. --- --- The Package Versioning Policy __does not apply__. --- --- The contents of this module may change __in any way whatsoever__ --- and __without any warning__ between minor versions of this package. --- --- Authors importing this module are expected to track development --- closely. --- --- = Description --- --- This module exports a workaround for this bug: --- --- http://hackage.haskell.org/trac/ghc/ticket/5916 --- --- Please read the comments in ghc/libraries/base/GHC/ST.lhs to --- understand what's going on here. --- --- Code that uses this module should be compiled with -fno-full-laziness -module Data.Strict.HashMap.Autogen.Internal.Unsafe - ( runST - ) where - -#if MIN_VERSION_base(4,9,0) --- The GHC issue was fixed in GHC 8.0/base 4.9 -import Control.Monad.ST - -#else - -import GHC.Base (realWorld#) -import qualified GHC.ST as ST - --- | Return the value computed by a state transformer computation. --- The @forall@ ensures that the internal state used by the 'ST' --- computation is inaccessible to the rest of the program. -runST :: (forall s. ST.ST s a) -> a -runST st = runSTRep (case st of { ST.ST st_rep -> st_rep }) -{-# INLINE runST #-} - -runSTRep :: (forall s. ST.STRep s a) -> a -runSTRep st_rep = case st_rep realWorld# of - (# _, r #) -> r -{-# INLINE [0] runSTRep #-} -#endif diff --git a/src/Data/Strict/HashMap/Autogen/Strict.hs b/src/Data/Strict/HashMap/Autogen/Strict.hs --- a/src/Data/Strict/HashMap/Autogen/Strict.hs +++ b/src/Data/Strict/HashMap/Autogen/Strict.hs @@ -18,7 +18,7 @@ -- especially when key comparison is expensive, as in the case of -- strings. -- --- Many operations have a average-case complexity of /O(log n)/. The +-- Many operations have a average-case complexity of \(O(\log n)\). The -- implementation uses a large base (i.e. 16) so in practice these -- operations are constant time. module Data.Strict.HashMap.Autogen.Strict @@ -65,6 +65,7 @@ , map , mapWithKey , traverseWithKey + , mapKeys -- * Difference and intersection , difference @@ -101,8 +102,10 @@ , fromListWithKey ) where -import Data.Strict.HashMap.Autogen.Internal.Strict as HM -import Prelude () +import Data.Strict.HashMap.Autogen.Internal.Strict +import Prelude () + +import qualified Data.HashSet.Internal as HS -- $strictness -- diff --git a/src/Data/Strict/IntMap/Autogen/Internal.hs b/src/Data/Strict/IntMap/Autogen/Internal.hs --- a/src/Data/Strict/IntMap/Autogen/Internal.hs +++ b/src/Data/Strict/IntMap/Autogen/Internal.hs @@ -1,18 +1,19 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} -#if __GLASGOW_HASKELL__ -{-# LANGUAGE MagicHash, DeriveDataTypeable, StandaloneDeriving #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} #endif #if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Trustworthy #-} #endif -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE TypeFamilies #-} -#endif {-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} #include "containers.h" @@ -292,34 +293,19 @@ , mapGentlyWhenMatched ) where -#if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity (..)) import Control.Applicative (liftA2) -#else -import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2) -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)) -#endif -#if !(MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0) +#if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup((<>))) #endif -#if MIN_VERSION_base(4,9,0) import Data.Semigroup (stimesIdempotentMonoid) import Data.Functor.Classes -#endif import Control.DeepSeq (NFData(rnf)) import Data.Bits import qualified Data.Foldable as Foldable -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable (Foldable()) -#endif import Data.Maybe (fromMaybe) -import Data.Typeable import Prelude hiding (lookup, map, filter, foldr, foldl, null) import Data.IntSet.Internal (Key) @@ -327,22 +313,16 @@ import Data.Strict.ContainersUtils.Autogen.BitUtil import Data.Strict.ContainersUtils.Autogen.StrictPair -#if __GLASGOW_HASKELL__ +#ifdef __GLASGOW_HASKELL__ +import Data.Coerce import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix), - DataType, mkDataType) + DataType, mkDataType, gcast1) import GHC.Exts (build) -#if !MIN_VERSION_base(4,8,0) -import Data.Functor ((<$)) -#endif -#if __GLASGOW_HASKELL__ >= 708 import qualified GHC.Exts as GHCExts -#endif import Text.Read +import Language.Haskell.TH.Syntax (Lift) #endif import qualified Control.Category as Category -#if __GLASGOW_HASKELL__ >= 709 -import Data.Coerce -#endif -- A "Nat" is a natural machine word (an unsigned Int) @@ -391,6 +371,9 @@ type IntSetPrefix = Int type IntSetBitMap = Word +-- | @since FIXME +deriving instance Lift a => Lift (IntMap a) + bitmapOf :: Int -> IntSetBitMap bitmapOf x = shiftLL 1 (x .&. IntSet.suffixBitMask) {-# INLINE bitmapOf #-} @@ -399,7 +382,7 @@ Operators --------------------------------------------------------------------} --- | /O(min(n,W))/. Find the value at a key. +-- | \(O(\min(n,W))\). Find the value at a key. -- Calls 'error' when the element can not be found. -- -- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map @@ -408,7 +391,7 @@ (!) :: IntMap a -> Key -> a (!) m k = find k m --- | /O(min(n,W))/. Find the value at a key. +-- | \(O(\min(n,W))\). Find the value at a key. -- Returns 'Nothing' when the element can not be found. -- -- > fromList [(5,'a'), (3,'b')] !? 1 == Nothing @@ -432,16 +415,12 @@ instance Monoid (IntMap a) where mempty = empty mconcat = unions -#if !(MIN_VERSION_base(4,9,0)) - mappend = union -#else mappend = (<>) -- | @since 0.5.7 instance Semigroup (IntMap a) where (<>) = union stimes = stimesIdempotentMonoid -#endif -- | Folds in order of increasing key. instance Foldable.Foldable IntMap where @@ -467,7 +446,6 @@ {-# INLINE foldl' #-} foldr' = foldr' {-# INLINE foldr' #-} -#if MIN_VERSION_base(4,8,0) length = size {-# INLINE length #-} null = null @@ -505,7 +483,6 @@ {-# INLINABLE sum #-} product = foldl' (*) 1 {-# INLINABLE product #-} -#endif -- | Traverses in order of increasing key. instance Traversable IntMap where @@ -546,7 +523,7 @@ {-------------------------------------------------------------------- Query --------------------------------------------------------------------} --- | /O(1)/. Is the map empty? +-- | \(O(1)\). Is the map empty? -- -- > Data.Strict.IntMap.Autogen.null (empty) == True -- > Data.Strict.IntMap.Autogen.null (singleton 1 'a') == False @@ -556,7 +533,7 @@ null _ = False {-# INLINE null #-} --- | /O(n)/. Number of elements in the map. +-- | \(O(n)\). Number of elements in the map. -- -- > size empty == 0 -- > size (singleton 1 'a') == 1 @@ -568,7 +545,7 @@ go acc (Tip _ _) = 1 + acc go acc Nil = acc --- | /O(min(n,W))/. Is the key a member of the map? +-- | \(O(\min(n,W))\). Is the key a member of the map? -- -- > member 5 (fromList [(5,'a'), (3,'b')]) == True -- > member 1 (fromList [(5,'a'), (3,'b')]) == False @@ -583,7 +560,7 @@ go (Tip kx _) = k == kx go Nil = False --- | /O(min(n,W))/. Is the key not a member of the map? +-- | \(O(\min(n,W))\). Is the key not a member of the map? -- -- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False -- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True @@ -591,34 +568,31 @@ notMember :: Key -> IntMap a -> Bool notMember k m = not $ member k m --- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'. +-- | \(O(\min(n,W))\). Lookup the value at a key in the map. See also 'Data.Map.lookup'. --- See Note: Local 'go' functions and capturing] +-- See Note: Local 'go' functions and capturing lookup :: Key -> IntMap a -> Maybe a lookup !k = go where - go (Bin p m l r) | nomatch k p m = Nothing - | zero k m = go l - | otherwise = go r + go (Bin _p m l r) | zero k m = go l + | otherwise = go r go (Tip kx x) | k == kx = Just x | otherwise = Nothing go Nil = Nothing - -- See Note: Local 'go' functions and capturing] find :: Key -> IntMap a -> a find !k = go where - go (Bin p m l r) | nomatch k p m = not_found - | zero k m = go l - | otherwise = go r + go (Bin _p m l r) | zero k m = go l + | otherwise = go r go (Tip kx x) | k == kx = x | otherwise = not_found go Nil = not_found not_found = error ("IntMap.!: key " ++ show k ++ " is not an element of the map") --- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@ +-- | \(O(\min(n,W))\). The expression @('findWithDefault' def k map)@ -- returns the value at key @k@ or returns @def@ when the key is not an -- element of the map. -- @@ -636,7 +610,7 @@ | otherwise = def go Nil = def --- | /O(log n)/. Find largest key smaller than the given one and return the +-- | \(O(\log n)\). Find largest key smaller than the given one and return the -- corresponding (key, value) pair. -- -- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing @@ -657,7 +631,7 @@ | otherwise = Just (ky, y) go def Nil = unsafeFindMax def --- | /O(log n)/. Find smallest key greater than the given one and return the +-- | \(O(\log n)\). Find smallest key greater than the given one and return the -- corresponding (key, value) pair. -- -- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') @@ -678,7 +652,7 @@ | otherwise = Just (ky, y) go def Nil = unsafeFindMin def --- | /O(log n)/. Find largest key smaller or equal to the given one and return +-- | \(O(\log n)\). Find largest key smaller or equal to the given one and return -- the corresponding (key, value) pair. -- -- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing @@ -700,7 +674,7 @@ | otherwise = Just (ky, y) go def Nil = unsafeFindMax def --- | /O(log n)/. Find smallest key greater or equal to the given one and return +-- | \(O(\log n)\). Find smallest key greater or equal to the given one and return -- the corresponding (key, value) pair. -- -- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') @@ -740,7 +714,7 @@ {-------------------------------------------------------------------- Disjoint --------------------------------------------------------------------} --- | /O(n+m)/. Check whether the key sets of two maps are disjoint +-- | \(O(n+m)\). Check whether the key sets of two maps are disjoint -- (i.e. their 'intersection' is empty). -- -- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())]) == True @@ -796,7 +770,7 @@ {-------------------------------------------------------------------- Construction --------------------------------------------------------------------} --- | /O(1)/. The empty map. +-- | \(O(1)\). The empty map. -- -- > empty == fromList [] -- > size empty == 0 @@ -806,7 +780,7 @@ = Nil {-# INLINE empty #-} --- | /O(1)/. A map of one element. +-- | \(O(1)\). A map of one element. -- -- > singleton 1 'a' == fromList [(1, 'a')] -- > size (singleton 1 'a') == 1 @@ -819,7 +793,7 @@ {-------------------------------------------------------------------- Insert --------------------------------------------------------------------} --- | /O(min(n,W))/. Insert a new key\/value pair in the map. +-- | \(O(\min(n,W))\). Insert a new key\/value pair in the map. -- If the key is already present in the map, the associated value is -- replaced with the supplied value, i.e. 'insert' is equivalent to -- @'insertWith' 'const'@. @@ -839,7 +813,7 @@ insert k x Nil = Tip k x -- right-biased insertion, used by 'union' --- | /O(min(n,W))/. Insert with a combining function. +-- | \(O(\min(n,W))\). Insert with a combining function. -- @'insertWith' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does -- not exist in the map. If the key does exist, the function will @@ -853,7 +827,7 @@ insertWith f k x t = insertWithKey (\_ x' y' -> f x' y') k x t --- | /O(min(n,W))/. Insert with a combining function. +-- | \(O(\min(n,W))\). Insert with a combining function. -- @'insertWithKey' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does -- not exist in the map. If the key does exist, the function will @@ -874,7 +848,7 @@ | otherwise = link k (Tip k x) ky t insertWithKey _ k x Nil = Tip k x --- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@) +-- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@) -- is a pair where the first element is equal to (@'lookup' k map@) -- and the second element equal to (@'insertWithKey' f k x map@). -- @@ -905,7 +879,7 @@ {-------------------------------------------------------------------- Deletion --------------------------------------------------------------------} --- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not +-- | \(O(\min(n,W))\). Delete a key and its value from the map. When the key is not -- a member of the map, the original map is returned. -- -- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" @@ -922,7 +896,7 @@ | otherwise = t delete _k Nil = Nil --- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not +-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. -- -- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] @@ -933,7 +907,7 @@ adjust f k m = adjustWithKey (\_ x -> f x) k m --- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not +-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. -- -- > let f key x = (show key) ++ ":new " ++ x @@ -942,8 +916,7 @@ -- > adjustWithKey f 7 empty == empty adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a -adjustWithKey f !k t@(Bin p m l r) - | nomatch k p m = t +adjustWithKey f !k (Bin p m l r) | zero k m = Bin p m (adjustWithKey f k l) r | otherwise = Bin p m l (adjustWithKey f k r) adjustWithKey f k t@(Tip ky y) @@ -952,7 +925,7 @@ adjustWithKey _ _ Nil = Nil --- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@ +-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. -- @@ -965,7 +938,7 @@ update f = updateWithKey (\_ x -> f x) --- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@ +-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. -- @@ -975,8 +948,7 @@ -- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a -updateWithKey f !k t@(Bin p m l r) - | nomatch k p m = t +updateWithKey f !k (Bin p m l r) | zero k m = binCheckLeft p m (updateWithKey f k l) r | otherwise = binCheckRight p m l (updateWithKey f k r) updateWithKey f k t@(Tip ky y) @@ -986,7 +958,7 @@ | otherwise = t updateWithKey _ _ Nil = Nil --- | /O(min(n,W))/. Lookup and update. +-- | \(O(\min(n,W))\). Lookup and update. -- The function returns original value, if it is updated. -- This is different behavior than 'Data.Map.updateLookupWithKey'. -- Returns the original key value if the map entry is deleted. @@ -997,8 +969,7 @@ -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a) -updateLookupWithKey f !k t@(Bin p m l r) - | nomatch k p m = (Nothing,t) +updateLookupWithKey f !k (Bin p m l r) | zero k m = let !(found,l') = updateLookupWithKey f k l in (found,binCheckLeft p m l' r) | otherwise = let !(found,r') = updateLookupWithKey f k r @@ -1012,7 +983,7 @@ --- | /O(min(n,W))/. 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 @@ -1033,7 +1004,7 @@ Just x -> Tip k x Nothing -> Nil --- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at +-- | \(O(\log n)\). The expression (@'alterF' f k map@) alters the value @x@ at -- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete, -- or update a value in an 'IntMap'. In short : @'lookup' k <$> 'alterF' f k m = f -- ('lookup' k m)@. @@ -1093,7 +1064,7 @@ unionsWith f ts = Foldable.foldl' (unionWith f) empty ts --- | /O(n+m)/. The (left-biased) union of two maps. +-- | \(O(n+m)\). The (left-biased) union of two maps. -- It prefers the first map when duplicate keys are encountered, -- i.e. (@'union' == 'unionWith' 'const'@). -- @@ -1103,7 +1074,7 @@ union m1 m2 = mergeWithKey' Bin const id id m1 m2 --- | /O(n+m)/. The union with a combining function. +-- | \(O(n+m)\). The union with a combining function. -- -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] @@ -1111,7 +1082,7 @@ unionWith f m1 m2 = unionWithKey (\_ x y -> f x y) m1 m2 --- | /O(n+m)/. The union with a combining function. +-- | \(O(n+m)\). The union with a combining function. -- -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] @@ -1123,7 +1094,7 @@ {-------------------------------------------------------------------- Difference --------------------------------------------------------------------} --- | /O(n+m)/. Difference between two maps (based on keys). +-- | \(O(n+m)\). Difference between two maps (based on keys). -- -- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b" @@ -1131,7 +1102,7 @@ difference m1 m2 = mergeWithKey (\_ _ _ -> Nothing) id (const Nil) m1 m2 --- | /O(n+m)/. Difference with a combining function. +-- | \(O(n+m)\). Difference with a combining function. -- -- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing -- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) @@ -1141,7 +1112,7 @@ differenceWith f m1 m2 = differenceWithKey (\_ x y -> f x y) m1 m2 --- | /O(n+m)/. Difference with a combining function. When two equal keys are +-- | \(O(n+m)\). Difference with a combining function. When two equal keys are -- encountered, the combining function is applied to the key and both values. -- If it returns 'Nothing', the element is discarded (proper set difference). -- If it returns (@'Just' y@), the element is updated with a new value @y@. @@ -1156,7 +1127,7 @@ -- TODO(wrengr): re-verify that asymptotic bound --- | /O(n+m)/. Remove all the keys in a given set from a map. +-- | \(O(n+m)\). Remove all the keys in a given set from a map. -- -- @ -- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``IntSet.notMember`` s) m @@ -1224,7 +1195,7 @@ {-------------------------------------------------------------------- Intersection --------------------------------------------------------------------} --- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys). +-- | \(O(n+m)\). The (left-biased) intersection of two maps (based on keys). -- -- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a" @@ -1234,7 +1205,7 @@ -- TODO(wrengr): re-verify that asymptotic bound --- | /O(n+m)/. The restriction of a map to the keys in a set. +-- | \(O(n+m)\). The restriction of a map to the keys in a set. -- -- @ -- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``IntSet.member`` s) m @@ -1271,7 +1242,7 @@ restrictKeys Nil _ = Nil --- | /O(min(n,W))/. Restrict to the sub-map with all keys matching +-- | \(O(\min(n,W))\). Restrict to the sub-map with all keys matching -- a key prefix. lookupPrefix :: IntSetPrefix -> IntMap a -> IntMap a lookupPrefix !kp t@(Bin p m l r) @@ -1300,7 +1271,7 @@ restrictBM _ Nil = Nil --- | /O(n+m)/. The intersection with a combining function. +-- | \(O(n+m)\). The intersection with a combining function. -- -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" @@ -1308,7 +1279,7 @@ intersectionWith f m1 m2 = intersectionWithKey (\_ x y -> f x y) m1 m2 --- | /O(n+m)/. The intersection with a combining function. +-- | \(O(n+m)\). The intersection with a combining function. -- -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" @@ -1321,7 +1292,7 @@ MergeWithKey --------------------------------------------------------------------} --- | /O(n+m)/. A high-performance universal combining function. Using +-- | \(O(n+m)\). A high-performance universal combining function. Using -- 'mergeWithKey', all combining functions can be defined without any loss of -- efficiency (with exception of 'union', 'difference' and 'intersection', -- where sharing of some nodes is lost with 'mergeWithKey'). @@ -1482,9 +1453,6 @@ -- -- @since 0.5.9 instance (Applicative f, Monad f) => Monad (WhenMissing f x) where -#if !MIN_VERSION_base(4,8,0) - return = pure -#endif m >>= f = traverseMaybeMissing $ \k x -> do res1 <- missingKey m k x @@ -1567,17 +1535,6 @@ {-# INLINE contramapSecondWhenMatched #-} -#if !MIN_VERSION_base(4,8,0) -newtype Identity a = Identity {runIdentity :: a} - -instance Functor Identity where - fmap f (Identity x) = Identity (f x) - -instance Applicative Identity where - pure = Identity - Identity f <*> Identity x = Identity (f x) -#endif - -- | A tactic for dealing with keys present in one map but not the -- other in 'merge'. -- @@ -1656,9 +1613,6 @@ -- -- @since 0.5.9 instance (Monad f, Applicative f) => Monad (WhenMatched f x y) where -#if !MIN_VERSION_base(4,8,0) - return = pure -#endif m >>= f = zipWithMaybeAMatched $ \k x y -> do res <- runWhenMatched m k x y @@ -1853,7 +1807,7 @@ {-# INLINE filterAMissing #-} --- | /O(n)/. Filter keys and values using an 'Applicative' predicate. +-- | \(O(n)\). Filter keys and values using an 'Applicative' predicate. filterWithKeyA :: Applicative f => (Key -> a -> f Bool) -> IntMap a -> f (IntMap a) filterWithKeyA _ Nil = pure Nil @@ -1894,7 +1848,7 @@ {-# INLINE traverseMaybeMissing #-} --- | /O(n)/. Traverse keys\/values and collect the 'Just' results. +-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results. -- -- @since 0.6.4 traverseMaybeWithKey @@ -2157,7 +2111,7 @@ Min\/Max --------------------------------------------------------------------} --- | /O(min(n,W))/. Update the value at the minimal key. +-- | \(O(\min(n,W))\). Update the value at the minimal key. -- -- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" @@ -2173,7 +2127,7 @@ Nothing -> Nil go _ Nil = error "updateMinWithKey Nil" --- | /O(min(n,W))/. Update the value at the maximal key. +-- | \(O(\min(n,W))\). Update the value at the maximal key. -- -- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" @@ -2192,7 +2146,7 @@ data View a = View {-# UNPACK #-} !Key a !(IntMap a) --- | /O(min(n,W))/. Retrieves the maximal (key,value) pair of the map, and +-- | \(O(\min(n,W))\). Retrieves the maximal (key,value) pair of the map, and -- the map stripped of that element, or 'Nothing' if passed an empty map. -- -- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b") @@ -2220,7 +2174,7 @@ -- See note on NOINLINE at minViewWithKeySure {-# NOINLINE maxViewWithKeySure #-} --- | /O(min(n,W))/. Retrieves the minimal (key,value) pair of the map, and +-- | \(O(\min(n,W))\). Retrieves the minimal (key,value) pair of the map, and -- the map stripped of that element, or 'Nothing' if passed an empty map. -- -- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a") @@ -2256,7 +2210,7 @@ -- anyway, which should be good enough. {-# NOINLINE minViewWithKeySure #-} --- | /O(min(n,W))/. Update the value at the maximal key. +-- | \(O(\min(n,W))\). Update the value at the maximal key. -- -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" @@ -2264,7 +2218,7 @@ updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a updateMax f = updateMaxWithKey (const f) --- | /O(min(n,W))/. Update the value at the minimal key. +-- | \(O(\min(n,W))\). Update the value at the minimal key. -- -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" @@ -2272,29 +2226,29 @@ updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a updateMin f = updateMinWithKey (const f) --- | /O(min(n,W))/. Retrieves the maximal key of the map, and the map +-- | \(O(\min(n,W))\). Retrieves the maximal key of the map, and the map -- stripped of that element, or 'Nothing' if passed an empty map. maxView :: IntMap a -> Maybe (a, IntMap a) maxView t = fmap (\((_, x), t') -> (x, t')) (maxViewWithKey t) --- | /O(min(n,W))/. Retrieves the minimal key of the map, and the map +-- | \(O(\min(n,W))\). Retrieves the minimal key of the map, and the map -- stripped of that element, or 'Nothing' if passed an empty map. minView :: IntMap a -> Maybe (a, IntMap a) minView t = fmap (\((_, x), t') -> (x, t')) (minViewWithKey t) --- | /O(min(n,W))/. Delete and find the maximal element. +-- | \(O(\min(n,W))\). Delete and find the maximal element. -- This function throws an error if the map is empty. Use 'maxViewWithKey' -- if the map may be empty. deleteFindMax :: IntMap a -> ((Key, a), IntMap a) deleteFindMax = fromMaybe (error "deleteFindMax: empty map has no maximal element") . maxViewWithKey --- | /O(min(n,W))/. Delete and find the minimal element. +-- | \(O(\min(n,W))\). Delete and find the minimal element. -- This function throws an error if the map is empty. Use 'minViewWithKey' -- if the map may be empty. deleteFindMin :: IntMap a -> ((Key, a), IntMap a) deleteFindMin = fromMaybe (error "deleteFindMin: empty map has no minimal element") . minViewWithKey --- | /O(min(n,W))/. The minimal key of the map. Returns 'Nothing' if the map is empty. +-- | \(O(\min(n,W))\). The minimal key of the map. Returns 'Nothing' if the map is empty. lookupMin :: IntMap a -> Maybe (Key, a) lookupMin Nil = Nothing lookupMin (Tip k v) = Just (k,v) @@ -2305,14 +2259,14 @@ go (Bin _ _ l' _) = go l' go Nil = Nothing --- | /O(min(n,W))/. The minimal key of the map. Calls 'error' if the map is empty. +-- | \(O(\min(n,W))\). The minimal key of the map. Calls 'error' if the map is empty. -- Use 'minViewWithKey' if the map may be empty. findMin :: IntMap a -> (Key, a) findMin t | Just r <- lookupMin t = r | otherwise = error "findMin: empty map has no minimal element" --- | /O(min(n,W))/. The maximal key of the map. Returns 'Nothing' if the map is empty. +-- | \(O(\min(n,W))\). The maximal key of the map. Returns 'Nothing' if the map is empty. lookupMax :: IntMap a -> Maybe (Key, a) lookupMax Nil = Nothing lookupMax (Tip k v) = Just (k,v) @@ -2323,21 +2277,21 @@ go (Bin _ _ _ r') = go r' go Nil = Nothing --- | /O(min(n,W))/. The maximal key of the map. Calls 'error' if the map is empty. +-- | \(O(\min(n,W))\). The maximal key of the map. Calls 'error' if the map is empty. -- Use 'maxViewWithKey' if the map may be empty. findMax :: IntMap a -> (Key, a) findMax t | Just r <- lookupMax t = r | otherwise = error "findMax: empty map has no maximal element" --- | /O(min(n,W))/. Delete the minimal key. Returns an empty map if the map is empty. +-- | \(O(\min(n,W))\). Delete the minimal key. Returns an empty map if the map is empty. -- -- Note that this is a change of behaviour for consistency with 'Data.Map.Map' – -- versions prior to 0.5 threw an error if the 'IntMap' was already empty. deleteMin :: IntMap a -> IntMap a deleteMin = maybe Nil snd . minView --- | /O(min(n,W))/. Delete the maximal key. Returns an empty map if the map is empty. +-- | \(O(\min(n,W))\). Delete the maximal key. Returns an empty map if the map is empty. -- -- Note that this is a change of behaviour for consistency with 'Data.Map.Map' – -- versions prior to 0.5 threw an error if the 'IntMap' was already empty. @@ -2348,13 +2302,13 @@ {-------------------------------------------------------------------- Submap --------------------------------------------------------------------} --- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). +-- | \(O(n+m)\). Is this a proper submap? (ie. a submap but not equal). -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@). isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool isProperSubmapOf m1 m2 = isProperSubmapOfBy (==) m1 m2 -{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). +{- | \(O(n+m)\). Is this a proper submap? (ie. a submap but not equal). The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when @keys m1@ and @keys m2@ are not equal, all keys in @m1@ are in @m2@, and when @f@ returns 'True' when @@ -2403,13 +2357,13 @@ submapCmp _ Nil Nil = EQ submapCmp _ Nil _ = LT --- | /O(n+m)/. Is this a submap? +-- | \(O(n+m)\). Is this a submap? -- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2 -{- | /O(n+m)/. +{- | \(O(n+m)\). The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if all keys in @m1@ are in @m2@, and when @f@ returns 'True' when applied to their respective values. For example, the following @@ -2442,7 +2396,7 @@ {-------------------------------------------------------------------- Mapping --------------------------------------------------------------------} --- | /O(n)/. Map a function over all values in the map. +-- | \(O(n)\). Map a function over all values in the map. -- -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] @@ -2457,16 +2411,11 @@ {-# 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. +-- | \(O(n)\). Map a function over all values in the map. -- -- > let f key x = (show key) ++ ":" ++ x -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] @@ -2490,7 +2439,7 @@ #-} #endif --- | /O(n)/. +-- | \(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 -- function also has access to the key associated with a value. @@ -2507,7 +2456,7 @@ | otherwise = liftA2 (Bin p m) (go l) (go r) {-# INLINE traverseWithKey #-} --- | /O(n)/. The function @'mapAccum'@ threads an accumulating +-- | \(O(n)\). The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a b = (a ++ b, b ++ "X") @@ -2516,7 +2465,7 @@ mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) mapAccum f = mapAccumWithKey (\a' _ x -> f a' x) --- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating +-- | \(O(n)\). The function @'mapAccumWithKey'@ threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") @@ -2526,7 +2475,7 @@ mapAccumWithKey f a t = mapAccumL f a t --- | /O(n)/. The function @'mapAccumL'@ threads an accumulating +-- | \(O(n)\). The function @'mapAccumL'@ threads an accumulating -- argument through the map in ascending order of keys. mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) mapAccumL f a t @@ -2543,7 +2492,7 @@ Tip k x -> let (a',x') = f a k x in (a',Tip k x') Nil -> (a,Nil) --- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating +-- | \(O(n)\). The function @'mapAccumRWithKey'@ threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) mapAccumRWithKey f a t @@ -2560,7 +2509,7 @@ Tip k x -> let (a',x') = f a k x in (a',Tip k x') Nil -> (a,Nil) --- | /O(n*min(n,W))/. +-- | \(O(n \min(n,W))\). -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. -- -- The size of the result may be smaller if @f@ maps two or more distinct @@ -2574,7 +2523,7 @@ mapKeys :: (Key->Key) -> IntMap a -> IntMap a mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) [] --- | /O(n*min(n,W))/. +-- | \(O(n \min(n,W))\). -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. -- -- The size of the result may be smaller if @f@ maps two or more distinct @@ -2588,7 +2537,7 @@ mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) [] --- | /O(n*min(n,W))/. +-- | \(O(n \min(n,W))\). -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ -- is strictly monotonic. -- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. @@ -2611,7 +2560,7 @@ {-------------------------------------------------------------------- Filter --------------------------------------------------------------------} --- | /O(n)/. Filter all values that satisfy some predicate. +-- | \(O(n)\). Filter all values that satisfy some predicate. -- -- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" -- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty @@ -2621,7 +2570,7 @@ filter p m = filterWithKey (\_ x -> p x) m --- | /O(n)/. Filter all keys\/values that satisfy some predicate. +-- | \(O(n)\). Filter all keys\/values that satisfy some predicate. -- -- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" @@ -2632,7 +2581,7 @@ go t@(Tip k x) = if predicate k x then t else Nil go (Bin p m l r) = bin p m (go l) (go r) --- | /O(n)/. Partition the map according to some predicate. The first +-- | \(O(n)\). Partition the map according to some predicate. The first -- map contains all elements that satisfy the predicate, the second all -- elements that fail the predicate. See also 'split'. -- @@ -2644,7 +2593,7 @@ partition p m = partitionWithKey (\_ x -> p x) m --- | /O(n)/. Partition the map according to some predicate. The first +-- | \(O(n)\). Partition the map according to some predicate. The first -- map contains all elements that satisfy the predicate, the second all -- elements that fail the predicate. See also 'split'. -- @@ -2666,7 +2615,7 @@ | otherwise -> (Nil :*: t) Nil -> (Nil :*: Nil) --- | /O(n)/. Map values and collect the 'Just' results. +-- | \(O(n)\). Map values and collect the 'Just' results. -- -- > let f x = if x == "a" then Just "new a" else Nothing -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" @@ -2674,7 +2623,7 @@ mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b mapMaybe f = mapMaybeWithKey (\_ x -> f x) --- | /O(n)/. Map keys\/values and collect the 'Just' results. +-- | \(O(n)\). Map keys\/values and collect the 'Just' results. -- -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" @@ -2687,7 +2636,7 @@ Nothing -> Nil mapMaybeWithKey _ Nil = Nil --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. +-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. -- -- > let f a = if a < "c" then Left a else Right a -- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) @@ -2700,7 +2649,7 @@ mapEither f m = mapEitherWithKey (\_ x -> f x) m --- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. +-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results. -- -- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) -- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) @@ -2722,7 +2671,7 @@ Right z -> (Nil :*: Tip k z) go _ Nil = (Nil :*: Nil) --- | /O(min(n,W))/. The expression (@'split' k map@) is a pair @(map1,map2)@ +-- | \(O(\min(n,W))\). The expression (@'split' k map@) is a pair @(map1,map2)@ -- where all keys in @map1@ are lower than @k@ and all keys in -- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@. -- @@ -2772,7 +2721,7 @@ mapGT f (SplitLookup lt fnd gt) = SplitLookup lt fnd (f gt) {-# INLINE mapGT #-} --- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot +-- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot -- key was found in the original map. -- -- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")]) @@ -2809,7 +2758,7 @@ {-------------------------------------------------------------------- Fold --------------------------------------------------------------------} --- | /O(n)/. Fold the values in the map using the given right-associative +-- | \(O(n)\). Fold the values in the map using the given right-associative -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. -- -- For example, @@ -2831,7 +2780,7 @@ go z' (Bin _ _ l r) = go (go z' r) l {-# INLINE foldr #-} --- | /O(n)/. A strict version of 'foldr'. Each application of the operator is +-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. foldr' :: (a -> b -> b) -> b -> IntMap a -> b @@ -2847,7 +2796,7 @@ go z' (Bin _ _ l r) = go (go z' r) l {-# INLINE foldr' #-} --- | /O(n)/. Fold the values in the map using the given left-associative +-- | \(O(n)\). Fold the values in the map using the given left-associative -- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@. -- -- For example, @@ -2869,7 +2818,7 @@ go z' (Bin _ _ l r) = go (go z' l) r {-# INLINE foldl #-} --- | /O(n)/. A strict version of 'foldl'. Each application of the operator is +-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. foldl' :: (a -> b -> a) -> a -> IntMap b -> a @@ -2885,7 +2834,7 @@ go z' (Bin _ _ l r) = go (go z' l) r {-# INLINE foldl' #-} --- | /O(n)/. Fold the keys and values in the map using the given right-associative +-- | \(O(n)\). Fold the keys and values in the map using the given right-associative -- binary operator, such that -- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. -- @@ -2908,7 +2857,7 @@ go z' (Bin _ _ l r) = go (go z' r) l {-# INLINE foldrWithKey #-} --- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is +-- | \(O(n)\). A strict version of 'foldrWithKey'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. foldrWithKey' :: (Key -> a -> b -> b) -> b -> IntMap a -> b @@ -2924,7 +2873,7 @@ go z' (Bin _ _ l r) = go (go z' r) l {-# INLINE foldrWithKey' #-} --- | /O(n)/. Fold the keys and values in the map using the given left-associative +-- | \(O(n)\). Fold the keys and values in the map using the given left-associative -- binary operator, such that -- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@. -- @@ -2947,7 +2896,7 @@ go z' (Bin _ _ l r) = go (go z' l) r {-# INLINE foldlWithKey #-} --- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is +-- | \(O(n)\). A strict version of 'foldlWithKey'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. foldlWithKey' :: (a -> Key -> b -> a) -> a -> IntMap b -> a @@ -2963,7 +2912,7 @@ go z' (Bin _ _ l r) = go (go z' l) r {-# INLINE foldlWithKey' #-} --- | /O(n)/. Fold the keys and values in the map using the given monoid, such that +-- | \(O(n)\). Fold the keys and values in the map using the given monoid, such that -- -- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@ -- @@ -2983,7 +2932,7 @@ {-------------------------------------------------------------------- List variations --------------------------------------------------------------------} --- | /O(n)/. +-- | \(O(n)\). -- Return all elements of the map in the ascending order of their keys. -- Subject to list fusion. -- @@ -2993,7 +2942,7 @@ elems :: IntMap a -> [a] elems = foldr (:) [] --- | /O(n)/. Return all keys of the map in ascending order. Subject to list +-- | \(O(n)\). Return all keys of the map in ascending order. Subject to list -- fusion. -- -- > keys (fromList [(5,"a"), (3,"b")]) == [3,5] @@ -3002,7 +2951,7 @@ keys :: IntMap a -> [Key] keys = foldrWithKey (\k _ ks -> k : ks) [] --- | /O(n)/. An alias for 'toAscList'. Returns all key\/value pairs in the +-- | \(O(n)\). An alias for 'toAscList'. Returns all key\/value pairs in the -- map in ascending key order. Subject to list fusion. -- -- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] @@ -3011,7 +2960,7 @@ assocs :: IntMap a -> [(Key,a)] assocs = toAscList --- | /O(n*min(n,W))/. The set of all keys of the map. +-- | \(O(n \min(n,W))\). The set of all keys of the map. -- -- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.IntSet.fromList [3,5] -- > keysSet empty == Data.IntSet.empty @@ -3026,7 +2975,7 @@ computeBm acc (Tip kx _) = acc .|. IntSet.bitmapOf kx computeBm _ Nil = error "Data.IntSet.keysSet: Nil" --- | /O(n)/. Build a map from a set of keys and a function which for each key +-- | \(O(n)\). Build a map from a set of keys and a function which for each key -- computes its value. -- -- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] @@ -3061,7 +3010,8 @@ {-------------------------------------------------------------------- Lists --------------------------------------------------------------------} -#if __GLASGOW_HASKELL__ >= 708 + +#ifdef __GLASGOW_HASKELL__ -- | @since 0.5.6.2 instance GHCExts.IsList (IntMap a) where type Item (IntMap a) = (Key,a) @@ -3069,7 +3019,7 @@ toList = toList #endif --- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list +-- | \(O(n)\). Convert the map to a list of key\/value pairs. Subject to list -- fusion. -- -- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] @@ -3078,7 +3028,7 @@ toList :: IntMap a -> [(Key,a)] toList = toAscList --- | /O(n)/. Convert the map to a list of key\/value pairs where the +-- | \(O(n)\). Convert the map to a list of key\/value pairs where the -- keys are in ascending order. Subject to list fusion. -- -- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] @@ -3086,7 +3036,7 @@ toAscList :: IntMap a -> [(Key,a)] toAscList = foldrWithKey (\k x xs -> (k,x):xs) [] --- | /O(n)/. Convert the map to a list of key\/value pairs where the keys +-- | \(O(n)\). Convert the map to a list of key\/value pairs where the keys -- are in descending order. Subject to list fusion. -- -- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")] @@ -3130,7 +3080,7 @@ #endif --- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs. +-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs. -- -- > fromList [] == empty -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] @@ -3142,7 +3092,7 @@ where ins t (k,x) = insert k x t --- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. -- -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")] -- > fromListWith (++) [] == empty @@ -3151,7 +3101,7 @@ fromListWith f xs = fromListWithKey (\_ x y -> f x y) xs --- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. +-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. -- -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value -- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] @@ -3163,7 +3113,7 @@ where ins t (k,x) = insertWithKey f k x t --- | /O(n)/. Build a map from a list of key\/value pairs where +-- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order. -- -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] @@ -3173,7 +3123,7 @@ fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x) {-# NOINLINE fromAscList #-} --- | /O(n)/. Build a map from a list of key\/value pairs where +-- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys. -- /The precondition (input list is ascending) is not checked./ -- @@ -3183,7 +3133,7 @@ fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y) {-# NOINLINE fromAscListWith #-} --- | /O(n)/. Build a map from a list of key\/value pairs where +-- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys. -- /The precondition (input list is ascending) is not checked./ -- @@ -3194,7 +3144,7 @@ fromAscListWithKey f = fromMonoListWithKey Nondistinct f {-# NOINLINE fromAscListWithKey #-} --- | /O(n)/. Build a map from a list of key\/value pairs where +-- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order and all distinct. -- /The precondition (input list is strictly ascending) is not checked./ -- @@ -3204,7 +3154,7 @@ fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x) {-# NOINLINE fromDistinctAscList #-} --- | /O(n)/. Build a map from a list of key\/value pairs with monotonic keys +-- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys -- and a combining function. -- -- The precise conditions under which this function works are subtle: @@ -3289,7 +3239,6 @@ nequal Nil Nil = False nequal _ _ = True -#if MIN_VERSION_base(4,9,0) -- | @since 0.5.9 instance Eq1 IntMap where liftEq eq (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) @@ -3298,7 +3247,6 @@ = (kx == ky) && (eq x y) liftEq _eq Nil Nil = True liftEq _eq _ _ = False -#endif {-------------------------------------------------------------------- Ord @@ -3307,12 +3255,10 @@ instance Ord a => Ord (IntMap a) where compare m1 m2 = compare (toList m1) (toList m2) -#if MIN_VERSION_base(4,9,0) -- | @since 0.5.9 instance Ord1 IntMap where liftCompare cmp m n = liftCompare (liftCompare cmp) (toList m) (toList n) -#endif {-------------------------------------------------------------------- Functor @@ -3335,7 +3281,6 @@ showsPrec d m = showParen (d > 10) $ showString "fromList " . shows (toList m) -#if MIN_VERSION_base(4,9,0) -- | @since 0.5.9 instance Show1 IntMap where liftShowsPrec sp sl d m = @@ -3343,7 +3288,6 @@ where sp' = liftShowsPrec sp sl sl' = liftShowList sp sl -#endif {-------------------------------------------------------------------- Read @@ -3363,7 +3307,6 @@ return (fromList xs,t) #endif -#if MIN_VERSION_base(4,9,0) -- | @since 0.5.9 instance Read1 IntMap where liftReadsPrec rp rl = readsData $ @@ -3371,15 +3314,8 @@ where rp' = liftReadsPrec rp rl rl' = liftReadList rp rl -#endif {-------------------------------------------------------------------- - Typeable ---------------------------------------------------------------------} - -INSTANCE_TYPEABLE1(IntMap) - -{-------------------------------------------------------------------- Helpers --------------------------------------------------------------------} {-------------------------------------------------------------------- @@ -3480,7 +3416,7 @@ Utilities --------------------------------------------------------------------} --- | /O(1)/. Decompose a map into pieces based on the structure +-- | \(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. -- @@ -3513,14 +3449,14 @@ Debugging --------------------------------------------------------------------} --- | /O(n)/. Show the tree that implements the map. The tree is shown +-- | \(O(n)\). Show the tree that implements the map. The tree is shown -- in a compressed, hanging format. showTree :: Show a => IntMap a -> String showTree s = showTreeWith True False s -{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows +{- | \(O(n)\). The expression (@'showTreeWith' hang wide map@) shows the tree that implements the map. If @hang@ is 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If @wide@ is 'True', an extra wide version is shown. diff --git a/src/Data/Strict/IntMap/Autogen/Merge/Strict.hs b/src/Data/Strict/IntMap/Autogen/Merge/Strict.hs --- a/src/Data/Strict/IntMap/Autogen/Merge/Strict.hs +++ b/src/Data/Strict/IntMap/Autogen/Merge/Strict.hs @@ -1,21 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -#if __GLASGOW_HASKELL__ -{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} -#endif #if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Trustworthy #-} #endif -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TypeFamilies #-} -#define USE_MAGIC_PROXY 1 -#endif -#if USE_MAGIC_PROXY -{-# LANGUAGE MagicHash #-} -#endif - #include "containers.h" ----------------------------------------------------------------------------- @@ -112,9 +100,6 @@ , runWhenMissing ) import Data.Strict.IntMap.Autogen.Strict.Internal -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative (..), (<$>)) -#endif import Prelude hiding (filter, map, foldl, foldr) -- | Map covariantly over a @'WhenMissing' f k x@. diff --git a/src/Data/Strict/IntMap/Autogen/Strict.hs b/src/Data/Strict/IntMap/Autogen/Strict.hs --- a/src/Data/Strict/IntMap/Autogen/Strict.hs +++ b/src/Data/Strict/IntMap/Autogen/Strict.hs @@ -48,8 +48,8 @@ -- -- == Detailed performance information -- --- The amortized running time is given for each operation, with /n/ referring to --- the number of entries in the map and /W/ referring to the number of bits in +-- The amortized running time is given for each operation, with \(n\) referring to +-- the number of entries in the map and \(W\) referring to the number of bits in -- an 'Int' (32 or 64). -- -- Benchmarks comparing "Data.Strict.IntMap.Autogen.Strict" with other dictionary @@ -77,9 +77,8 @@ -- Workshop on ML, September 1998, pages 77-86, -- -- --- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve --- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), --- October 1968, pages 514-534. +-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\", +-- Journal of the ACM, 15(4), October 1968, pages 514-534. -- ----------------------------------------------------------------------------- diff --git a/src/Data/Strict/IntMap/Autogen/Strict/Internal.hs b/src/Data/Strict/IntMap/Autogen/Strict/Internal.hs --- a/src/Data/Strict/IntMap/Autogen/Strict/Internal.hs +++ b/src/Data/Strict/IntMap/Autogen/Strict/Internal.hs @@ -2,6 +2,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + #include "containers.h" ----------------------------------------------------------------------------- @@ -46,8 +48,8 @@ -- -- == Detailed performance information -- --- The amortized running time is given for each operation, with /n/ referring to --- the number of entries in the map and /W/ referring to the number of bits in +-- The amortized running time is given for each operation, with \(n\) referring to +-- the number of entries in the map and \(W\) referring to the number of bits in -- an 'Int' (32 or 64). -- -- Benchmarks comparing "Data.Strict.IntMap.Autogen.Strict" with other dictionary @@ -75,9 +77,8 @@ -- Workshop on ML, September 1998, pages 77-86, -- -- --- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve --- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), --- October 1968, pages 514-534. +-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\", +-- Journal of the ACM, 15(4), October 1968, pages 514-534. -- ----------------------------------------------------------------------------- @@ -344,20 +345,14 @@ import qualified Data.IntSet.Internal as IntSet import Data.Strict.ContainersUtils.Autogen.BitUtil import Data.Strict.ContainersUtils.Autogen.StrictPair -#if !MIN_VERSION_base(4,8,0) -import Data.Functor((<$>)) -#endif import Control.Applicative (Applicative (..), liftA2) import qualified Data.Foldable as Foldable -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable (Foldable()) -#endif {-------------------------------------------------------------------- Query --------------------------------------------------------------------} --- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@ +-- | \(O(\min(n,W))\). The expression @('findWithDefault' def k map)@ -- returns the value at key @k@ or returns @def@ when the key is not an -- element of the map. -- @@ -378,7 +373,7 @@ {-------------------------------------------------------------------- Construction --------------------------------------------------------------------} --- | /O(1)/. A map of one element. +-- | \(O(1)\). A map of one element. -- -- > singleton 1 'a' == fromList [(1, 'a')] -- > size (singleton 1 'a') == 1 @@ -391,7 +386,7 @@ {-------------------------------------------------------------------- Insert --------------------------------------------------------------------} --- | /O(min(n,W))/. Insert a new key\/value pair in the map. +-- | \(O(\min(n,W))\). Insert a new key\/value pair in the map. -- If the key is already present in the map, the associated value is -- replaced with the supplied value, i.e. 'insert' is equivalent to -- @'insertWith' 'const'@. @@ -413,7 +408,7 @@ Nil -> Tip k x -- right-biased insertion, used by 'union' --- | /O(min(n,W))/. Insert with a combining function. +-- | \(O(\min(n,W))\). Insert with a combining function. -- @'insertWith' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does -- not exist in the map. If the key does exist, the function will @@ -427,7 +422,7 @@ insertWith f k x t = insertWithKey (\_ x' y' -> f x' y') k x t --- | /O(min(n,W))/. Insert with a combining function. +-- | \(O(\min(n,W))\). Insert with a combining function. -- @'insertWithKey' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does -- not exist in the map. If the key does exist, the function will @@ -453,7 +448,7 @@ | otherwise -> link k (singleton k x) ky t Nil -> singleton k x --- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@) +-- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@) -- is a pair where the first element is equal to (@'lookup' k map@) -- and the second element equal to (@'insertWithKey' f k x map@). -- @@ -486,7 +481,7 @@ {-------------------------------------------------------------------- Deletion --------------------------------------------------------------------} --- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not +-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. -- -- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] @@ -497,7 +492,7 @@ adjust f k m = adjustWithKey (\_ x -> f x) k m --- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not +-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. -- -- > let f key x = (show key) ++ ":new " ++ x @@ -517,7 +512,7 @@ | otherwise -> t Nil -> Nil --- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@ +-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. -- @@ -530,7 +525,7 @@ update f = updateWithKey (\_ x -> f x) --- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@ +-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. -- @@ -553,7 +548,7 @@ | otherwise -> t Nil -> Nil --- | /O(min(n,W))/. Lookup and update. +-- | \(O(\min(n,W))\). Lookup and update. -- The function returns original value, if it is updated. -- This is different behavior than 'Data.Map.updateLookupWithKey'. -- Returns the original key value if the map entry is deleted. @@ -581,7 +576,7 @@ --- | /O(min(n,W))/. 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 @@ -604,7 +599,7 @@ Just !x -> Tip k x Nothing -> Nil --- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at +-- | \(O(\log n)\). The expression (@'alterF' f k map@) alters the value @x@ at -- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete, -- or update a value in an 'IntMap'. In short : @'lookup' k <$> 'alterF' f k m = f -- ('lookup' k m)@. @@ -654,7 +649,7 @@ unionsWith f ts = Foldable.foldl' (unionWith f) empty ts --- | /O(n+m)/. The union with a combining function. +-- | \(O(n+m)\). The union with a combining function. -- -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] @@ -662,7 +657,7 @@ unionWith f m1 m2 = unionWithKey (\_ x y -> f x y) m1 m2 --- | /O(n+m)/. The union with a combining function. +-- | \(O(n+m)\). The union with a combining function. -- -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] @@ -675,7 +670,7 @@ Difference --------------------------------------------------------------------} --- | /O(n+m)/. Difference with a combining function. +-- | \(O(n+m)\). Difference with a combining function. -- -- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing -- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) @@ -685,7 +680,7 @@ differenceWith f m1 m2 = differenceWithKey (\_ x y -> f x y) m1 m2 --- | /O(n+m)/. Difference with a combining function. When two equal keys are +-- | \(O(n+m)\). Difference with a combining function. When two equal keys are -- encountered, the combining function is applied to the key and both values. -- If it returns 'Nothing', the element is discarded (proper set difference). -- If it returns (@'Just' y@), the element is updated with a new value @y@. @@ -702,7 +697,7 @@ Intersection --------------------------------------------------------------------} --- | /O(n+m)/. The intersection with a combining function. +-- | \(O(n+m)\). The intersection with a combining function. -- -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" @@ -710,7 +705,7 @@ intersectionWith f m1 m2 = intersectionWithKey (\_ x y -> f x y) m1 m2 --- | /O(n+m)/. The intersection with a combining function. +-- | \(O(n+m)\). The intersection with a combining function. -- -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" @@ -723,7 +718,7 @@ MergeWithKey --------------------------------------------------------------------} --- | /O(n+m)/. A high-performance universal combining function. Using +-- | \(O(n+m)\). A high-performance universal combining function. Using -- 'mergeWithKey', all combining functions can be defined without any loss of -- efficiency (with exception of 'union', 'difference' and 'intersection', -- where sharing of some nodes is lost with 'mergeWithKey'). @@ -772,7 +767,7 @@ Min\/Max --------------------------------------------------------------------} --- | /O(log n)/. Update the value at the minimal key. +-- | \(O(\log n)\). Update the value at the minimal key. -- -- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" @@ -788,7 +783,7 @@ Nothing -> Nil go _ Nil = error "updateMinWithKey Nil" --- | /O(log n)/. Update the value at the maximal key. +-- | \(O(\log n)\). Update the value at the maximal key. -- -- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" @@ -804,7 +799,7 @@ Nothing -> Nil go _ Nil = error "updateMaxWithKey Nil" --- | /O(log n)/. Update the value at the maximal key. +-- | \(O(\log n)\). Update the value at the maximal key. -- -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" @@ -812,7 +807,7 @@ updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a updateMax f = updateMaxWithKey (const f) --- | /O(log n)/. Update the value at the minimal key. +-- | \(O(\log n)\). Update the value at the minimal key. -- -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" @@ -824,7 +819,7 @@ {-------------------------------------------------------------------- Mapping --------------------------------------------------------------------} --- | /O(n)/. Map a function over all values in the map. +-- | \(O(n)\). Map a function over all values in the map. -- -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] @@ -843,7 +838,7 @@ #-} #endif --- | /O(n)/. Map a function over all values in the map. +-- | \(O(n)\). Map a function over all values in the map. -- -- > let f key x = (show key) ++ ":" ++ x -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] @@ -885,7 +880,7 @@ #-} #endif --- | /O(n)/. +-- | \(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 -- function also has access to the key associated with a value. @@ -902,7 +897,7 @@ | otherwise = liftA2 (Bin p m) (go l) (go r) {-# INLINE traverseWithKey #-} --- | /O(n)/. Traverse keys\/values and collect the 'Just' results. +-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results. -- -- @since 0.6.4 traverseMaybeWithKey @@ -915,7 +910,7 @@ | m < 0 = liftA2 (flip (bin p m)) (go r) (go l) | otherwise = liftA2 (bin p m) (go l) (go r) --- | /O(n)/. The function @'mapAccum'@ threads an accumulating +-- | \(O(n)\). The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a b = (a ++ b, b ++ "X") @@ -924,7 +919,7 @@ mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) mapAccum f = mapAccumWithKey (\a' _ x -> f a' x) --- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating +-- | \(O(n)\). The function @'mapAccumWithKey'@ threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") @@ -934,7 +929,7 @@ mapAccumWithKey f a t = mapAccumL f a t --- | /O(n)/. The function @'mapAccumL'@ threads an accumulating +-- | \(O(n)\). The function @'mapAccumL'@ threads an accumulating -- argument through the map in ascending order of keys. Strict in -- the accumulating argument and the both elements of the -- result of the function. @@ -955,7 +950,7 @@ Tip k x -> let !(a',!x') = f a k x in (a' :*: Tip k x') Nil -> (a :*: Nil) --- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating +-- | \(O(n)\). The function @'mapAccumRWithKey'@ threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) mapAccumRWithKey f0 a0 t0 = toPair $ go f0 a0 t0 @@ -974,7 +969,7 @@ Tip k x -> let !(a',!x') = f a k x in (a' :*: Tip k x') Nil -> (a :*: Nil) --- | /O(n*log n)/. +-- | \(O(n \log n)\). -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. -- -- The size of the result may be smaller if @f@ maps two or more distinct @@ -990,7 +985,7 @@ {-------------------------------------------------------------------- Filter --------------------------------------------------------------------} --- | /O(n)/. Map values and collect the 'Just' results. +-- | \(O(n)\). Map values and collect the 'Just' results. -- -- > let f x = if x == "a" then Just "new a" else Nothing -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" @@ -998,7 +993,7 @@ mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b mapMaybe f = mapMaybeWithKey (\_ x -> f x) --- | /O(n)/. Map keys\/values and collect the 'Just' results. +-- | \(O(n)\). Map keys\/values and collect the 'Just' results. -- -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" @@ -1011,7 +1006,7 @@ Nothing -> Nil mapMaybeWithKey _ Nil = Nil --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. +-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. -- -- > let f a = if a < "c" then Left a else Right a -- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) @@ -1024,7 +1019,7 @@ mapEither f m = mapEitherWithKey (\_ x -> f x) m --- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. +-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results. -- -- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) -- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) @@ -1050,7 +1045,7 @@ Conversions --------------------------------------------------------------------} --- | /O(n)/. Build a map from a set of keys and a function which for each key +-- | \(O(n)\). Build a map from a set of keys and a function which for each key -- computes its value. -- -- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] @@ -1080,7 +1075,7 @@ {-------------------------------------------------------------------- Lists --------------------------------------------------------------------} --- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs. +-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs. -- -- > fromList [] == empty -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] @@ -1092,7 +1087,7 @@ where ins t (k,x) = insert k x t --- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. -- -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] -- > fromListWith (++) [] == empty @@ -1101,7 +1096,7 @@ fromListWith f xs = fromListWithKey (\_ x y -> f x y) xs --- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. +-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. -- -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] -- > fromListWith (++) [] == empty @@ -1112,7 +1107,7 @@ where ins t (k,x) = insertWithKey f k x t --- | /O(n)/. Build a map from a list of key\/value pairs where +-- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order. -- -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] @@ -1122,7 +1117,7 @@ fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x) {-# NOINLINE fromAscList #-} --- | /O(n)/. Build a map from a list of key\/value pairs where +-- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys. -- /The precondition (input list is ascending) is not checked./ -- @@ -1132,7 +1127,7 @@ fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y) {-# NOINLINE fromAscListWith #-} --- | /O(n)/. Build a map from a list of key\/value pairs where +-- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys. -- /The precondition (input list is ascending) is not checked./ -- @@ -1142,7 +1137,7 @@ fromAscListWithKey f = fromMonoListWithKey Nondistinct f {-# NOINLINE fromAscListWithKey #-} --- | /O(n)/. Build a map from a list of key\/value pairs where +-- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order and all distinct. -- /The precondition (input list is strictly ascending) is not checked./ -- @@ -1152,7 +1147,7 @@ fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x) {-# NOINLINE fromDistinctAscList #-} --- | /O(n)/. Build a map from a list of key\/value pairs with monotonic keys +-- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys -- and a combining function. -- -- The precise conditions under which this function works are subtle: diff --git a/src/Data/Strict/Map/Autogen/Internal.hs b/src/Data/Strict/Map/Autogen/Internal.hs --- a/src/Data/Strict/Map/Autogen/Internal.hs +++ b/src/Data/Strict/Map/Autogen/Internal.hs @@ -1,17 +1,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} -#if __GLASGOW_HASKELL__ -{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} -#endif #if defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Trustworthy #-} -#endif -#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} -#define USE_MAGIC_PROXY 1 #endif +#define USE_MAGIC_PROXY 1 #ifdef USE_MAGIC_PROXY {-# LANGUAGE MagicHash #-} @@ -267,7 +264,9 @@ , keys , assocs , keysSet + , argSet , fromSet + , fromArgSet -- ** Lists , toList @@ -344,7 +343,7 @@ -- Used by the strict version , AreWeStrict (..) , atKeyImpl -#if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0) +#ifdef __GLASGOW_HASKELL__ , atKeyPlain #endif , bin @@ -369,35 +368,21 @@ , mapGentlyWhenMatched ) where -#if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity (..)) import Control.Applicative (liftA3) -#else -import Control.Applicative (Applicative(..), (<$>), liftA3) -import Data.Monoid (Monoid(..)) -import Data.Traversable (Traversable(traverse)) -#endif -#if MIN_VERSION_base(4,9,0) import Data.Functor.Classes import Data.Semigroup (stimesIdempotentMonoid) -#endif -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup(stimes)) -#endif -#if !(MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0) +import Data.Semigroup (Arg(..), Semigroup(stimes)) +#if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup((<>))) #endif import Control.Applicative (Const (..)) import Control.DeepSeq (NFData(rnf)) import Data.Bits (shiftL, shiftR) import qualified Data.Foldable as Foldable -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable (Foldable()) -#endif #if MIN_VERSION_base(4,10,0) import Data.Bifoldable #endif -import Data.Typeable import Prelude hiding (lookup, map, filter, foldr, foldl, null, splitAt, take, drop) import qualified Data.Set.Internal as Set @@ -412,20 +397,14 @@ #if __GLASGOW_HASKELL__ import GHC.Exts (build, lazy) -#if !MIN_VERSION_base(4,8,0) -import Data.Functor ((<$)) -#endif -#ifdef USE_MAGIC_PROXY +import Language.Haskell.TH.Syntax (Lift) +# ifdef USE_MAGIC_PROXY import GHC.Exts (Proxy#, proxy# ) -#endif -#if __GLASGOW_HASKELL__ >= 708 +# endif import qualified GHC.Exts as GHCExts -#endif import Text.Read hiding (lift) import Data.Data import qualified Control.Category as Category -#endif -#if __GLASGOW_HASKELL__ >= 708 import Data.Coerce #endif @@ -435,7 +414,7 @@ --------------------------------------------------------------------} infixl 9 !,!?,\\ -- --- | /O(log n)/. Find the value at a key. +-- | \(O(\log n)\). Find the value at a key. -- Calls 'error' when the element can not be found. -- -- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map @@ -447,7 +426,7 @@ {-# INLINE (!) #-} #endif --- | /O(log n)/. Find the value at a key. +-- | \(O(\log n)\). Find the value at a key. -- Returns 'Nothing' when the element can not be found. -- -- prop> fromList [(5, 'a'), (3, 'b')] !? 1 == Nothing @@ -484,22 +463,23 @@ type Size = Int -#if __GLASGOW_HASKELL__ >= 708 +#ifdef __GLASGOW_HASKELL__ type role Map nominal representational #endif +#ifdef __GLASGOW_HASKELL__ +-- | @since FIXME +deriving instance (Lift k, Lift a) => Lift (Map k a) +#endif + instance (Ord k) => Monoid (Map k v) where mempty = empty 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__ @@ -530,7 +510,7 @@ {-------------------------------------------------------------------- Query --------------------------------------------------------------------} --- | /O(1)/. Is the map empty? +-- | \(O(1)\). Is the map empty? -- -- > Data.Strict.Map.Autogen.null (empty) == True -- > Data.Strict.Map.Autogen.null (singleton 1 'a') == False @@ -540,7 +520,7 @@ null (Bin {}) = False {-# INLINE null #-} --- | /O(1)/. The number of elements in the map. +-- | \(O(1)\). The number of elements in the map. -- -- > size empty == 0 -- > size (singleton 1 'a') == 1 @@ -552,7 +532,7 @@ {-# INLINE size #-} --- | /O(log n)/. Lookup the value at a key in the map. +-- | \(O(\log n)\). Lookup the value at a key in the map. -- -- The function will return the corresponding value as @('Just' value)@, -- or 'Nothing' if the key isn't in the map. @@ -594,7 +574,7 @@ {-# INLINE lookup #-} #endif --- | /O(log n)/. Is the key a member of the map? See also 'notMember'. +-- | \(O(\log n)\). Is the key a member of the map? See also 'notMember'. -- -- > member 5 (fromList [(5,'a'), (3,'b')]) == True -- > member 1 (fromList [(5,'a'), (3,'b')]) == False @@ -612,7 +592,7 @@ {-# INLINE member #-} #endif --- | /O(log n)/. Is the key not a member of the map? See also 'member'. +-- | \(O(\log n)\). Is the key not a member of the map? See also 'member'. -- -- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False -- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True @@ -625,7 +605,7 @@ {-# INLINE notMember #-} #endif --- | /O(log n)/. Find the value at a key. +-- | \(O(\log n)\). Find the value at a key. -- Calls 'error' when the element can not be found. find :: Ord k => k -> Map k a -> a find = go @@ -641,7 +621,7 @@ {-# INLINE find #-} #endif --- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns +-- | \(O(\log n)\). The expression @('findWithDefault' def k map)@ returns -- the value at key @k@ or returns default value @def@ -- when the key is not in the map. -- @@ -661,7 +641,7 @@ {-# INLINE findWithDefault #-} #endif --- | /O(log n)/. Find largest key smaller than the given one and return the +-- | \(O(\log n)\). Find largest key smaller than the given one and return the -- corresponding (key, value) pair. -- -- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing @@ -682,7 +662,7 @@ {-# INLINE lookupLT #-} #endif --- | /O(log n)/. Find smallest key greater than the given one and return the +-- | \(O(\log n)\). Find smallest key greater than the given one and return the -- corresponding (key, value) pair. -- -- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') @@ -703,7 +683,7 @@ {-# INLINE lookupGT #-} #endif --- | /O(log n)/. Find largest key smaller or equal to the given one and return +-- | \(O(\log n)\). Find largest key smaller or equal to the given one and return -- the corresponding (key, value) pair. -- -- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing @@ -727,7 +707,7 @@ {-# INLINE lookupLE #-} #endif --- | /O(log n)/. Find smallest key greater or equal to the given one and return +-- | \(O(\log n)\). Find smallest key greater or equal to the given one and return -- the corresponding (key, value) pair. -- -- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') @@ -754,7 +734,7 @@ {-------------------------------------------------------------------- Construction --------------------------------------------------------------------} --- | /O(1)/. The empty map. +-- | \(O(1)\). The empty map. -- -- > empty == fromList [] -- > size empty == 0 @@ -763,7 +743,7 @@ empty = Tip {-# INLINE empty #-} --- | /O(1)/. A map with a single element. +-- | \(O(1)\). A map with a single element. -- -- > singleton 1 'a' == fromList [(1, 'a')] -- > size (singleton 1 'a') == 1 @@ -775,7 +755,7 @@ {-------------------------------------------------------------------- Insertion --------------------------------------------------------------------} --- | /O(log n)/. Insert a new key and value in the map. +-- | \(O(\log n)\). Insert a new key and value in the map. -- If the key is already present in the map, the associated value is -- replaced with the supplied value. 'insert' is equivalent to -- @'insertWith' 'const'@. @@ -855,7 +835,7 @@ {-# INLINE insertR #-} #endif --- | /O(log n)/. Insert with a function, combining new value and old value. +-- | \(O(\log n)\). Insert with a function, combining new value and old value. -- @'insertWith' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does -- not exist in the map. If the key does exist, the function will @@ -907,7 +887,7 @@ {-# INLINE insertWithR #-} #endif --- | /O(log n)/. Insert with a function, combining key, new value and old value. +-- | \(O(\log n)\). Insert with a function, combining key, new value and old value. -- @'insertWithKey' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does -- not exist in the map. If the key does exist, the function will @@ -956,7 +936,7 @@ {-# INLINE insertWithKeyR #-} #endif --- | /O(log n)/. Combines insert operation with old value retrieval. +-- | \(O(\log n)\). Combines insert operation with old value retrieval. -- The expression (@'insertLookupWithKey' f k x map@) -- is a pair where the first element is equal to (@'lookup' k map@) -- and the second element equal to (@'insertWithKey' f k x map@). @@ -997,7 +977,7 @@ {-------------------------------------------------------------------- Deletion --------------------------------------------------------------------} --- | /O(log n)/. Delete a key and its value from the map. When the key is not +-- | \(O(\log n)\). Delete a key and its value from the map. When the key is not -- a member of the map, the original map is returned. -- -- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" @@ -1025,7 +1005,7 @@ {-# INLINE delete #-} #endif --- | /O(log n)/. Update a value at a specific key with the result of the provided function. +-- | \(O(\log n)\). Update a value at a specific key with the result of the provided function. -- When the key is not -- a member of the map, the original map is returned. -- @@ -1041,7 +1021,7 @@ {-# INLINE adjust #-} #endif --- | /O(log n)/. Adjust a value at a specific key. When the key is not +-- | \(O(\log n)\). Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. -- -- > let f key x = (show key) ++ ":new " ++ x @@ -1065,7 +1045,7 @@ {-# INLINE adjustWithKey #-} #endif --- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ +-- | \(O(\log n)\). The expression (@'update' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. -- @@ -1082,7 +1062,7 @@ {-# INLINE update #-} #endif --- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the +-- | \(O(\log n)\). The expression (@'updateWithKey' f k map@) updates the -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound -- to the new value @y@. @@ -1111,7 +1091,7 @@ {-# INLINE updateWithKey #-} #endif --- | /O(log n)/. Lookup and update. See also 'updateWithKey'. +-- | \(O(\log n)\). Lookup and update. See also 'updateWithKey'. -- The function returns changed value, if it is updated. -- Returns the original key value if the map entry is deleted. -- @@ -1144,7 +1124,7 @@ {-# INLINE updateLookupWithKey #-} #endif --- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. +-- | \(O(\log n)\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. -- 'alter' can be used to insert, delete, or update a value in a 'Map'. -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. -- @@ -1155,6 +1135,8 @@ -- > let f _ = Just "c" -- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")] -- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")] +-- +-- Note that @'adjust' = alter . fmap@. -- See Note: Type of local 'go' function alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a @@ -1180,7 +1162,7 @@ -- Used to choose the appropriate alterF implementation. data AreWeStrict = Strict | Lazy --- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at +-- | \(O(\log n)\). The expression (@'alterF' f k map@) alters the value @x@ at -- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete, -- or update a value in a 'Map'. In short: @'lookup' k \<$\> 'alterF' f k m = f -- ('lookup' k m)@. @@ -1236,14 +1218,12 @@ "alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)) . alterF f k = \m -> Const . getConst . f $ lookup k m #-} -#if MIN_VERSION_base(4,8,0) -- base 4.8 and above include Data.Functor.Identity, so we can -- save a pretty decent amount of time by handling it specially. {-# RULES "alterF/Identity" forall k f . alterF f k = atKeyIdentity k f #-} #endif -#endif atKeyImpl :: (Functor f, Ord k) => AreWeStrict -> k -> (Maybe a -> f (Maybe a)) -> Map k a -> f (Map k a) @@ -1297,10 +1277,7 @@ GT -> (go $! q `snocQB` True) k r EQ -> TraceResult (Just x) (buildQ q) --- GHC 7.8 doesn't manage to unbox the queue properly --- unless we explicitly inline this function. This stuff --- is a bit touchy, unfortunately. -#if __GLASGOW_HASKELL__ >= 710 +#ifdef __GLASGOW_HASKELL__ {-# INLINABLE lookupTrace #-} #else {-# INLINE lookupTrace #-} @@ -1370,7 +1347,7 @@ Just (True,tl) -> Bin sz ky y l (replaceAlong tl x r) Nothing -> Bin sz ky x l r -#if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0) +#ifdef __GLASGOW_HASKELL__ atKeyIdentity :: Ord k => k -> (Maybe a -> Identity (Maybe a)) -> Map k a -> Identity (Map k a) atKeyIdentity k f t = Identity $ atKeyPlain Lazy k (coerce f) t {-# INLINABLE atKeyIdentity #-} @@ -1445,7 +1422,7 @@ {-------------------------------------------------------------------- Indexing --------------------------------------------------------------------} --- | /O(log n)/. Return the /index/ of a key, which is its zero-based index in +-- | \(O(\log n)\). Return the /index/ of a key, which is its zero-based index in -- the sequence sorted by keys. The index is a number from /0/ up to, but not -- including, the 'size' of the map. Calls 'error' when the key is not -- a 'member' of the map. @@ -1469,7 +1446,7 @@ {-# INLINABLE findIndex #-} #endif --- | /O(log n)/. Lookup the /index/ of a key, which is its zero-based index in +-- | \(O(\log n)\). Lookup the /index/ of a key, which is its zero-based index in -- the sequence sorted by keys. The index is a number from /0/ up to, but not -- including, the 'size' of the map. -- @@ -1492,7 +1469,7 @@ {-# INLINABLE lookupIndex #-} #endif --- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based +-- | \(O(\log n)\). Retrieve an element by its /index/, i.e. by its zero-based -- index in the sequence sorted by keys. If the /index/ is out of range (less -- than zero, greater or equal to 'size' of the map), 'error' is called. -- @@ -1553,7 +1530,7 @@ EQ -> insertMin kx x r where sizeL = size l --- | /O(log n)/. Split a map at a particular index. +-- | \(O(\log n)\). Split a map at a particular index. -- -- @ -- splitAt !n !xs = ('take' n xs, 'drop' n xs) @@ -1576,7 +1553,7 @@ EQ -> l :*: insertMin kx x r where sizeL = size l --- | /O(log n)/. Update the element at /index/, i.e. by its zero-based index in +-- | \(O(\log n)\). Update the element at /index/, i.e. by its zero-based index in -- the sequence sorted by keys. If the /index/ is out of range (less than zero, -- greater or equal to 'size' of the map), 'error' is called. -- @@ -1602,7 +1579,7 @@ where sizeL = size l --- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in +-- | \(O(\log n)\). Delete the element at /index/, i.e. by its zero-based index in -- the sequence sorted by keys. If the /index/ is out of range (less than zero, -- greater or equal to 'size' of the map), 'error' is called. -- @@ -1631,7 +1608,7 @@ lookupMinSure k a Tip = (k, a) lookupMinSure _ _ (Bin _ k a l _) = lookupMinSure k a l --- | /O(log n)/. The minimal key of the map. Returns 'Nothing' if the map is empty. +-- | \(O(\log n)\). The minimal key of the map. Returns 'Nothing' if the map is empty. -- -- > lookupMin (fromList [(5,"a"), (3,"b")]) == Just (3,"b") -- > lookupMin empty = Nothing @@ -1642,7 +1619,7 @@ lookupMin Tip = Nothing lookupMin (Bin _ k x l _) = Just $! lookupMinSure k x l --- | /O(log n)/. The minimal key of the map. Calls 'error' if the map is empty. +-- | \(O(\log n)\). The minimal key of the map. Calls 'error' if the map is empty. -- -- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b") -- > findMin empty Error: empty map has no minimal element @@ -1652,7 +1629,7 @@ | Just r <- lookupMin t = r | otherwise = error "Map.findMin: empty map has no minimal element" --- | /O(log n)/. The maximal key of the map. Calls 'error' if the map is empty. +-- | \(O(\log n)\). The maximal key of the map. Calls 'error' if the map is empty. -- -- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a") -- > findMax empty Error: empty map has no maximal element @@ -1661,7 +1638,7 @@ lookupMaxSure k a Tip = (k, a) lookupMaxSure _ _ (Bin _ k a _ r) = lookupMaxSure k a r --- | /O(log n)/. The maximal key of the map. Returns 'Nothing' if the map is empty. +-- | \(O(\log n)\). The maximal key of the map. Returns 'Nothing' if the map is empty. -- -- > lookupMax (fromList [(5,"a"), (3,"b")]) == Just (5,"a") -- > lookupMax empty = Nothing @@ -1677,7 +1654,7 @@ | Just r <- lookupMax t = r | otherwise = error "Map.findMax: empty map has no maximal element" --- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty. +-- | \(O(\log n)\). Delete the minimal key. Returns an empty map if the map is empty. -- -- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")] -- > deleteMin empty == empty @@ -1687,7 +1664,7 @@ deleteMin (Bin _ kx x l r) = balanceR kx x (deleteMin l) r deleteMin Tip = Tip --- | /O(log n)/. Delete the maximal key. Returns an empty map if the map is empty. +-- | \(O(\log n)\). Delete the maximal key. Returns an empty map if the map is empty. -- -- > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")] -- > deleteMax empty == empty @@ -1697,7 +1674,7 @@ deleteMax (Bin _ kx x l r) = balanceL kx x l (deleteMax r) deleteMax Tip = Tip --- | /O(log n)/. Update the value at the minimal key. +-- | \(O(\log n)\). Update the value at the minimal key. -- -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" @@ -1706,7 +1683,7 @@ updateMin f m = updateMinWithKey (\_ x -> f x) m --- | /O(log n)/. Update the value at the maximal key. +-- | \(O(\log n)\). Update the value at the maximal key. -- -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" @@ -1716,7 +1693,7 @@ = updateMaxWithKey (\_ x -> f x) m --- | /O(log n)/. Update the value at the minimal key. +-- | \(O(\log n)\). Update the value at the minimal key. -- -- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" @@ -1728,7 +1705,7 @@ Just x' -> Bin sx kx x' Tip r updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r --- | /O(log n)/. Update the value at the maximal key. +-- | \(O(\log n)\). Update the value at the maximal key. -- -- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" @@ -1740,7 +1717,7 @@ Just x' -> Bin sx kx x' l Tip updateMaxWithKey f (Bin _ kx x l r) = balanceL kx x l (updateMaxWithKey f r) --- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and +-- | \(O(\log n)\). Retrieves the minimal (key,value) pair of the map, and -- the map stripped of that element, or 'Nothing' if passed an empty map. -- -- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a") @@ -1756,7 +1733,7 @@ -- the Just. {-# INLINE minViewWithKey #-} --- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and +-- | \(O(\log n)\). Retrieves the maximal (key,value) pair of the map, and -- the map stripped of that element, or 'Nothing' if passed an empty map. -- -- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b") @@ -1770,7 +1747,7 @@ -- See note on inlining at minViewWithKey {-# INLINE maxViewWithKey #-} --- | /O(log n)/. Retrieves the value associated with minimal key of the +-- | \(O(\log n)\). Retrieves the value associated with minimal key of the -- map, and the map stripped of that element, or 'Nothing' if passed an -- empty map. -- @@ -1782,7 +1759,7 @@ Nothing -> Nothing Just ~((_, x), t') -> Just (x, t') --- | /O(log n)/. Retrieves the value associated with maximal key of the +-- | \(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. -- @@ -1825,7 +1802,7 @@ {-# INLINABLE unionsWith #-} #endif --- | /O(m*log(n\/m + 1)), m <= n/. +-- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. -- It prefers @t1@ when duplicate keys are encountered, -- i.e. (@'union' == 'unionWith' 'const'@). @@ -1849,7 +1826,7 @@ {-------------------------------------------------------------------- Union with a combining function --------------------------------------------------------------------} --- | /O(m*log(n\/m + 1)), m <= n/. Union with a combining function. +-- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Union with a combining function. -- -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] @@ -1869,7 +1846,7 @@ {-# INLINABLE unionWith #-} #endif --- | /O(m*log(n\/m + 1)), m <= n/. +-- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). -- Union with a combining function. -- -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value @@ -1900,7 +1877,7 @@ -- relies on doing it the way we do, and it's not clear whether that -- bound holds the other way. --- | /O(m*log(n\/m + 1)), m <= n/. Difference of two maps. +-- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Difference of two maps. -- Return elements of the first map not existing in the second map. -- -- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b" @@ -1919,7 +1896,7 @@ {-# INLINABLE difference #-} #endif --- | /O(m*log(n\/m + 1)), m <= n/. Remove all keys in a 'Set' from a 'Map'. +-- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Remove all keys in a 'Set' from a 'Map'. -- -- @ -- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``Set.notMember`` s) m @@ -1942,7 +1919,7 @@ {-# INLINABLE withoutKeys #-} #endif --- | /O(n+m)/. Difference with a combining function. +-- | \(O(n+m)\). Difference with a combining function. -- When two equal keys are -- encountered, the combining function is applied to the values of these keys. -- If it returns 'Nothing', the element is discarded (proper set difference). If @@ -1958,7 +1935,7 @@ {-# INLINABLE differenceWith #-} #endif --- | /O(n+m)/. Difference with a combining function. When two equal keys are +-- | \(O(n+m)\). Difference with a combining function. When two equal keys are -- encountered, the combining function is applied to the key and both values. -- If it returns 'Nothing', the element is discarded (proper set difference). If -- it returns (@'Just' y@), the element is updated with a new value @y@. @@ -1978,7 +1955,7 @@ {-------------------------------------------------------------------- Intersection --------------------------------------------------------------------} --- | /O(m*log(n\/m + 1)), m <= n/. Intersection of two maps. +-- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Intersection of two maps. -- Return data in the first map for the keys existing in both maps. -- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@). -- @@ -2000,7 +1977,7 @@ {-# INLINABLE intersection #-} #endif --- | /O(m*log(n\/m + 1)), m <= n/. Restrict a 'Map' to only those keys +-- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Restrict a 'Map' to only those keys -- found in a 'Set'. -- -- @ @@ -2025,7 +2002,7 @@ {-# INLINABLE restrictKeys #-} #endif --- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function. +-- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Intersection with a combining function. -- -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" @@ -2045,7 +2022,7 @@ {-# INLINABLE intersectionWith #-} #endif --- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function. +-- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Intersection with a combining function. -- -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" @@ -2067,7 +2044,7 @@ {-------------------------------------------------------------------- Disjoint --------------------------------------------------------------------} --- | /O(m*log(n\/m + 1)), m <= n/. Check whether the key sets of two +-- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Check whether the key sets of two -- maps are disjoint (i.e., their 'intersection' is empty). -- -- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())]) == True @@ -2116,24 +2093,6 @@ | null bc = empty | otherwise = mapMaybe (bc !?) ab -#if !MIN_VERSION_base (4,8,0) --- | The identity type. -newtype Identity a = Identity { runIdentity :: a } -#if __GLASGOW_HASKELL__ == 708 -instance Functor Identity where - fmap = coerce -instance Applicative Identity where - (<*>) = coerce - pure = Identity -#else -instance Functor Identity where - fmap f (Identity a) = Identity (f a) -instance Applicative Identity where - Identity f <*> Identity x = Identity (f x) - pure = Identity -#endif -#endif - -- | A tactic for dealing with keys present in one map but not the other in -- 'merge' or 'mergeA'. -- @@ -2180,9 +2139,6 @@ -- -- @since 0.5.9 instance (Applicative f, Monad f) => Monad (WhenMissing f k x) where -#if !MIN_VERSION_base(4,8,0) - return = pure -#endif m >>= f = traverseMaybeMissing $ \k x -> do res1 <- missingKey m k x case res1 of @@ -2318,9 +2274,6 @@ -- -- @since 0.5.9 instance (Monad f, Applicative f) => Monad (WhenMatched f k x y) where -#if !MIN_VERSION_base(4,8,0) - return = pure -#endif m >>= f = zipWithMaybeAMatched $ \k x y -> do res <- runWhenMatched m k x y case res of @@ -2732,7 +2685,7 @@ MergeWithKey --------------------------------------------------------------------} --- | /O(n+m)/. An unsafe general combining function. +-- | \(O(n+m)\). An unsafe general combining function. -- -- WARNING: This function can produce corrupt maps and its results -- may depend on the internal structures of its inputs. Users should @@ -2792,7 +2745,7 @@ {-------------------------------------------------------------------- Submap --------------------------------------------------------------------} --- | /O(m*log(n\/m + 1)), m <= n/. +-- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). -- isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool @@ -2801,7 +2754,7 @@ {-# INLINABLE isSubmapOf #-} #endif -{- | /O(m*log(n\/m + 1)), m <= n/. +{- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when applied to their respective values. For example, the following @@ -2850,7 +2803,7 @@ {-# INLINABLE submap' #-} #endif --- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap but not equal). +-- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Is this a proper submap? (ie. a submap but not equal). -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@). isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool isProperSubmapOf m1 m2 @@ -2859,7 +2812,7 @@ {-# INLINABLE isProperSubmapOf #-} #endif -{- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap but not equal). +{- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Is this a proper submap? (ie. a submap but not equal). The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when @keys m1@ and @keys m2@ are not equal, all keys in @m1@ are in @m2@, and when @f@ returns 'True' when @@ -2887,7 +2840,7 @@ {-------------------------------------------------------------------- Filter and partition --------------------------------------------------------------------} --- | /O(n)/. Filter all values that satisfy the predicate. +-- | \(O(n)\). Filter all values that satisfy the predicate. -- -- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" -- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty @@ -2897,7 +2850,7 @@ filter p m = filterWithKey (\_ x -> p x) m --- | /O(n)/. Filter all keys\/values that satisfy the predicate. +-- | \(O(n)\). Filter all keys\/values that satisfy the predicate. -- -- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" @@ -2911,7 +2864,7 @@ where !pl = filterWithKey p l !pr = filterWithKey p r --- | /O(n)/. Filter keys and values using an 'Applicative' +-- | \(O(n)\). Filter keys and values using an 'Applicative' -- predicate. filterWithKeyA :: Applicative f => (k -> a -> f Bool) -> Map k a -> f (Map k a) filterWithKeyA _ Tip = pure Tip @@ -2923,7 +2876,7 @@ | otherwise = link kx x pl pr combine False pl pr = link2 pl pr --- | /O(log n)/. Take while a predicate on the keys holds. +-- | \(O(\log n)\). Take while a predicate on the keys holds. -- The user is responsible for ensuring that for all keys @j@ and @k@ in the map, -- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'. -- @@ -2940,7 +2893,7 @@ | p kx = link kx x l (takeWhileAntitone p r) | otherwise = takeWhileAntitone p l --- | /O(log n)/. Drop while a predicate on the keys holds. +-- | \(O(\log n)\). Drop while a predicate on the keys holds. -- The user is responsible for ensuring that for all keys @j@ and @k@ in the map, -- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'. -- @@ -2957,7 +2910,7 @@ | p kx = dropWhileAntitone p r | otherwise = link kx x (dropWhileAntitone p l) r --- | /O(log n)/. Divide a map at the point where a predicate on the keys stops holding. +-- | \(O(\log n)\). Divide a map at the point where a predicate on the keys stops holding. -- The user is responsible for ensuring that for all keys @j@ and @k@ in the map, -- @j \< k ==\> p j \>= p k@. -- @@ -2981,7 +2934,7 @@ | p kx = let u :*: v = go p r in link kx x l u :*: v | otherwise = let u :*: v = go p l in u :*: link kx x v r --- | /O(n)/. Partition the map according to a predicate. The first +-- | \(O(n)\). Partition the map according to a predicate. The first -- map contains all elements that satisfy the predicate, the second all -- elements that fail the predicate. See also 'split'. -- @@ -2993,7 +2946,7 @@ partition p m = partitionWithKey (\_ x -> p x) m --- | /O(n)/. Partition the map according to a predicate. The first +-- | \(O(n)\). Partition the map according to a predicate. The first -- map contains all elements that satisfy the predicate, the second all -- elements that fail the predicate. See also 'split'. -- @@ -3017,7 +2970,7 @@ (l1 :*: l2) = go p l (r1 :*: r2) = go p r --- | /O(n)/. Map values and collect the 'Just' results. +-- | \(O(n)\). Map values and collect the 'Just' results. -- -- > let f x = if x == "a" then Just "new a" else Nothing -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" @@ -3025,7 +2978,7 @@ mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b mapMaybe f = mapMaybeWithKey (\_ x -> f x) --- | /O(n)/. Map keys\/values and collect the 'Just' results. +-- | \(O(n)\). Map keys\/values and collect the 'Just' results. -- -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" @@ -3036,7 +2989,7 @@ Just y -> link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r) Nothing -> link2 (mapMaybeWithKey f l) (mapMaybeWithKey f r) --- | /O(n)/. Traverse keys\/values and collect the 'Just' results. +-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results. -- -- @since 0.5.8 traverseMaybeWithKey :: Applicative f @@ -3051,7 +3004,7 @@ Nothing -> link2 l' r' Just x' -> link kx x' l' r' --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. +-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. -- -- > let f a = if a < "c" then Left a else Right a -- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) @@ -3064,7 +3017,7 @@ mapEither f m = mapEitherWithKey (\_ x -> f x) m --- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. +-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results. -- -- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) -- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) @@ -3087,7 +3040,7 @@ {-------------------------------------------------------------------- Mapping --------------------------------------------------------------------} --- | /O(n)/. Map a function over all values in the map. +-- | \(O(n)\). Map a function over all values in the map. -- -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] @@ -3103,16 +3056,11 @@ {-# 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. +-- | \(O(n)\). Map a function over all values in the map. -- -- > let f key x = (show key) ++ ":" ++ x -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] @@ -3133,7 +3081,7 @@ #-} #endif --- | /O(n)/. +-- | \(O(n)\). -- @'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. @@ -3148,7 +3096,7 @@ go (Bin s k v l r) = liftA3 (flip (Bin s k)) (go l) (f k v) (go r) {-# INLINE traverseWithKey #-} --- | /O(n)/. The function 'mapAccum' threads an accumulating +-- | \(O(n)\). The function 'mapAccum' threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a b = (a ++ b, b ++ "X") @@ -3158,7 +3106,7 @@ mapAccum f a m = mapAccumWithKey (\a' _ x' -> f a' x') a m --- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating +-- | \(O(n)\). The function 'mapAccumWithKey' threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") @@ -3168,7 +3116,7 @@ mapAccumWithKey f a t = mapAccumL f a t --- | /O(n)/. The function 'mapAccumL' threads an accumulating +-- | \(O(n)\). The function 'mapAccumL' threads an accumulating -- argument through the map in ascending order of keys. mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccumL _ a Tip = (a,Tip) @@ -3178,7 +3126,7 @@ (a3,r') = mapAccumL f a2 r in (a3,Bin sx kx x' l' r') --- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating +-- | \(O(n)\). The function 'mapAccumRWithKey' threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccumRWithKey _ a Tip = (a,Tip) @@ -3188,7 +3136,7 @@ (a3,l') = mapAccumRWithKey f a2 l in (a3,Bin sx kx x' l' r') --- | /O(n*log n)/. +-- | \(O(n \log n)\). -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. -- -- The size of the result may be smaller if @f@ maps two or more distinct @@ -3205,7 +3153,7 @@ {-# INLINABLE mapKeys #-} #endif --- | /O(n*log n)/. +-- | \(O(n \log n)\). -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. -- -- The size of the result may be smaller if @f@ maps two or more distinct @@ -3223,7 +3171,7 @@ #endif --- | /O(n)/. +-- | \(O(n)\). -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ -- is strictly monotonic. -- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. @@ -3250,7 +3198,7 @@ Folds --------------------------------------------------------------------} --- | /O(n)/. Fold the values in the map using the given right-associative +-- | \(O(n)\). Fold the values in the map using the given right-associative -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. -- -- For example, @@ -3266,17 +3214,17 @@ go z' (Bin _ _ x l r) = go (f x (go z' r)) l {-# INLINE foldr #-} --- | /O(n)/. A strict version of 'foldr'. Each application of the operator is +-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. foldr' :: (a -> b -> b) -> b -> Map k a -> b foldr' f z = go z where - go !z' Tip = z' - go z' (Bin _ _ x l r) = go (f x (go z' r)) l + go !z' Tip = z' + go z' (Bin _ _ x l r) = go (f x $! go z' r) l {-# INLINE foldr' #-} --- | /O(n)/. Fold the values in the map using the given left-associative +-- | \(O(n)\). Fold the values in the map using the given left-associative -- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@. -- -- For example, @@ -3292,17 +3240,19 @@ go z' (Bin _ _ x l r) = go (f (go z' l) x) r {-# INLINE foldl #-} --- | /O(n)/. A strict version of 'foldl'. Each application of the operator is +-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. foldl' :: (a -> b -> a) -> a -> Map k b -> a foldl' f z = go z where - go !z' Tip = z' - go z' (Bin _ _ x l r) = go (f (go z' l) x) r + go !z' Tip = z' + go z' (Bin _ _ x l r) = + let !z'' = go z' l + in go (f z'' x) r {-# INLINE foldl' #-} --- | /O(n)/. Fold the keys and values in the map using the given right-associative +-- | \(O(n)\). Fold the keys and values in the map using the given right-associative -- binary operator, such that -- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. -- @@ -3319,17 +3269,17 @@ go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l {-# INLINE foldrWithKey #-} --- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is +-- | \(O(n)\). A strict version of 'foldrWithKey'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b foldrWithKey' f z = go z where go !z' Tip = z' - go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l + go z' (Bin _ kx x l r) = go (f kx x $! go z' r) l {-# INLINE foldrWithKey' #-} --- | /O(n)/. Fold the keys and values in the map using the given left-associative +-- | \(O(n)\). Fold the keys and values in the map using the given left-associative -- binary operator, such that -- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@. -- @@ -3346,17 +3296,19 @@ go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r {-# INLINE foldlWithKey #-} --- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is +-- | \(O(n)\). A strict version of 'foldlWithKey'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a foldlWithKey' f z = go z where - go !z' Tip = z' - go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r + go !z' Tip = z' + go z' (Bin _ kx x l r) = + let !z'' = go z' l + in go (f z'' kx x) r {-# INLINE foldlWithKey' #-} --- | /O(n)/. Fold the keys and values in the map using the given monoid, such that +-- | \(O(n)\). Fold the keys and values in the map using the given monoid, such that -- -- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@ -- @@ -3374,7 +3326,7 @@ {-------------------------------------------------------------------- List variations --------------------------------------------------------------------} --- | /O(n)/. +-- | \(O(n)\). -- Return all elements of the map in the ascending order of their keys. -- Subject to list fusion. -- @@ -3384,7 +3336,7 @@ elems :: Map k a -> [a] elems = foldr (:) [] --- | /O(n)/. Return all keys of the map in ascending order. Subject to list +-- | \(O(n)\). Return all keys of the map in ascending order. Subject to list -- fusion. -- -- > keys (fromList [(5,"a"), (3,"b")]) == [3,5] @@ -3393,7 +3345,7 @@ keys :: Map k a -> [k] keys = foldrWithKey (\k _ ks -> k : ks) [] --- | /O(n)/. An alias for 'toAscList'. Return all key\/value pairs in the map +-- | \(O(n)\). An alias for 'toAscList'. Return all key\/value pairs in the map -- in ascending key order. Subject to list fusion. -- -- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] @@ -3403,7 +3355,7 @@ assocs m = toAscList m --- | /O(n)/. The set of all keys of the map. +-- | \(O(n)\). The set of all keys of the map. -- -- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5] -- > keysSet empty == Data.Set.empty @@ -3412,7 +3364,16 @@ keysSet Tip = Set.Tip keysSet (Bin sz kx _ l r) = Set.Bin sz kx (keysSet l) (keysSet r) --- | /O(n)/. Build a map from a set of keys and a function which for each key +-- | \(O(n)\). The set of all elements of the map contained in 'Arg's. +-- +-- > argSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [Arg 3 "b",Arg 5 "a"] +-- > argSet empty == Data.Set.empty + +argSet :: Map k a -> Set.Set (Arg k a) +argSet Tip = Set.Tip +argSet (Bin sz kx x l r) = Set.Bin sz (Arg kx x) (argSet l) (argSet r) + +-- | \(O(n)\). Build a map from a set of keys and a function which for each key -- computes its value. -- -- > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] @@ -3422,10 +3383,20 @@ fromSet _ Set.Tip = Tip fromSet f (Set.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r) +-- | /O(n)/. Build a map from a set of elements contained inside 'Arg's. +-- +-- > fromArgSet (Data.Set.fromList [Arg 3 "aaa", Arg 5 "aaaaa"]) == fromList [(5,"aaaaa"), (3,"aaa")] +-- > fromArgSet Data.Set.empty == empty + +fromArgSet :: Set.Set (Arg k a) -> Map k a +fromArgSet Set.Tip = Tip +fromArgSet (Set.Bin sz (Arg x v) l r) = Bin sz x v (fromArgSet l) (fromArgSet r) + {-------------------------------------------------------------------- Lists --------------------------------------------------------------------} -#if __GLASGOW_HASKELL__ >= 708 + +#ifdef __GLASGOW_HASKELL__ -- | @since 0.5.6.2 instance (Ord k) => GHCExts.IsList (Map k v) where type Item (Map k v) = (k,v) @@ -3433,7 +3404,7 @@ toList = toList #endif --- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'. +-- | \(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. -- @@ -3485,7 +3456,7 @@ {-# INLINABLE fromList #-} #endif --- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +-- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. -- -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] -- > fromListWith (++) [] == empty @@ -3497,7 +3468,7 @@ {-# INLINABLE fromListWith #-} #endif --- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'. +-- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'. -- -- > let f k a1 a2 = (show k) ++ a1 ++ a2 -- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")] @@ -3512,7 +3483,7 @@ {-# INLINABLE fromListWithKey #-} #endif --- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list fusion. +-- | \(O(n)\). Convert the map to a list of key\/value pairs. Subject to list fusion. -- -- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] -- > toList empty == [] @@ -3520,7 +3491,7 @@ toList :: Map k a -> [(k,a)] toList = toAscList --- | /O(n)/. Convert the map to a list of key\/value pairs where the keys are +-- | \(O(n)\). Convert the map to a list of key\/value pairs where the keys are -- in ascending order. Subject to list fusion. -- -- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] @@ -3528,7 +3499,7 @@ toAscList :: Map k a -> [(k,a)] toAscList = foldrWithKey (\k x xs -> (k,x):xs) [] --- | /O(n)/. Convert the map to a list of key\/value pairs where the keys +-- | \(O(n)\). Convert the map to a list of key\/value pairs where the keys -- are in descending order. Subject to list fusion. -- -- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")] @@ -3578,7 +3549,7 @@ fromAscList xs == fromList xs fromAscListWith f xs == fromListWith f xs --------------------------------------------------------------------} --- | /O(n)/. Build a map from an ascending list in linear time. +-- | \(O(n)\). Build a map from an ascending list in linear time. -- /The precondition (input list is ascending) is not checked./ -- -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] @@ -3605,7 +3576,7 @@ {-# INLINABLE fromAscList #-} #endif --- | /O(n)/. Build a map from a descending list in linear time. +-- | \(O(n)\). Build a map from a descending list in linear time. -- /The precondition (input list is descending) is not checked./ -- -- > fromDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")] @@ -3633,7 +3604,7 @@ {-# INLINABLE fromDescList #-} #endif --- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. +-- | \(O(n)\). Build a map from an ascending list in linear time with a combining function for equal keys. -- /The precondition (input list is ascending) is not checked./ -- -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] @@ -3647,7 +3618,7 @@ {-# INLINABLE fromAscListWith #-} #endif --- | /O(n)/. Build a map from a descending list in linear time with a combining function for equal keys. +-- | \(O(n)\). Build a map from a descending list in linear time with a combining function for equal keys. -- /The precondition (input list is descending) is not checked./ -- -- > fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "ba")] @@ -3663,7 +3634,7 @@ {-# INLINABLE fromDescListWith #-} #endif --- | /O(n)/. Build a map from an ascending list in linear time with a +-- | \(O(n)\). Build a map from an ascending list in linear time with a -- combining function for equal keys. -- /The precondition (input list is ascending) is not checked./ -- @@ -3691,7 +3662,7 @@ {-# INLINABLE fromAscListWithKey #-} #endif --- | /O(n)/. Build a map from a descending list in linear time with a +-- | \(O(n)\). Build a map from a descending list in linear time with a -- combining function for equal keys. -- /The precondition (input list is descending) is not checked./ -- @@ -3719,7 +3690,7 @@ #endif --- | /O(n)/. Build a map from an ascending list of distinct elements in linear time. +-- | \(O(n)\). Build a map from an ascending list of distinct elements in linear time. -- /The precondition is not checked./ -- -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] @@ -3745,7 +3716,7 @@ (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of (r :*: zs) -> (link ky y l r :*: zs) --- | /O(n)/. Build a map from a descending list of distinct elements in linear time. +-- | \(O(n)\). Build a map from a descending list of distinct elements in linear time. -- /The precondition is not checked./ -- -- > fromDistinctDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")] @@ -3808,7 +3779,7 @@ {-------------------------------------------------------------------- Split --------------------------------------------------------------------} --- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where +-- | \(O(\log n)\). The expression (@'split' k map@) is a pair @(map1,map2)@ where -- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@. -- Any key equal to @k@ is found in neither @map1@ nor @map2@. -- @@ -3832,7 +3803,7 @@ {-# INLINABLE split #-} #endif --- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just +-- | \(O(\log n)\). The expression (@'splitLookup' k map@) splits a map just -- like 'split' but also returns @'lookup' k map@. -- -- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")]) @@ -3977,7 +3948,7 @@ MaxView km xm r' -> MaxView km xm (balanceL k x l r') {-# NOINLINE maxViewSure #-} --- | /O(log n)/. Delete and find the minimal element. +-- | \(O(\log n)\). Delete and find the minimal element. -- -- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")]) -- > deleteFindMin empty Error: can not return the minimal element of an empty map @@ -3987,7 +3958,7 @@ Nothing -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip) Just res -> res --- | /O(log n)/. Delete and find the maximal element. +-- | \(O(\log n)\). Delete and find the maximal element. -- -- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")]) -- > deleteFindMax empty Error: can not return the maximal element of an empty map @@ -4177,7 +4148,6 @@ instance (Ord k, Ord v) => Ord (Map k v) where compare m1 m2 = compare (toAscList m1) (toAscList m2) -#if MIN_VERSION_base(4,9,0) {-------------------------------------------------------------------- Lifted instances --------------------------------------------------------------------} @@ -4219,7 +4189,6 @@ where rp' = liftReadsPrec rp rl rl' = liftReadList rp rl -#endif {-------------------------------------------------------------------- Functor @@ -4256,7 +4225,6 @@ {-# INLINE foldl' #-} foldr' = foldr' {-# INLINE foldr' #-} -#if MIN_VERSION_base(4,8,0) length = size {-# INLINE length #-} null = null @@ -4285,7 +4253,6 @@ {-# INLINABLE sum #-} product = foldl' (*) 1 {-# INLINABLE product #-} -#endif #if MIN_VERSION_base(4,10,0) -- | @since 0.6.3.1 @@ -4340,16 +4307,10 @@ showString "fromList " . shows (toList m) {-------------------------------------------------------------------- - Typeable ---------------------------------------------------------------------} - -INSTANCE_TYPEABLE2(Map) - -{-------------------------------------------------------------------- Utilities --------------------------------------------------------------------} --- | /O(1)/. Decompose a map into pieces based on the structure of the underlying +-- | \(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. -- -- No guarantee is made as to the sizes of the pieces; an internal, but diff --git a/src/Data/Strict/Map/Autogen/Internal/Debug.hs b/src/Data/Strict/Map/Autogen/Internal/Debug.hs --- a/src/Data/Strict/Map/Autogen/Internal/Debug.hs +++ b/src/Data/Strict/Map/Autogen/Internal/Debug.hs @@ -6,7 +6,7 @@ import Data.Strict.Map.Autogen.Internal (Map (..), size, delta) import Control.Monad (guard) --- | /O(n)/. Show the tree that implements the map. The tree is shown +-- | \(O(n)\). Show the tree that implements the map. The tree is shown -- in a compressed, hanging format. See 'showTreeWith'. showTree :: (Show k,Show a) => Map k a -> String showTree m @@ -15,7 +15,7 @@ showElem k x = show k ++ ":=" ++ show x -{- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows +{- | \(O(n)\). The expression (@'showTreeWith' showelem hang wide map@) shows the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If @wide@ is 'True', an extra wide version is shown. @@ -103,7 +103,7 @@ {-------------------------------------------------------------------- Assertions --------------------------------------------------------------------} --- | /O(n)/. Test if the internal map structure is valid. +-- | \(O(n)\). Test if the internal map structure is valid. -- -- > valid (fromAscList [(3,"b"), (5,"a")]) == True -- > valid (fromAscList [(5,"a"), (3,"b")]) == False diff --git a/src/Data/Strict/Map/Autogen/Merge/Strict.hs b/src/Data/Strict/Map/Autogen/Merge/Strict.hs --- a/src/Data/Strict/Map/Autogen/Merge/Strict.hs +++ b/src/Data/Strict/Map/Autogen/Merge/Strict.hs @@ -1,19 +1,6 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -#if __GLASGOW_HASKELL__ -{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} -#endif -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) +#if defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TypeFamilies #-} -#define USE_MAGIC_PROXY 1 -#endif - -#if USE_MAGIC_PROXY -{-# LANGUAGE MagicHash #-} #endif #include "containers.h" diff --git a/src/Data/Strict/Map/Autogen/Strict.hs b/src/Data/Strict/Map/Autogen/Strict.hs --- a/src/Data/Strict/Map/Autogen/Strict.hs +++ b/src/Data/Strict/Map/Autogen/Strict.hs @@ -55,7 +55,7 @@ -- -- == Detailed performance information -- --- The amortized running time is given for each operation, with /n/ referring to +-- The amortized running time is given for each operation, with \(n\) referring to -- the number of entries in the map. -- -- Benchmarks comparing "Data.Strict.Map.Autogen.Strict" with other dictionary implementations @@ -108,6 +108,7 @@ , empty , singleton , fromSet + , fromArgSet -- ** From Unordered Lists , fromList @@ -223,6 +224,7 @@ , keys , assocs , keysSet + , argSet -- ** Lists , toList diff --git a/src/Data/Strict/Map/Autogen/Strict/Internal.hs b/src/Data/Strict/Map/Autogen/Strict/Internal.hs --- a/src/Data/Strict/Map/Autogen/Strict/Internal.hs +++ b/src/Data/Strict/Map/Autogen/Strict/Internal.hs @@ -226,7 +226,9 @@ , keys , assocs , keysSet + , argSet , fromSet + , fromArgSet -- ** Lists , toList @@ -299,7 +301,7 @@ , maxViewWithKey -- * Debugging -#if defined(__GLASGOW_HASKELL__) +#ifdef __GLASGOW_HASKELL__ , showTree , showTreeWith #endif @@ -327,11 +329,10 @@ , (!) , (!?) , (\\) + , argSet , assocs , atKeyImpl -#if MIN_VERSION_base(4,8,0) , atKeyPlain -#endif , balance , balanceL , balanceR @@ -415,26 +416,21 @@ import Data.Strict.Map.Autogen.Internal.Debug (valid) import Control.Applicative (Const (..), liftA3) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative (..), (<$>)) -#endif +import Data.Semigroup (Arg (..)) import qualified Data.Set.Internal as Set import qualified Data.Strict.Map.Autogen.Internal as L import Data.Strict.ContainersUtils.Autogen.StrictPair import Data.Bits (shiftL, shiftR) -#if __GLASGOW_HASKELL__ >= 709 +#ifdef __GLASGOW_HASKELL__ import Data.Coerce #endif -#if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0) +#ifdef __GLASGOW_HASKELL__ import Data.Functor.Identity (Identity (..)) #endif import qualified Data.Foldable as Foldable -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable (Foldable()) -#endif -- $strictness -- @@ -469,7 +465,7 @@ Query --------------------------------------------------------------------} --- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns +-- | \(O(\log n)\). The expression @('findWithDefault' def k map)@ returns -- the value at key @k@ or returns default value @def@ -- when the key is not in the map. -- @@ -495,7 +491,7 @@ Construction --------------------------------------------------------------------} --- | /O(1)/. A map with a single element. +-- | \(O(1)\). A map with a single element. -- -- > singleton 1 'a' == fromList [(1, 'a')] -- > size (singleton 1 'a') == 1 @@ -507,7 +503,7 @@ {-------------------------------------------------------------------- Insertion --------------------------------------------------------------------} --- | /O(log n)/. Insert a new key and value in the map. +-- | \(O(\log n)\). Insert a new key and value in the map. -- If the key is already present in the map, the associated value is -- replaced with the supplied value. 'insert' is equivalent to -- @'insertWith' 'const'@. @@ -533,7 +529,7 @@ {-# INLINE insert #-} #endif --- | /O(log n)/. Insert with a function, combining new value and old value. +-- | \(O(\log n)\). Insert with a function, combining new value and old value. -- @'insertWith' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does -- not exist in the map. If the key does exist, the function will @@ -575,7 +571,7 @@ {-# INLINE insertWithR #-} #endif --- | /O(log n)/. Insert with a function, combining key, new value and old value. +-- | \(O(\log n)\). Insert with a function, combining key, new value and old value. -- @'insertWithKey' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does -- not exist in the map. If the key does exist, the function will @@ -626,7 +622,7 @@ {-# INLINE insertWithKeyR #-} #endif --- | /O(log n)/. Combines insert operation with old value retrieval. +-- | \(O(\log n)\). Combines insert operation with old value retrieval. -- The expression (@'insertLookupWithKey' f k x map@) -- is a pair where the first element is equal to (@'lookup' k map@) -- and the second element equal to (@'insertWithKey' f k x map@). @@ -667,7 +663,7 @@ Deletion --------------------------------------------------------------------} --- | /O(log n)/. Update a value at a specific key with the result of the provided function. +-- | \(O(\log n)\). Update a value at a specific key with the result of the provided function. -- When the key is not -- a member of the map, the original map is returned. -- @@ -683,7 +679,7 @@ {-# INLINE adjust #-} #endif --- | /O(log n)/. Adjust a value at a specific key. When the key is not +-- | \(O(\log n)\). Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. -- -- > let f key x = (show key) ++ ":new " ++ x @@ -708,7 +704,7 @@ {-# INLINE adjustWithKey #-} #endif --- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ +-- | \(O(\log n)\). The expression (@'update' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. -- @@ -725,7 +721,7 @@ {-# INLINE update #-} #endif --- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the +-- | \(O(\log n)\). The expression (@'updateWithKey' f k map@) updates the -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound -- to the new value @y@. @@ -754,7 +750,7 @@ {-# INLINE updateWithKey #-} #endif --- | /O(log n)/. Lookup and update. See also 'updateWithKey'. +-- | \(O(\log n)\). Lookup and update. See also 'updateWithKey'. -- The function returns changed value, if it is updated. -- Returns the original key value if the map entry is deleted. -- @@ -784,7 +780,7 @@ {-# INLINE updateLookupWithKey #-} #endif --- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. +-- | \(O(\log n)\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. -- 'alter' can be used to insert, delete, or update a value in a 'Map'. -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. -- @@ -795,6 +791,8 @@ -- > let f _ = Just "c" -- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")] -- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")] +-- +-- Note that @'adjust' = alter . fmap@. -- See Map.Internal.Note: Type of local 'go' function alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a @@ -817,7 +815,7 @@ {-# INLINE alter #-} #endif --- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at @k@, or absence thereof. +-- | \(O(\log n)\). The expression (@'alterF' f k map@) alters the value @x@ at @k@, or absence thereof. -- 'alterF' can be used to inspect, insert, delete, or update a value in a 'Map'. -- In short: @'lookup' k \<$\> 'alterF' f k m = f ('lookup' k m)@. -- @@ -870,11 +868,6 @@ -- `Control.Applicative.Const` and just doing a lookup. {-# RULES "alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)) . alterF f k = \m -> Const . getConst . f $ lookup k m - #-} -#if MIN_VERSION_base(4,8,0) --- base 4.8 and above include Data.Functor.Identity, so we can --- save a pretty decent amount of time by handling it specially. -{-# RULES "alterF/Identity" forall k f . alterF f k = atKeyIdentity k f #-} @@ -882,13 +875,12 @@ atKeyIdentity k f t = Identity $ atKeyPlain Strict k (coerce f) t {-# INLINABLE atKeyIdentity #-} #endif -#endif {-------------------------------------------------------------------- Indexing --------------------------------------------------------------------} --- | /O(log n)/. Update the element at /index/. Calls 'error' when an +-- | \(O(\log n)\). Update the element at /index/. Calls 'error' when an -- invalid index is used. -- -- > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")] @@ -917,7 +909,7 @@ Minimal, Maximal --------------------------------------------------------------------} --- | /O(log n)/. Update the value at the minimal key. +-- | \(O(\log n)\). Update the value at the minimal key. -- -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" @@ -926,7 +918,7 @@ updateMin f m = updateMinWithKey (\_ x -> f x) m --- | /O(log n)/. Update the value at the maximal key. +-- | \(O(\log n)\). Update the value at the maximal key. -- -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" @@ -936,7 +928,7 @@ = updateMaxWithKey (\_ x -> f x) m --- | /O(log n)/. Update the value at the minimal key. +-- | \(O(\log n)\). Update the value at the minimal key. -- -- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" @@ -948,7 +940,7 @@ Just x' -> x' `seq` Bin sx kx x' Tip r updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r --- | /O(log n)/. Update the value at the maximal key. +-- | \(O(\log n)\). Update the value at the maximal key. -- -- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" @@ -980,7 +972,7 @@ {-------------------------------------------------------------------- Union with a combining function --------------------------------------------------------------------} --- | /O(m*log(n\/m + 1)), m <= n/. Union with a combining function. +-- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Union with a combining function. -- -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] @@ -996,7 +988,7 @@ {-# INLINABLE unionWith #-} #endif --- | /O(m*log(n\/m + 1)), m <= n/. +-- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). -- Union with a combining function. -- -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value @@ -1018,7 +1010,7 @@ Difference --------------------------------------------------------------------} --- | /O(n+m)/. Difference with a combining function. +-- | \(O(n+m)\). Difference with a combining function. -- When two equal keys are -- encountered, the combining function is applied to the values of these keys. -- If it returns 'Nothing', the element is discarded (proper set difference). If @@ -1034,7 +1026,7 @@ {-# INLINABLE differenceWith #-} #endif --- | /O(n+m)/. Difference with a combining function. When two equal keys are +-- | \(O(n+m)\). Difference with a combining function. When two equal keys are -- encountered, the combining function is applied to the key and both values. -- If it returns 'Nothing', the element is discarded (proper set difference). If -- it returns (@'Just' y@), the element is updated with a new value @y@. @@ -1054,7 +1046,7 @@ Intersection --------------------------------------------------------------------} --- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function. +-- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Intersection with a combining function. -- -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" @@ -1072,7 +1064,7 @@ {-# INLINABLE intersectionWith #-} #endif --- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function. +-- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Intersection with a combining function. -- -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" @@ -1210,7 +1202,7 @@ MergeWithKey --------------------------------------------------------------------} --- | /O(n+m)/. An unsafe universal combining function. +-- | \(O(n+m)\). An unsafe universal combining function. -- -- WARNING: This function can produce corrupt maps and its results -- may depend on the internal structures of its inputs. Users should @@ -1272,7 +1264,7 @@ Filter and partition --------------------------------------------------------------------} --- | /O(n)/. Map values and collect the 'Just' results. +-- | \(O(n)\). Map values and collect the 'Just' results. -- -- > let f x = if x == "a" then Just "new a" else Nothing -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" @@ -1280,7 +1272,7 @@ mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b mapMaybe f = mapMaybeWithKey (\_ x -> f x) --- | /O(n)/. Map keys\/values and collect the 'Just' results. +-- | \(O(n)\). Map keys\/values and collect the 'Just' results. -- -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" @@ -1291,7 +1283,7 @@ Just y -> y `seq` link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r) Nothing -> link2 (mapMaybeWithKey f l) (mapMaybeWithKey f r) --- | /O(n)/. Traverse keys\/values and collect the 'Just' results. +-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results. -- -- @since 0.5.8 @@ -1307,7 +1299,7 @@ Nothing -> link2 l' r' Just !x' -> link kx x' l' r' --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. +-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. -- -- > let f a = if a < "c" then Left a else Right a -- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) @@ -1320,7 +1312,7 @@ mapEither f m = mapEitherWithKey (\_ x -> f x) m --- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. +-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results. -- -- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) -- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) @@ -1343,7 +1335,7 @@ {-------------------------------------------------------------------- Mapping --------------------------------------------------------------------} --- | /O(n)/. Map a function over all values in the map. +-- | \(O(n)\). Map a function over all values in the map. -- -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] @@ -1363,7 +1355,7 @@ #-} #endif --- | /O(n)/. Map a function over all values in the map. +-- | \(O(n)\). Map a function over all values in the map. -- -- > let f key x = (show key) ++ ":" ++ x -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] @@ -1392,7 +1384,7 @@ #-} #endif --- | /O(n)/. +-- | \(O(n)\). -- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (\v' -> v' \`seq\` (k,v')) <$> f k v) ('toList' m)@ -- That is, it behaves much like a regular 'traverse' except that the traversing -- function also has access to the key associated with a value and the values are @@ -1408,7 +1400,7 @@ go (Bin s k v l r) = liftA3 (\ l' !v' r' -> Bin s k v' l' r') (go l) (f k v) (go r) {-# INLINE traverseWithKey #-} --- | /O(n)/. The function 'mapAccum' threads an accumulating +-- | \(O(n)\). The function 'mapAccum' threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a b = (a ++ b, b ++ "X") @@ -1418,7 +1410,7 @@ mapAccum f a m = mapAccumWithKey (\a' _ x' -> f a' x') a m --- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating +-- | \(O(n)\). The function 'mapAccumWithKey' threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") @@ -1428,7 +1420,7 @@ mapAccumWithKey f a t = mapAccumL f a t --- | /O(n)/. The function 'mapAccumL' threads an accumulating +-- | \(O(n)\). The function 'mapAccumL' threads an accumulating -- argument through the map in ascending order of keys. mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccumL _ a Tip = (a,Tip) @@ -1438,7 +1430,7 @@ (a3,r') = mapAccumL f a2 r in x' `seq` (a3,Bin sx kx x' l' r') --- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating +-- | \(O(n)\). The function 'mapAccumRWithKey' threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccumRWithKey _ a Tip = (a,Tip) @@ -1448,7 +1440,7 @@ (a3,l') = mapAccumRWithKey f a2 l in x' `seq` (a3,Bin sx kx x' l' r') --- | /O(n*log n)/. +-- | \(O(n \log n)\). -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. -- -- The size of the result may be smaller if @f@ maps two or more distinct @@ -1469,7 +1461,7 @@ Conversions --------------------------------------------------------------------} --- | /O(n)/. Build a map from a set of keys and a function which for each key +-- | \(O(n)\). Build a map from a set of keys and a function which for each key -- computes its value. -- -- > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] @@ -1479,10 +1471,19 @@ fromSet _ Set.Tip = Tip fromSet f (Set.Bin sz x l r) = case f x of v -> v `seq` Bin sz x v (fromSet f l) (fromSet f r) +-- | /O(n)/. Build a map from a set of elements contained inside 'Arg's. +-- +-- > fromArgSet (Data.Set.fromList [Arg 3 "aaa", Arg 5 "aaaaa"]) == fromList [(5,"aaaaa"), (3,"aaa")] +-- > fromArgSet Data.Set.empty == empty + +fromArgSet :: Set.Set (Arg k a) -> Map k a +fromArgSet Set.Tip = Tip +fromArgSet (Set.Bin sz (Arg x v) l r) = v `seq` Bin sz x v (fromArgSet l) (fromArgSet r) + {-------------------------------------------------------------------- Lists --------------------------------------------------------------------} --- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'. +-- | \(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. -- @@ -1534,7 +1535,7 @@ {-# INLINABLE fromList #-} #endif --- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +-- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. -- -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] -- > fromListWith (++) [] == empty @@ -1546,7 +1547,7 @@ {-# INLINABLE fromListWith #-} #endif --- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'. +-- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'. -- -- > let f k a1 a2 = (show k) ++ a1 ++ a2 -- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")] @@ -1573,7 +1574,7 @@ fromDescListWith f xs == fromListWith f xs --------------------------------------------------------------------} --- | /O(n)/. Build a map from an ascending list in linear time. +-- | \(O(n)\). Build a map from an ascending list in linear time. -- /The precondition (input list is ascending) is not checked./ -- -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] @@ -1587,7 +1588,7 @@ {-# INLINABLE fromAscList #-} #endif --- | /O(n)/. Build a map from a descending list in linear time. +-- | \(O(n)\). Build a map from a descending list in linear time. -- /The precondition (input list is descending) is not checked./ -- -- > fromDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")] @@ -1601,7 +1602,7 @@ {-# INLINABLE fromDescList #-} #endif --- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. +-- | \(O(n)\). Build a map from an ascending list in linear time with a combining function for equal keys. -- /The precondition (input list is ascending) is not checked./ -- -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] @@ -1615,7 +1616,7 @@ {-# INLINABLE fromAscListWith #-} #endif --- | /O(n)/. Build a map from a descending list in linear time with a combining function for equal keys. +-- | \(O(n)\). Build a map from a descending list in linear time with a combining function for equal keys. -- /The precondition (input list is descending) is not checked./ -- -- > fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "ba")] @@ -1629,7 +1630,7 @@ {-# INLINABLE fromDescListWith #-} #endif --- | /O(n)/. Build a map from an ascending list in linear time with a +-- | \(O(n)\). Build a map from an ascending list in linear time with a -- combining function for equal keys. -- /The precondition (input list is ascending) is not checked./ -- @@ -1657,7 +1658,7 @@ {-# INLINABLE fromAscListWithKey #-} #endif --- | /O(n)/. Build a map from a descending list in linear time with a +-- | \(O(n)\). Build a map from a descending list in linear time with a -- combining function for equal keys. -- /The precondition (input list is descending) is not checked./ -- @@ -1685,7 +1686,7 @@ {-# INLINABLE fromDescListWithKey #-} #endif --- | /O(n)/. Build a map from an ascending list of distinct elements in linear time. +-- | \(O(n)\). Build a map from an ascending list of distinct elements in linear time. -- /The precondition is not checked./ -- -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] @@ -1712,7 +1713,7 @@ (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of (r :*: zs) -> y `seq` (link ky y l r :*: zs) --- | /O(n)/. Build a map from a descending list of distinct elements in linear time. +-- | \(O(n)\). Build a map from a descending list of distinct elements in linear time. -- /The precondition is not checked./ -- -- > fromDistinctDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")] diff --git a/src/Data/Strict/Sequence.hs b/src/Data/Strict/Sequence.hs --- a/src/Data/Strict/Sequence.hs +++ b/src/Data/Strict/Sequence.hs @@ -10,6 +10,33 @@ The documentation in the auto-generated modules have not been updated in a particularly sophisticated way, so may sound weird or contradictory. In those cases, please re-interpret such weird wording in the context of the above. + +== Detailed note on laziness + +'Seq' uses internal laziness for performance; and our data structure preserves +this laziness and performance in a way that retains the strictness of values. +For technical details, see the source code of our patch. As a user of the data +structure, what you need to know is that: + +* Strictness is guaranteed when constructing containers - values added to a + container are evaluated /before/ the new, larger, container itself is + evaluated. + +* Laziness and performance applies when splitting or combining existing + containers, whose values have already been evaluated as per the previous + point. + +== Bugs + +One known bug, is that whole-container transforms (such as @fmap@) are not +entirely strict, since they make use of the lazy behaviour above to avoid doing +work that is unnecessary (in the lazy case) to a large part of the data +structure. This is possible to fix, by re-implementing all such transforms so +that they force the lazy parts as well; we just haven't gotten around to it +yet. (This would revert the performance back to @O(n)@, but this is unavoidable +since all such transforms on strict data structures must inherently evaluate +every single element.) + -} module Data.Strict.Sequence ( module Data.Strict.Sequence.Autogen diff --git a/src/Data/Strict/Sequence/Autogen.hs b/src/Data/Strict/Sequence/Autogen.hs --- a/src/Data/Strict/Sequence/Autogen.hs +++ b/src/Data/Strict/Sequence/Autogen.hs @@ -78,7 +78,7 @@ -- -- == Detailed performance information -- --- An amortized running time is given for each operation, with /n/ referring +-- An amortized running time is given for each operation, with \(n\) referring -- to the length of the sequence and /i/ being the integral index used by -- some operations. These bounds hold even in a persistent (shared) setting. -- @@ -296,7 +296,7 @@ shift2Right :: Seq a -> Seq a -> (Seq a, Seq a) shift2Right Empty ys = (Empty, ys) shift2Right (Empty :|> x) ys = (Empty, x :<| ys) -shift2Right (xs :|> x1 :|> x2) = (xs, x1 :<| x2 :<| ys) +shift2Right (xs :|> x1 :|> x2) ys = (xs, x1 :<| x2 :<| ys) @ @ diff --git a/src/Data/Strict/Sequence/Autogen/Internal.hs b/src/Data/Strict/Sequence/Autogen/Internal.hs --- a/src/Data/Strict/Sequence/Autogen/Internal.hs +++ b/src/Data/Strict/Sequence/Autogen/Internal.hs @@ -4,11 +4,14 @@ #if __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} #endif #ifdef DEFINE_PATTERN_SYNONYMS {-# LANGUAGE PatternSynonyms #-} @@ -17,6 +20,7 @@ {-# LANGUAGE PatternGuards #-} {-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- | @@ -192,13 +196,10 @@ #if MIN_VERSION_base(4,11,0) (<>), #endif -#if MIN_VERSION_base(4,8,0) Applicative, (<$>), foldMap, Monoid, -#endif null, length, lookup, take, drop, splitAt, foldl, foldl1, foldr, foldr1, scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3, unzip, takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all) -import qualified Data.List import Control.Applicative (Applicative(..), (<$>), (<**>), Alternative, liftA2, liftA3) import qualified Control.Applicative as Applicative @@ -208,13 +209,11 @@ import Data.Functor (Functor(..)) import Data.Strict.ContainersUtils.Autogen.State (State(..), execState) import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, foldl', foldr'), toList) +import qualified Data.Foldable as F -#if MIN_VERSION_base(4,9,0) import qualified Data.Semigroup as Semigroup import Data.Functor.Classes -#endif import Data.Traversable -import Data.Typeable -- GHC specific stuff #ifdef __GLASGOW_HASKELL__ @@ -223,8 +222,7 @@ readPrec, readListPrec, readListPrecDefault) import Data.Data import Data.String (IsString(..)) -#endif -#if __GLASGOW_HASKELL__ +import qualified Language.Haskell.TH.Syntax as TH import GHC.Generics (Generic, Generic1) #endif @@ -236,22 +234,11 @@ #endif import Data.Strict.ContainersUtils.Autogen.Coercions ((.#), (.^#)) --- 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 -#if !MIN_VERSION_base(4,8,0) -import Data.Word (Word) -#endif - import Data.Strict.ContainersUtils.Autogen.StrictPair (StrictPair (..), toPair) import Control.Monad.Zip (MonadZip (..)) import Control.Monad.Fix (MonadFix (..), fix) @@ -350,6 +337,41 @@ -- | General-purpose finite sequences. newtype Seq a = Seq (FingerTree (Elem a)) +#ifdef __GLASGOW_HASKELL__ +-- | @since FIXME +instance TH.Lift a => TH.Lift (Seq a) where +# if MIN_VERSION_template_haskell(2,16,0) + liftTyped t = [|| coerceFT z ||] +# else + lift t = [| coerceFT z |] +# endif + where + -- We rebalance the sequence to use only 3-nodes before lifting its + -- underlying finger tree. This should minimize the size and depth of the + -- tree generated at run-time. It also reduces the size of the splice, + -- but I don't know how that affects the size of the resulting Core once + -- all the types are added. + Seq ft = zipWith (flip const) (replicate (length t) ()) t + + -- We remove the 'Elem' constructors to reduce the size of the splice + -- and the number of types and coercions in the generated Core. Instead + -- of, say, + -- + -- Seq (Deep 3 (Two (Elem 1) (Elem 2)) EmptyT (One (Elem 3))) + -- + -- we generate + -- + -- coerceFT (Deep 3 (Two 1 2)) EmptyT (One 3) + z :: FingerTree a + z = coerce ft + +-- | We use this to help the types work out for splices in the +-- Lift instance. Things get a bit yucky otherwise. +coerceFT :: FingerTree a -> Seq a +coerceFT = coerce + +#endif + instance Functor Seq where fmap = fmapSeq #ifdef __GLASGOW_HASKELL__ @@ -362,11 +384,6 @@ {-# 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 @@ -399,12 +416,10 @@ 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 #-} -#endif instance Traversable Seq where #if __GLASGOW_HASKELL__ @@ -456,7 +471,7 @@ (\a' b' c' d' -> Four (Elem a') (Elem b') (Elem c') (Elem d')) (f a) (f b) - (f c) <*> + (f c) <*> (f d) traverseDigitN :: Applicative f @@ -520,7 +535,7 @@ EmptyR -> fmap firstf xs Seq fs''FT :> lastf -> case rigidify xsFT of RigidEmpty -> empty - RigidOne (Elem x) -> fmap ($x) fs + 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) -> @@ -592,7 +607,7 @@ (fmap (fmap (f lastx)) (nodeToDigit sf)) where lift_elem :: (a -> b -> c) -> a -> Elem b -> Elem c -#if __GLASGOW_HASKELL__ >= 708 +#ifdef __GLASGOW_HASKELL__ lift_elem = coerce #else lift_elem f x (Elem y) = Elem (f x y) @@ -774,8 +789,8 @@ 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 +-- | \(O(mn)\) (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 -- @FingerTree (Elem a)@, it applies the function to elements of type @Elem -- a@), replacing the leaves with subtrees of at least the same height, e.g., @@ -790,7 +805,7 @@ 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) --- | /O(log n)/ (incremental) Takes the extra flexibility out of a 'FingerTree' +-- | \(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. If the tree has fewer than four elements, 'rigidify' @@ -820,7 +835,7 @@ 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 +-- | \(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) @@ -837,7 +852,7 @@ 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 +-- | \(O(\log n)\) (incremental) Rejigger a finger tree so the digits are all ones -- and twos. thin :: Sized a => FingerTree a -> Thin a -- Note that 'thin12' will produce a 'DeepTh' constructor immediately before @@ -905,7 +920,6 @@ showString "fromList " . shows (toList xs) #endif -#if MIN_VERSION_base(4,9,0) -- | @since 0.5.9 instance Show1 Seq where liftShowsPrec _shwsPrc shwList p xs = showParen (p > 10) $ @@ -918,7 +932,6 @@ -- | @since 0.5.9 instance Ord1 Seq where liftCompare cmp xs ys = liftCompare cmp (toList xs) (toList ys) -#endif instance Read a => Read (Seq a) where #ifdef __GLASGOW_HASKELL__ @@ -935,32 +948,22 @@ return (fromList xs,t) #endif -#if MIN_VERSION_base(4,9,0) -- | @since 0.5.9 instance Read1 Seq where liftReadsPrec _rp readLst p = readParen (p > 10) $ \r -> do ("fromList",s) <- lex r (xs,t) <- readLst s pure (fromList xs, t) -#endif instance Monoid (Seq a) where mempty = empty -#if MIN_VERSION_base(4,9,0) mappend = (Semigroup.<>) -#else - mappend = (><) -#endif -#if MIN_VERSION_base(4,9,0) -- | @since 0.5.7 instance Semigroup.Semigroup (Seq a) where (<>) = (><) stimes = cycleNTimes . fromIntegral -#endif -INSTANCE_TYPEABLE1(Seq) - #if __GLASGOW_HASKELL__ instance Data a => Data (Seq a) where gfoldl f z s = case viewl s of @@ -1004,6 +1007,8 @@ -- | @since 0.6.1 deriving instance Generic (FingerTree a) + +deriving instance TH.Lift a => TH.Lift (FingerTree a) #endif instance Sized a => Sized (FingerTree a) where @@ -1016,7 +1021,7 @@ instance Foldable FingerTree where foldMap _ EmptyT = mempty foldMap f' (Single x') = f' x' - foldMap f' (Deep _ pr' m' sf') = + foldMap f' (Deep _ pr' m' sf') = foldMapDigit f' pr' <> foldMapTree (foldMapNode f') m' <> foldMapDigit f' sf' @@ -1024,7 +1029,7 @@ foldMapTree :: Monoid m => (Node a -> m) -> FingerTree (Node a) -> m foldMapTree _ EmptyT = mempty foldMapTree f (Single x) = f x - foldMapTree f (Deep _ pr m sf) = + foldMapTree f (Deep _ pr m sf) = foldMapDigitN f pr <> foldMapTree (foldMapNodeN f) m <> foldMapDigitN f sf @@ -1195,6 +1200,8 @@ -- | @since 0.6.1 deriving instance Generic (Digit a) + +deriving instance TH.Lift a => TH.Lift (Digit a) #endif foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b @@ -1296,6 +1303,8 @@ -- | @since 0.6.1 deriving instance Generic (Node a) + +deriving instance TH.Lift a => TH.Lift (Node a) #endif foldNode :: (b -> b -> b) -> (a -> b) -> Node a -> b @@ -1371,7 +1380,7 @@ size _ = 1 instance Functor Elem where -#if __GLASGOW_HASKELL__ >= 708 +#ifdef __GLASGOW_HASKELL__ -- This cuts the time for <*> by around a fifth. fmap = coerce #else @@ -1380,7 +1389,7 @@ instance Foldable Elem where foldr f z (Elem x) = f x z -#if __GLASGOW_HASKELL__ >= 708 +#ifdef __GLASGOW_HASKELL__ foldMap = coerce foldl = coerce foldl' = coerce @@ -1399,17 +1408,7 @@ ------------------------------------------------------- -- Applicative construction ------------------------------------------------------- -#if !MIN_VERSION_base(4,8,0) -newtype Identity a = Identity {runIdentity :: a} -instance Functor Identity where - fmap f (Identity x) = Identity (f x) - -instance Applicative Identity where - pure = Identity - Identity f <*> Identity x = Identity (f x) -#endif - -- | '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 @@ -1418,7 +1417,7 @@ {-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-} {-# 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)/. +-- 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 = case n of 0 -> pure EmptyT @@ -1709,17 +1708,10 @@ -- -- For @base >= 4.8.0@ and @containers >= 0.5.11@, 'replicateM' -- is a synonym for 'replicateA'. -#if MIN_VERSION_base(4,8,0) replicateM :: Applicative m => Int -> m a -> m (Seq a) replicateM = replicateA -#else -replicateM :: Monad m => Int -> m a -> m (Seq a) -replicateM n x - | n >= 0 = Applicative.unwrapMonad (replicateA n (Applicative.WrapMonad x)) - | otherwise = error "replicateM takes a nonnegative integer argument" -#endif --- | /O(/log/ k)/. @'cycleTaking' k xs@ forms a sequence of length @k@ by +-- | \(O(\log k)\). @'cycleTaking' k xs@ forms a sequence of length @k@ by -- repeatedly concatenating @xs@ with itself. @xs@ may only be empty if -- @k@ is 0. -- @@ -2178,9 +2170,10 @@ -- | @since 0.5.8 deriving instance Generic (ViewL a) -#endif -INSTANCE_TYPEABLE1(ViewL) +-- | @since FIXME +deriving instance TH.Lift a => TH.Lift (ViewL a) +#endif instance Functor ViewL where {-# INLINE fmap #-} @@ -2188,6 +2181,9 @@ fmap f (x :< xs) = f x :< fmap f xs instance Foldable ViewL where + foldMap _ EmptyL = mempty + foldMap f (x :< xs) = f x <> foldMap f xs + foldr _ z EmptyL = z foldr f z (x :< xs) = f x (foldr f z xs) @@ -2197,13 +2193,11 @@ foldl1 _ EmptyL = error "foldl1: empty view" foldl1 f (x :< xs) = foldl f x xs -#if MIN_VERSION_base(4,8,0) null EmptyL = True null (_ :< _) = False length EmptyL = 0 length (_ :< xs) = 1 + length xs -#endif instance Traversable ViewL where traverse _ EmptyL = pure EmptyL @@ -2243,9 +2237,10 @@ -- | @since 0.5.8 deriving instance Generic (ViewR a) -#endif -INSTANCE_TYPEABLE1(ViewR) +-- | @since FIXME +deriving instance TH.Lift a => TH.Lift (ViewR a) +#endif instance Functor ViewR where {-# INLINE fmap #-} @@ -2264,13 +2259,12 @@ foldr1 _ EmptyR = error "foldr1: empty view" foldr1 f (xs :> x) = foldr f x xs -#if MIN_VERSION_base(4,8,0) + null EmptyR = True null (_ :> _) = False length EmptyR = 0 length (xs :> _) = length xs + 1 -#endif instance Traversable ViewR where traverse _ EmptyR = pure EmptyR @@ -2351,7 +2345,7 @@ -- See note on unsigned arithmetic in splitAt | fromIntegral i < (fromIntegral (size xs) :: Word) = case lookupTree i xs of Place _ (Elem x) -> x - | otherwise = + | otherwise = error $ "index out of bounds in call to: Data.Strict.Sequence.Autogen.index " ++ show i -- | \( O(\log(\min(i,n-i))) \). The element at the specified position, @@ -2528,7 +2522,7 @@ -- -- @since 0.5.8 adjust :: forall a . (a -> a) -> Int -> Seq a -> Seq a -#if __GLASGOW_HASKELL__ >= 708 +#ifdef __GLASGOW_HASKELL__ adjust f i xs -- See note on unsigned arithmetic in splitAt | fromIntegral i < (fromIntegral (length xs) :: Word) = @@ -3136,7 +3130,7 @@ foldMapWithIndex f' (Seq xs') = foldMapWithIndexTreeE (lift_elem f') 0 xs' where lift_elem :: (Int -> a -> m) -> (Int -> Elem a -> m) -#if __GLASGOW_HASKELL__ >= 708 +#ifdef __GLASGOW_HASKELL__ lift_elem g = coerce g #else lift_elem g = \s (Elem a) -> g s a @@ -3333,7 +3327,7 @@ {-# INLINE mb #-} lift_elem :: (Int -> a) -> (Int -> Elem a) -#if __GLASGOW_HASKELL__ >= 708 +#ifdef __GLASGOW_HASKELL__ lift_elem g = coerce g #else lift_elem g = Elem . g @@ -3350,8 +3344,8 @@ #ifdef __GLASGOW_HASKELL__ fromArray a = fromFunction (GHC.Arr.numElements a) (GHC.Arr.unsafeAt a) where - -- The following definition uses (Ix i) constraing, which is needed for the - -- other fromArray definition. + -- The following definition uses an (Ix i) constraint, which is needed for + -- the other fromArray definition. _ = Data.Array.rangeSize (Data.Array.bounds a) #else fromArray a = fromList2 (Data.Array.rangeSize (Data.Array.bounds a)) (Data.Array.elems a) @@ -4368,7 +4362,7 @@ !n10 = Node3 (3*s) n1 n2 n3 map_elem :: [a] -> [Elem a] -#if __GLASGOW_HASKELL__ >= 708 +#ifdef __GLASGOW_HASKELL__ map_elem xs = coerce xs #else map_elem xs = Data.List.map Elem xs @@ -4378,7 +4372,7 @@ -- essentially: Free ((,) a) b. data ListFinal a cont = LFinal !cont | LCons !a (ListFinal a cont) -#if __GLASGOW_HASKELL__ >= 708 +#ifdef __GLASGOW_HASKELL__ instance GHC.Exts.IsList (Seq a) where type Item (Seq a) = a fromList = fromList @@ -4409,7 +4403,7 @@ fmapReverse f (Seq xs) = Seq (fmapReverseTree (lift_elem f) xs) where lift_elem :: (a -> b) -> (Elem a -> Elem b) -#if __GLASGOW_HASKELL__ >= 708 +#ifdef __GLASGOW_HASKELL__ lift_elem = coerce #else lift_elem g (Elem a) = Elem (g a) @@ -4737,7 +4731,7 @@ -- This instance is only used at the very top of the tree; -- the rest of the elements are handled by unzipWithNodeElem instance UnzipWith Elem where -#if __GLASGOW_HASKELL__ >= 708 +#ifdef __GLASGOW_HASKELL__ unzipWith' = coerce #else unzipWith' f (Elem a) = case f a of (x, y) -> (Elem x, Elem y) diff --git a/src/Data/Strict/Vector/Autogen.hs b/src/Data/Strict/Vector/Autogen.hs --- a/src/Data/Strict/Vector/Autogen.hs +++ b/src/Data/Strict/Vector/Autogen.hs @@ -1,18 +1,20 @@ -{-# LANGUAGE CPP - , DeriveDataTypeable - , FlexibleInstances - , MultiParamTypeClasses - , TypeFamilies - , Rank2Types - , BangPatterns - #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.Strict.Vector.Autogen -- Copyright : (c) Roman Leshchinskiy 2008-2010 +-- Alexey Kuleshevich 2020-2022 +-- Aleksey Khudyakov 2020-2022 +-- Andrew Lelechenko 2020-2022 -- License : BSD-style -- --- Maintainer : Roman Leshchinskiy +-- Maintainer : Haskell Libraries Team -- Stability : experimental -- Portability : non-portable -- @@ -23,11 +25,10 @@ -- -- * immutable -- --- and support a rich interface of both list-like operations, and bulk +-- They support a rich interface of both list-like operations and bulk -- array operations. -- --- For unboxed arrays, use "Data.Strict.Vector.Autogen.Unboxed" --- +-- For unboxed arrays, use "Data.Strict.Vector.Autogen.Unboxed". module Data.Strict.Vector.Autogen ( -- * Boxed vectors @@ -121,7 +122,7 @@ takeWhile, dropWhile, -- ** Partitioning - partition, unstablePartition, partitionWith, span, break, + partition, unstablePartition, partitionWith, span, break, groupBy, group, -- ** Searching elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, @@ -134,7 +135,8 @@ -- ** Specialised folds all, any, and, or, sum, product, - maximum, maximumBy, minimum, minimumBy, + maximum, maximumBy, maximumOn, + minimum, minimumBy, minimumOn, minIndex, minIndexBy, maxIndex, maxIndexBy, -- ** Monadic folds @@ -145,7 +147,7 @@ -- ** Monadic sequencing sequence, sequence_, - -- * Prefix sums (scans) + -- * Scans prescanl, prescanl', postscanl, postscanl', scanl, scanl', scanl1, scanl1', @@ -164,7 +166,7 @@ toList, Data.Strict.Vector.Autogen.fromList, Data.Strict.Vector.Autogen.fromListN, -- ** Arrays - fromArray, toArray, + toArray, fromArray, toArraySlice, unsafeFromArraySlice, -- ** Other vector types G.convert, @@ -200,19 +202,13 @@ zipWith, zipWith3, zip, zip3, unzip, unzip3, filter, takeWhile, dropWhile, span, break, elem, notElem, - foldl, foldl1, foldr, foldr1, -#if __GLASGOW_HASKELL__ >= 706 - foldMap, -#endif + foldl, foldl1, foldr, foldr1, foldMap, all, any, and, or, sum, product, minimum, maximum, scanl, scanl1, scanr, scanr1, enumFromTo, enumFromThenTo, mapM, mapM_, sequence, sequence_ ) -#if MIN_VERSION_base(4,9,0) import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..)) -#endif - import Data.Typeable ( Typeable ) import Data.Data ( Data(..) ) import Text.Read ( Read(..), readListPrecDefault ) @@ -222,17 +218,13 @@ import qualified Data.Foldable as Foldable import qualified Data.Traversable as Traversable -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid ( Monoid(..) ) -#endif - -#if __GLASGOW_HASKELL__ >= 708 import qualified GHC.Exts as Exts (IsList(..)) -#endif -- | Boxed vectors, supporting efficient slicing. -data Vector a = Vector {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !(Array a) +data Vector a = Vector {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + {-# UNPACK #-} !(Array a) deriving ( Typeable ) liftRnfV :: (a -> ()) -> Vector a -> () @@ -256,22 +248,17 @@ readPrec = G.readPrec readListPrec = readListPrecDefault -#if MIN_VERSION_base(4,9,0) instance Show1 Vector where liftShowsPrec = G.liftShowsPrec instance Read1 Vector where liftReadsPrec = G.liftReadsPrec -#endif -#if __GLASGOW_HASKELL__ >= 708 - instance Exts.IsList (Vector a) where type Item (Vector a) = a fromList = Data.Strict.Vector.Autogen.fromList fromListN = Data.Strict.Vector.Autogen.fromListN toList = toList -#endif instance Data a => Data (Vector a) where gfoldl = G.gfoldl @@ -312,9 +299,6 @@ {-# INLINE (==) #-} xs == ys = Bundle.eq (G.stream xs) (G.stream ys) - {-# INLINE (/=) #-} - xs /= ys = not (Bundle.eq (G.stream xs) (G.stream ys)) - -- See http://trac.haskell.org/vector/ticket/12 instance Ord a => Ord (Vector a) where {-# INLINE compare #-} @@ -332,13 +316,11 @@ {-# INLINE (>=) #-} xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT -#if MIN_VERSION_base(4,9,0) instance Eq1 Vector where liftEq eq xs ys = Bundle.eqBy eq (G.stream xs) (G.stream ys) instance Ord1 Vector where liftCompare cmp xs ys = Bundle.cmpBy cmp (G.stream xs) (G.stream ys) -#endif instance Semigroup (Vector a) where {-# INLINE (<>) #-} @@ -352,7 +334,7 @@ mempty = empty {-# INLINE mappend #-} - mappend = (++) + mappend = (<>) {-# INLINE mconcat #-} mconcat = concat @@ -361,10 +343,8 @@ {-# INLINE fmap #-} fmap = map -#if MIN_VERSION_base(4,8,0) {-# INLINE (<$) #-} (<$) = map . const -#endif instance Monad Vector where {-# INLINE return #-} @@ -400,7 +380,7 @@ {-# INLINE munzip #-} munzip = unzip --- | Instance has same semantics as one for lists +-- | This instance has the same semantics as the one for lists. -- -- @since 0.12.2.0 instance MonadFix Vector where @@ -451,15 +431,12 @@ {-# INLINE foldl1 #-} foldl1 = foldl1 -#if MIN_VERSION_base(4,6,0) {-# INLINE foldr' #-} foldr' = foldr' {-# INLINE foldl' #-} foldl' = foldl' -#endif -#if MIN_VERSION_base(4,8,0) {-# INLINE toList #-} toList = toList @@ -483,7 +460,6 @@ {-# INLINE product #-} product = product -#endif instance Traversable.Traversable Vector where {-# INLINE traverse #-} @@ -503,12 +479,12 @@ -- Length information -- ------------------ --- | /O(1)/ Yield the length of the vector +-- | /O(1)/ Yield the length of the vector. length :: Vector a -> Int {-# INLINE length #-} length = G.length --- | /O(1)/ Test whether a vector is empty +-- | /O(1)/ Test whether a vector is empty. null :: Vector a -> Bool {-# INLINE null #-} null = G.null @@ -516,37 +492,37 @@ -- Indexing -- -------- --- | O(1) Indexing +-- | O(1) Indexing. (!) :: Vector a -> Int -> a {-# INLINE (!) #-} (!) = (G.!) --- | O(1) Safe indexing +-- | O(1) Safe indexing. (!?) :: Vector a -> Int -> Maybe a {-# INLINE (!?) #-} (!?) = (G.!?) --- | /O(1)/ First element +-- | /O(1)/ First element. head :: Vector a -> a {-# INLINE head #-} head = G.head --- | /O(1)/ Last element +-- | /O(1)/ Last element. last :: Vector a -> a {-# INLINE last #-} last = G.last --- | /O(1)/ Unsafe indexing without bounds checking +-- | /O(1)/ Unsafe indexing without bounds checking. unsafeIndex :: Vector a -> Int -> a {-# INLINE unsafeIndex #-} unsafeIndex = G.unsafeIndex --- | /O(1)/ First element without checking if the vector is empty +-- | /O(1)/ First element, without checking if the vector is empty. unsafeHead :: Vector a -> a {-# INLINE unsafeHead #-} unsafeHead = G.unsafeHead --- | /O(1)/ Last element without checking if the vector is empty +-- | /O(1)/ Last element, without checking if the vector is empty. unsafeLast :: Vector a -> a {-# INLINE unsafeLast #-} unsafeLast = G.unsafeLast @@ -571,8 +547,7 @@ -- > write mv i x -- -- Here, no references to @v@ are retained because indexing (but /not/ the --- elements) is evaluated eagerly. --- +-- element) is evaluated eagerly. indexM :: Monad m => Vector a -> Int -> m a {-# INLINE indexM #-} indexM = G.indexM @@ -589,19 +564,19 @@ {-# INLINE lastM #-} lastM = G.lastM --- | /O(1)/ Indexing in a monad without bounds checks. See 'indexM' for an +-- | /O(1)/ Indexing in a monad, without bounds checks. See 'indexM' for an -- explanation of why this is useful. unsafeIndexM :: Monad m => Vector a -> Int -> m a {-# INLINE unsafeIndexM #-} unsafeIndexM = G.unsafeIndexM --- | /O(1)/ First element in a monad without checking for empty vectors. +-- | /O(1)/ First element in a monad, without checking for empty vectors. -- See 'indexM' for an explanation of why this is useful. unsafeHeadM :: Monad m => Vector a -> m a {-# INLINE unsafeHeadM #-} unsafeHeadM = G.unsafeHeadM --- | /O(1)/ Last element in a monad without checking for empty vectors. +-- | /O(1)/ Last element in a monad, without checking for empty vectors. -- See 'indexM' for an explanation of why this is useful. unsafeLastM :: Monad m => Vector a -> m a {-# INLINE unsafeLastM #-} @@ -632,20 +607,20 @@ tail = G.tail -- | /O(1)/ Yield at the first @n@ elements without copying. The vector may --- contain less than @n@ elements in which case it is returned unchanged. +-- contain less than @n@ elements, in which case it is returned unchanged. take :: Int -> Vector a -> Vector a {-# INLINE take #-} take = G.take -- | /O(1)/ Yield all but the first @n@ elements without copying. The vector may --- contain less than @n@ elements in which case an empty vector is returned. +-- contain less than @n@ elements, in which case an empty vector is returned. drop :: Int -> Vector a -> Vector a {-# INLINE drop #-} drop = G.drop --- | /O(1)/ Yield the first @n@ elements paired with the remainder without copying. +-- | /O(1)/ Yield the first @n@ elements paired with the remainder, without copying. -- --- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@ +-- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@, -- but slightly more efficient. -- -- @since 0.7.1 @@ -653,14 +628,16 @@ {-# INLINE splitAt #-} splitAt = G.splitAt --- | /O(1)/ Yield the 'head' and 'tail' of the vector, or 'Nothing' if empty. +-- | /O(1)/ Yield the 'head' and 'tail' of the vector, or 'Nothing' if +-- the vector is empty. -- -- @since 0.12.2.0 uncons :: Vector a -> Maybe (a, Vector a) {-# INLINE uncons #-} uncons = G.uncons --- | /O(1)/ Yield the 'last' and 'init' of the vector, or 'Nothing' if empty. +-- | /O(1)/ Yield the 'last' and 'init' of the vector, or 'Nothing' if +-- the vector is empty. -- -- @since 0.12.2.0 unsnoc :: Vector a -> Maybe (Vector a, a) @@ -668,7 +645,7 @@ unsnoc = G.unsnoc -- | /O(1)/ Yield a slice of the vector without copying. The vector must --- contain at least @i+n@ elements but this is not checked. +-- contain at least @i+n@ elements, but this is not checked. unsafeSlice :: Int -- ^ @i@ starting index -> Int -- ^ @n@ length -> Vector a @@ -677,25 +654,25 @@ unsafeSlice = G.unsafeSlice -- | /O(1)/ Yield all but the last element without copying. The vector may not --- be empty but this is not checked. +-- be empty, but this is not checked. unsafeInit :: Vector a -> Vector a {-# INLINE unsafeInit #-} unsafeInit = G.unsafeInit -- | /O(1)/ Yield all but the first element without copying. The vector may not --- be empty but this is not checked. +-- be empty, but this is not checked. unsafeTail :: Vector a -> Vector a {-# INLINE unsafeTail #-} unsafeTail = G.unsafeTail -- | /O(1)/ Yield the first @n@ elements without copying. The vector must --- contain at least @n@ elements but this is not checked. +-- contain at least @n@ elements, but this is not checked. unsafeTake :: Int -> Vector a -> Vector a {-# INLINE unsafeTake #-} unsafeTake = G.unsafeTake -- | /O(1)/ Yield all but the first @n@ elements without copying. The vector --- must contain at least @n@ elements but this is not checked. +-- must contain at least @n@ elements, but this is not checked. unsafeDrop :: Int -> Vector a -> Vector a {-# INLINE unsafeDrop #-} unsafeDrop = G.unsafeDrop @@ -703,29 +680,29 @@ -- Initialisation -- -------------- --- | /O(1)/ Empty vector +-- | /O(1)/ The empty vector. empty :: Vector a {-# INLINE empty #-} empty = G.empty --- | /O(1)/ Vector with exactly one element +-- | /O(1)/ A vector with exactly one element. singleton :: a -> Vector a {-# INLINE singleton #-} singleton = G.singleton --- | /O(n)/ Vector of the given length with the same value in each position +-- | /O(n)/ A vector of the given length with the same value in each position. replicate :: Int -> a -> Vector a {-# INLINE replicate #-} replicate = G.replicate -- | /O(n)/ Construct a vector of the given length by applying the function to --- each index +-- each index. generate :: Int -> (Int -> a) -> Vector a {-# INLINE generate #-} generate = G.generate --- | /O(n)/ Apply function \(\max(n - 1, 0)\) times to an initial value, producing a vector --- of length \(\max(n, 0)\). Zeroth element will contain the initial value, that's why there +-- | /O(n)/ Apply the function \(\max(n - 1, 0)\) times to an initial value, producing a vector +-- of length \(\max(n, 0)\). The 0th element will contain the initial value, which is why there -- is one less function application than the number of elements in the produced vector. -- -- \( \underbrace{x, f (x), f (f (x)), \ldots}_{\max(0,n)\rm{~elements}} \) @@ -805,7 +782,6 @@ -- generator function to the already constructed part of the vector. -- -- > constructN 3 f = let a = f <> ; b = f ; c = f in --- constructN :: Int -> (Vector a -> a) -> Vector a {-# INLINE constructN #-} constructN = G.constructN @@ -815,7 +791,6 @@ -- of the vector. -- -- > constructrN 3 f = let a = f <> ; b = f ; c = f in --- constructrN :: Int -> (Vector a -> a) -> Vector a {-# INLINE constructrN #-} constructrN = G.constructrN @@ -823,7 +798,7 @@ -- Enumeration -- ----------- --- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+1@ +-- | /O(n)/ Yield a vector of the given length, containing the values @x@, @x+1@ -- etc. This operation is usually more efficient than 'enumFromTo'. -- -- > enumFromN 5 3 = <5,6,7> @@ -831,17 +806,17 @@ {-# INLINE enumFromN #-} enumFromN = G.enumFromN --- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+y@, +-- | /O(n)/ Yield a vector of the given length, containing the values @x@, @x+y@, -- @x+y+y@ etc. This operations is usually more efficient than 'enumFromThenTo'. -- --- > enumFromStepN 1 0.1 5 = <1,1.1,1.2,1.3,1.4> +-- > enumFromStepN 1 2 5 = <1,3,5,7,9> enumFromStepN :: Num a => a -> a -> Int -> Vector a {-# INLINE enumFromStepN #-} enumFromStepN = G.enumFromStepN -- | /O(n)/ Enumerate values from @x@ to @y@. -- --- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- /WARNING:/ This operation can be very inefficient. If possible, use -- 'enumFromN' instead. enumFromTo :: Enum a => a -> a -> Vector a {-# INLINE enumFromTo #-} @@ -849,7 +824,7 @@ -- | /O(n)/ Enumerate values from @x@ to @y@ with a specific step @z@. -- --- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- /WARNING:/ This operation can be very inefficient. If possible, use -- 'enumFromStepN' instead. enumFromThenTo :: Enum a => a -> a -> a -> Vector a {-# INLINE enumFromThenTo #-} @@ -858,23 +833,23 @@ -- Concatenation -- ------------- --- | /O(n)/ Prepend an element +-- | /O(n)/ Prepend an element. cons :: a -> Vector a -> Vector a {-# INLINE cons #-} cons = G.cons --- | /O(n)/ Append an element +-- | /O(n)/ Append an element. snoc :: Vector a -> a -> Vector a {-# INLINE snoc #-} snoc = G.snoc infixr 5 ++ --- | /O(m+n)/ Concatenate two vectors +-- | /O(m+n)/ Concatenate two vectors. (++) :: Vector a -> Vector a -> Vector a {-# INLINE (++) #-} (++) = (G.++) --- | /O(n)/ Concatenate all vectors in the list +-- | /O(n)/ Concatenate all vectors in the list. concat :: [Vector a] -> Vector a {-# INLINE concat #-} concat = G.concat @@ -889,16 +864,16 @@ replicateM = G.replicateM -- | /O(n)/ Construct a vector of the given length by applying the monadic --- action to each index +-- action to each index. generateM :: Monad m => Int -> (Int -> m a) -> m (Vector a) {-# INLINE generateM #-} generateM = G.generateM --- | /O(n)/ Apply monadic function \(\max(n - 1, 0)\) times to an initial value, producing a vector --- of length \(\max(n, 0)\). Zeroth element will contain the initial value, that's why there +-- | /O(n)/ Apply the monadic function \(\max(n - 1, 0)\) times to an initial value, producing a vector +-- of length \(\max(n, 0)\). The 0th element will contain the initial value, which is why there -- is one less function application than the number of elements in the produced vector. -- --- For non-monadic version see `iterateN` +-- For a non-monadic version, see `iterateN`. -- -- @since 0.12.0.0 iterateNM :: Monad m => Int -> (a -> m a) -> a -> m (Vector a) @@ -925,7 +900,7 @@ -- Restricting memory usage -- ------------------------ --- | /O(n)/ Yield the argument but force it not to retain any extra memory, +-- | /O(n)/ Yield the argument, but force it not to retain any extra memory, -- possibly by copying it. -- -- This is especially useful when dealing with slices. For example: @@ -942,8 +917,8 @@ -- Bulk updates -- ------------ --- | /O(m+n)/ For each pair @(i,a)@ from the list, replace the vector --- element at position @i@ by @a@. +-- | /O(m+n)/ For each pair @(i,a)@ from the list of index/value pairs, +-- replace the vector element at position @i@ by @a@. -- -- > <5,9,2,7> // [(2,1),(0,3),(2,8)] = <3,9,8,7> -- @@ -983,17 +958,17 @@ {-# INLINE update_ #-} update_ = G.update_ --- | Same as ('//') but without bounds checking. +-- | Same as ('//'), but without bounds checking. unsafeUpd :: Vector a -> [(Int, a)] -> Vector a {-# INLINE unsafeUpd #-} unsafeUpd = G.unsafeUpd --- | Same as 'update' but without bounds checking. +-- | Same as 'update', but without bounds checking. unsafeUpdate :: Vector a -> Vector (Int, a) -> Vector a {-# INLINE unsafeUpdate #-} unsafeUpdate = G.unsafeUpdate --- | Same as 'update_' but without bounds checking. +-- | Same as 'update_', but without bounds checking. unsafeUpdate_ :: Vector a -> Vector Int -> Vector a -> Vector a {-# INLINE unsafeUpdate_ #-} unsafeUpdate_ = G.unsafeUpdate_ @@ -1007,8 +982,8 @@ -- ==== __Examples__ -- -- >>> import qualified Data.Strict.Vector.Autogen as V --- >>> V.accum (+) (V.fromList [1000.0,2000.0,3000.0]) [(2,4),(1,6),(0,3),(1,10)] --- [1003.0,2016.0,3004.0] +-- >>> V.accum (+) (V.fromList [1000,2000,3000]) [(2,4),(1,6),(0,3),(1,10)] +-- [1003,2016,3004] accum :: (a -> b -> a) -- ^ accumulating function @f@ -> Vector a -- ^ initial vector (of length @m@) -> [(Int,b)] -- ^ list of index/value pairs (of length @n@) @@ -1022,8 +997,8 @@ -- ==== __Examples__ -- -- >>> import qualified Data.Strict.Vector.Autogen as V --- >>> V.accumulate (+) (V.fromList [1000.0,2000.0,3000.0]) (V.fromList [(2,4),(1,6),(0,3),(1,10)]) --- [1003.0,2016.0,3004.0] +-- >>> V.accumulate (+) (V.fromList [1000,2000,3000]) (V.fromList [(2,4),(1,6),(0,3),(1,10)]) +-- [1003,2016,3004] accumulate :: (a -> b -> a) -- ^ accumulating function @f@ -> Vector a -- ^ initial vector (of length @m@) -> Vector (Int,b) -- ^ vector of index/value pairs (of length @n@) @@ -1052,17 +1027,17 @@ {-# INLINE accumulate_ #-} accumulate_ = G.accumulate_ --- | Same as 'accum' but without bounds checking. +-- | Same as 'accum', but without bounds checking. unsafeAccum :: (a -> b -> a) -> Vector a -> [(Int,b)] -> Vector a {-# INLINE unsafeAccum #-} unsafeAccum = G.unsafeAccum --- | Same as 'accumulate' but without bounds checking. +-- | Same as 'accumulate', but without bounds checking. unsafeAccumulate :: (a -> b -> a) -> Vector a -> Vector (Int,b) -> Vector a {-# INLINE unsafeAccumulate #-} unsafeAccumulate = G.unsafeAccumulate --- | Same as 'accumulate_' but without bounds checking. +-- | Same as 'accumulate_', but without bounds checking. unsafeAccumulate_ :: (a -> b -> a) -> Vector a -> Vector Int -> Vector b -> Vector a {-# INLINE unsafeAccumulate_ #-} @@ -1071,13 +1046,13 @@ -- Permutations -- ------------ --- | /O(n)/ Reverse a vector +-- | /O(n)/ Reverse a vector. reverse :: Vector a -> Vector a {-# INLINE reverse #-} reverse = G.reverse -- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the --- index vector by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is +-- index vector by @xs'!'i@. This is equivalent to @'map' (xs'!') is@, but is -- often much more efficient. -- -- > backpermute <0,3,2,3,1,0> = @@ -1085,7 +1060,7 @@ {-# INLINE backpermute #-} backpermute = G.backpermute --- | Same as 'backpermute' but without bounds checking. +-- | Same as 'backpermute', but without bounds checking. unsafeBackpermute :: Vector a -> Vector Int -> Vector a {-# INLINE unsafeBackpermute #-} unsafeBackpermute = G.unsafeBackpermute @@ -1107,7 +1082,7 @@ -- Indexing -- -------- --- | /O(n)/ Pair each element in a vector with its index +-- | /O(n)/ Pair each element in a vector with its index. indexed :: Vector a -> Vector (Int,a) {-# INLINE indexed #-} indexed = G.indexed @@ -1115,12 +1090,12 @@ -- Mapping -- ------- --- | /O(n)/ Map a function over a vector +-- | /O(n)/ Map a function over a vector. map :: (a -> b) -> Vector a -> Vector b {-# INLINE map #-} map = G.map --- | /O(n)/ Apply a function to every element of a vector and its index +-- | /O(n)/ Apply a function to every element of a vector and its index. imap :: (Int -> a -> b) -> Vector a -> Vector b {-# INLINE imap #-} imap = G.imap @@ -1134,25 +1109,25 @@ -- --------------- -- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a --- vector of results +-- vector of results. mapM :: Monad m => (a -> m b) -> Vector a -> m (Vector b) {-# INLINE mapM #-} mapM = G.mapM -- | /O(n)/ Apply the monadic action to every element of a vector and its --- index, yielding a vector of results +-- index, yielding a vector of results. imapM :: Monad m => (Int -> a -> m b) -> Vector a -> m (Vector b) {-# INLINE imapM #-} imapM = G.imapM -- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the --- results +-- results. mapM_ :: Monad m => (a -> m b) -> Vector a -> m () {-# INLINE mapM_ #-} mapM_ = G.mapM_ -- | /O(n)/ Apply the monadic action to every element of a vector and its --- index, ignoring the results +-- index, ignoring the results. imapM_ :: Monad m => (Int -> a -> m b) -> Vector a -> m () {-# INLINE imapM_ #-} imapM_ = G.imapM_ @@ -1170,15 +1145,15 @@ forM_ = G.forM_ -- | /O(n)/ Apply the monadic action to all elements of the vector and their indices, yielding a --- vector of results. Equivalent to 'flip' 'imapM'. +-- vector of results. Equivalent to @'flip' 'imapM'@. -- -- @since 0.12.2.0 iforM :: Monad m => Vector a -> (Int -> a -> m b) -> m (Vector b) {-# INLINE iforM #-} iforM = G.iforM --- | /O(n)/ Apply the monadic action to all elements of the vector and their indices and ignore the --- results. Equivalent to 'flip' 'imapM_'. +-- | /O(n)/ Apply the monadic action to all elements of the vector and their indices +-- and ignore the results. Equivalent to @'flip' 'imapM_'@. -- -- @since 0.12.2.0 iforM_ :: Monad m => Vector a -> (Int -> a -> m b) -> m () @@ -1244,12 +1219,12 @@ {-# INLINE izipWith6 #-} izipWith6 = G.izipWith6 --- | Elementwise pairing of array elements. +-- | /O(min(m,n))/ Zip two vectors. zip :: Vector a -> Vector b -> Vector (a, b) {-# INLINE zip #-} zip = G.zip --- | zip together three vectors into a vector of triples +-- | Zip together three vectors into a vector of triples. zip3 :: Vector a -> Vector b -> Vector c -> Vector (a, b, c) {-# INLINE zip3 #-} zip3 = G.zip3 @@ -1299,25 +1274,25 @@ -- --------------- -- | /O(min(m,n))/ Zip the two vectors with the monadic action and yield a --- vector of results +-- vector of results. zipWithM :: Monad m => (a -> b -> m c) -> Vector a -> Vector b -> m (Vector c) {-# INLINE zipWithM #-} zipWithM = G.zipWithM -- | /O(min(m,n))/ Zip the two vectors with a monadic action that also takes --- the element index and yield a vector of results +-- the element index and yield a vector of results. izipWithM :: Monad m => (Int -> a -> b -> m c) -> Vector a -> Vector b -> m (Vector c) {-# INLINE izipWithM #-} izipWithM = G.izipWithM -- | /O(min(m,n))/ Zip the two vectors with the monadic action and ignore the --- results +-- results. zipWithM_ :: Monad m => (a -> b -> m c) -> Vector a -> Vector b -> m () {-# INLINE zipWithM_ #-} zipWithM_ = G.zipWithM_ -- | /O(min(m,n))/ Zip the two vectors with a monadic action that also takes --- the element index and ignore the results +-- the element index and ignore the results. izipWithM_ :: Monad m => (Int -> a -> b -> m c) -> Vector a -> Vector b -> m () {-# INLINE izipWithM_ #-} izipWithM_ = G.izipWithM_ @@ -1325,54 +1300,63 @@ -- Filtering -- --------- --- | /O(n)/ Drop elements that do not satisfy the predicate +-- | /O(n)/ Drop all elements that do not satisfy the predicate. filter :: (a -> Bool) -> Vector a -> Vector a {-# INLINE filter #-} filter = G.filter --- | /O(n)/ Drop elements that do not satisfy the predicate which is applied to --- values and their indices +-- | /O(n)/ Drop all elements that do not satisfy the predicate which is applied to +-- the values and their indices. ifilter :: (Int -> a -> Bool) -> Vector a -> Vector a {-# INLINE ifilter #-} ifilter = G.ifilter --- | /O(n)/ Drop repeated adjacent elements. +-- | /O(n)/ Drop repeated adjacent elements. The first element in each group is returned. +-- +-- ==== __Examples__ +-- +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> V.uniq $ V.fromList [1,3,3,200,3] +-- [1,3,200,3] +-- >>> import Data.Semigroup +-- >>> V.uniq $ V.fromList [ Arg 1 'a', Arg 1 'b', Arg 1 'c'] +-- [Arg 1 'a'] uniq :: (Eq a) => Vector a -> Vector a {-# INLINE uniq #-} uniq = G.uniq --- | /O(n)/ Drop elements when predicate returns Nothing +-- | /O(n)/ Map the values and collect the 'Just' results. mapMaybe :: (a -> Maybe b) -> Vector a -> Vector b {-# INLINE mapMaybe #-} mapMaybe = G.mapMaybe --- | /O(n)/ Drop elements when predicate, applied to index and value, returns Nothing +-- | /O(n)/ Map the indices/values and collect the 'Just' results. imapMaybe :: (Int -> a -> Maybe b) -> Vector a -> Vector b {-# INLINE imapMaybe #-} imapMaybe = G.imapMaybe --- | /O(n)/ Return a Vector of all the `Just` values. +-- | /O(n)/ Return a Vector of all the 'Just' values. -- -- @since 0.12.2.0 catMaybes :: Vector (Maybe a) -> Vector a {-# INLINE catMaybes #-} catMaybes = mapMaybe id --- | /O(n)/ Drop elements that do not satisfy the monadic predicate +-- | /O(n)/ Drop all elements that do not satisfy the monadic predicate. filterM :: Monad m => (a -> m Bool) -> Vector a -> m (Vector a) {-# INLINE filterM #-} filterM = G.filterM --- | /O(n)/ Apply monadic function to each element of vector and --- discard elements returning Nothing. +-- | /O(n)/ Apply the monadic function to each element of the vector and +-- discard elements returning 'Nothing'. -- -- @since 0.12.2.0 mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Vector a -> m (Vector b) {-# INLINE mapMaybeM #-} mapMaybeM = G.mapMaybeM --- | /O(n)/ Apply monadic function to each element of vector and its index. --- Discards elements returning Nothing. +-- | /O(n)/ Apply the monadic function to each element of the vector and its index. +-- Discard elements returning 'Nothing'. -- -- @since 0.12.2.0 imapMaybeM :: Monad m => (Int -> a -> m (Maybe b)) -> Vector a -> m (Vector b) @@ -1380,7 +1364,7 @@ imapMaybeM = G.imapMaybeM -- | /O(n)/ Yield the longest prefix of elements satisfying the predicate. --- Current implementation is not copy-free, unless the result vector is +-- The current implementation is not copy-free, unless the result vector is -- fused away. takeWhile :: (a -> Bool) -> Vector a -> Vector a {-# INLINE takeWhile #-} @@ -1403,14 +1387,6 @@ {-# INLINE partition #-} partition = G.partition --- | /O(n)/ Split the vector in two parts, the first one containing those --- elements that satisfy the predicate and the second one those that don't. --- The order of the elements is not preserved but the operation is often --- faster than 'partition'. -unstablePartition :: (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE unstablePartition #-} -unstablePartition = G.unstablePartition - -- | /O(n)/ Split the vector into two parts, the first one containing the -- @`Left`@ elements and the second containing the @`Right`@ elements. -- The relative order of the elements is preserved. @@ -1420,6 +1396,14 @@ {-# INLINE partitionWith #-} partitionWith = G.partitionWith +-- | /O(n)/ Split the vector in two parts, the first one containing those +-- elements that satisfy the predicate and the second one those that don't. +-- The order of the elements is not preserved, but the operation is often +-- faster than 'partition'. +unstablePartition :: (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE unstablePartition #-} +unstablePartition = G.unstablePartition + -- | /O(n)/ Split the vector into the longest prefix of elements that satisfy -- the predicate and the rest without copying. span :: (a -> Bool) -> Vector a -> (Vector a, Vector a) @@ -1432,17 +1416,57 @@ {-# INLINE break #-} break = G.break +-- | /O(n)/ Split a vector into a list of slices, using a predicate function. +-- +-- The concatenation of this list of slices is equal to the argument vector, +-- and each slice contains only equal elements, as determined by the equality +-- predicate function. +-- +-- Does not fuse. +-- +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> import Data.Char (isUpper) +-- >>> V.groupBy (\a b -> isUpper a == isUpper b) (V.fromList "Mississippi River") +-- ["M","ississippi ","R","iver"] +-- +-- See also 'Data.List.groupBy', 'group'. +-- +-- @since 0.13.0.1 +groupBy :: (a -> a -> Bool) -> Vector a -> [Vector a] +{-# INLINE groupBy #-} +groupBy = G.groupBy + +-- | /O(n)/ Split a vector into a list of slices of the input vector. +-- +-- The concatenation of this list of slices is equal to the argument vector, +-- and each slice contains only equal elements. +-- +-- Does not fuse. +-- +-- This is the equivalent of 'groupBy (==)'. +-- +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> V.group (V.fromList "Mississippi") +-- ["M","i","ss","i","ss","i","pp","i"] +-- +-- See also 'Data.List.group'. +-- +-- @since 0.13.0.1 +group :: Eq a => Vector a -> [Vector a] +{-# INLINE group #-} +group = G.groupBy (==) + -- Searching -- --------- infix 4 `elem` --- | /O(n)/ Check if the vector contains an element +-- | /O(n)/ Check if the vector contains an element. elem :: Eq a => a -> Vector a -> Bool {-# INLINE elem #-} elem = G.elem infix 4 `notElem` --- | /O(n)/ Check if the vector does not contain an element (inverse of 'elem') +-- | /O(n)/ Check if the vector does not contain an element (inverse of 'elem'). notElem :: Eq a => a -> Vector a -> Bool {-# INLINE notElem #-} notElem = G.notElem @@ -1465,14 +1489,14 @@ {-# INLINE findIndices #-} findIndices = G.findIndices --- | /O(n)/ Yield 'Just' the index of the first occurence of the given element or +-- | /O(n)/ Yield 'Just' the index of the first occurrence of the given element or -- 'Nothing' if the vector does not contain the element. This is a specialised -- version of 'findIndex'. elemIndex :: Eq a => a -> Vector a -> Maybe Int {-# INLINE elemIndex #-} elemIndex = G.elemIndex --- | /O(n)/ Yield the indices of all occurences of the given element in +-- | /O(n)/ Yield the indices of all occurrences of the given element in -- ascending order. This is a specialised version of 'findIndices'. elemIndices :: Eq a => a -> Vector a -> Vector Int {-# INLINE elemIndices #-} @@ -1481,72 +1505,72 @@ -- Folding -- ------- --- | /O(n)/ Left fold +-- | /O(n)/ Left fold. foldl :: (a -> b -> a) -> a -> Vector b -> a {-# INLINE foldl #-} foldl = G.foldl --- | /O(n)/ Left fold on non-empty vectors +-- | /O(n)/ Left fold on non-empty vectors. foldl1 :: (a -> a -> a) -> Vector a -> a {-# INLINE foldl1 #-} foldl1 = G.foldl1 --- | /O(n)/ Left fold with strict accumulator +-- | /O(n)/ Left fold with strict accumulator. foldl' :: (a -> b -> a) -> a -> Vector b -> a {-# INLINE foldl' #-} foldl' = G.foldl' --- | /O(n)/ Left fold on non-empty vectors with strict accumulator +-- | /O(n)/ Left fold on non-empty vectors with strict accumulator. foldl1' :: (a -> a -> a) -> Vector a -> a {-# INLINE foldl1' #-} foldl1' = G.foldl1' --- | /O(n)/ Right fold +-- | /O(n)/ Right fold. foldr :: (a -> b -> b) -> b -> Vector a -> b {-# INLINE foldr #-} foldr = G.foldr --- | /O(n)/ Right fold on non-empty vectors +-- | /O(n)/ Right fold on non-empty vectors. foldr1 :: (a -> a -> a) -> Vector a -> a {-# INLINE foldr1 #-} foldr1 = G.foldr1 --- | /O(n)/ Right fold with a strict accumulator +-- | /O(n)/ Right fold with a strict accumulator. foldr' :: (a -> b -> b) -> b -> Vector a -> b {-# INLINE foldr' #-} foldr' = G.foldr' --- | /O(n)/ Right fold on non-empty vectors with strict accumulator +-- | /O(n)/ Right fold on non-empty vectors with strict accumulator. foldr1' :: (a -> a -> a) -> Vector a -> a {-# INLINE foldr1' #-} foldr1' = G.foldr1' --- | /O(n)/ Left fold (function applied to each element and its index) +-- | /O(n)/ Left fold using a function applied to each element and its index. ifoldl :: (a -> Int -> b -> a) -> a -> Vector b -> a {-# INLINE ifoldl #-} ifoldl = G.ifoldl --- | /O(n)/ Left fold with strict accumulator (function applied to each element --- and its index) +-- | /O(n)/ Left fold with strict accumulator using a function applied to each element +-- and its index. ifoldl' :: (a -> Int -> b -> a) -> a -> Vector b -> a {-# INLINE ifoldl' #-} ifoldl' = G.ifoldl' --- | /O(n)/ Right fold (function applied to each element and its index) +-- | /O(n)/ Right fold using a function applied to each element and its index. ifoldr :: (Int -> a -> b -> b) -> b -> Vector a -> b {-# INLINE ifoldr #-} ifoldr = G.ifoldr --- | /O(n)/ Right fold with strict accumulator (function applied to each --- element and its index) +-- | /O(n)/ Right fold with strict accumulator using a function applied to each +-- element and its index. ifoldr' :: (Int -> a -> b -> b) -> b -> Vector a -> b {-# INLINE ifoldr' #-} ifoldr' = G.ifoldr' --- | /O(n)/ Map each element of the structure to a monoid, and combine --- the results. It uses same implementation as corresponding method of --- 'Foldable' type cless. Note it's implemented in terms of 'foldr' --- and won't fuse with functions that traverse vector from left to +-- | /O(n)/ Map each element of the structure to a monoid and combine +-- the results. It uses the same implementation as the corresponding method +-- of the 'Foldable' type class. Note that it's implemented in terms of 'foldr' +-- and won't fuse with functions that traverse the vector from left to -- right ('map', 'generate', etc.). -- -- @since 0.12.2.0 @@ -1554,9 +1578,9 @@ {-# INLINE foldMap #-} foldMap = G.foldMap --- | /O(n)/ 'foldMap' which is strict in accumulator. It uses same --- implementation as corresponding method of 'Foldable' type class. --- Note it's implemented in terms of 'foldl'' so it fuses in most +-- | /O(n)/ Like 'foldMap', but strict in the accumulator. It uses the same +-- implementation as the corresponding method of the 'Foldable' type class. +-- Note that it's implemented in terms of 'foldl'', so it fuses in most -- contexts. -- -- @since 0.12.2.0 @@ -1573,9 +1597,9 @@ -- ==== __Examples__ -- -- >>> import qualified Data.Strict.Vector.Autogen as V --- >>> V.all even $ V.fromList [2, 4, 12 :: Int] +-- >>> V.all even $ V.fromList [2, 4, 12] -- True --- >>> V.all even $ V.fromList [2, 4, 13 :: Int] +-- >>> V.all even $ V.fromList [2, 4, 13] -- False -- >>> V.all even (V.empty :: V.Vector Int) -- True @@ -1588,9 +1612,9 @@ -- ==== __Examples__ -- -- >>> import qualified Data.Strict.Vector.Autogen as V --- >>> V.any even $ V.fromList [1, 3, 7 :: Int] +-- >>> V.any even $ V.fromList [1, 3, 7] -- False --- >>> V.any even $ V.fromList [3, 2, 13 :: Int] +-- >>> V.any even $ V.fromList [3, 2, 13] -- True -- >>> V.any even (V.empty :: V.Vector Int) -- False @@ -1598,7 +1622,7 @@ {-# INLINE any #-} any = G.any --- | /O(n)/ Check if all elements are 'True' +-- | /O(n)/ Check if all elements are 'True'. -- -- ==== __Examples__ -- @@ -1611,7 +1635,7 @@ {-# INLINE and #-} and = G.and --- | /O(n)/ Check if any element is 'True' +-- | /O(n)/ Check if any element is 'True'. -- -- ==== __Examples__ -- @@ -1624,12 +1648,12 @@ {-# INLINE or #-} or = G.or --- | /O(n)/ Compute the sum of the elements +-- | /O(n)/ Compute the sum of the elements. -- -- ==== __Examples__ -- -- >>> import qualified Data.Strict.Vector.Autogen as V --- >>> V.sum $ V.fromList [300,20,1 :: Int] +-- >>> V.sum $ V.fromList [300,20,1] -- 321 -- >>> V.sum (V.empty :: V.Vector Int) -- 0 @@ -1637,12 +1661,12 @@ {-# INLINE sum #-} sum = G.sum --- | /O(n)/ Compute the produce of the elements +-- | /O(n)/ Compute the product of the elements. -- -- ==== __Examples__ -- -- >>> import qualified Data.Strict.Vector.Autogen as V --- >>> V.product $ V.fromList [1,2,3,4 :: Int] +-- >>> V.product $ V.fromList [1,2,3,4] -- 24 -- >>> V.product (V.empty :: V.Vector Int) -- 1 @@ -1651,49 +1675,124 @@ product = G.product -- | /O(n)/ Yield the maximum element of the vector. The vector may not be --- empty. +-- empty. In case of a tie, the first occurrence wins. -- -- ==== __Examples__ -- -- >>> import qualified Data.Strict.Vector.Autogen as V --- >>> V.maximum $ V.fromList [2.0, 1.0] --- 2.0 +-- >>> V.maximum $ V.fromList [2, 1] +-- 2 +-- >>> import Data.Semigroup +-- >>> V.maximum $ V.fromList [Arg 1 'a', Arg 2 'b'] +-- Arg 2 'b' +-- >>> V.maximum $ V.fromList [Arg 1 'a', Arg 1 'b'] +-- Arg 1 'a' maximum :: Ord a => Vector a -> a {-# INLINE maximum #-} maximum = G.maximum --- | /O(n)/ Yield the maximum element of the vector according to the given --- comparison function. The vector may not be empty. +-- | /O(n)/ Yield the maximum element of the vector according to the +-- given comparison function. The vector may not be empty. In case of +-- a tie, the first occurrence wins. This behavior is different from +-- 'Data.List.maximumBy' which returns the last tie. +-- +-- ==== __Examples__ +-- +-- >>> import Data.Ord +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> V.maximumBy (comparing fst) $ V.fromList [(2,'a'), (1,'b')] +-- (2,'a') +-- >>> V.maximumBy (comparing fst) $ V.fromList [(1,'a'), (1,'b')] +-- (1,'a') maximumBy :: (a -> a -> Ordering) -> Vector a -> a {-# INLINE maximumBy #-} maximumBy = G.maximumBy +-- | /O(n)/ Yield the maximum element of the vector by comparing the results +-- of a key function on each element. In case of a tie, the first occurrence +-- wins. The vector may not be empty. +-- +-- ==== __Examples__ +-- +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> V.maximumOn fst $ V.fromList [(2,'a'), (1,'b')] +-- (2,'a') +-- >>> V.maximumOn fst $ V.fromList [(1,'a'), (1,'b')] +-- (1,'a') +-- +-- @since 0.13.0.0 +maximumOn :: Ord b => (a -> b) -> Vector a -> a +{-# INLINE maximumOn #-} +maximumOn = G.maximumOn + -- | /O(n)/ Yield the minimum element of the vector. The vector may not be --- empty. +-- empty. In case of a tie, the first occurrence wins. -- -- ==== __Examples__ -- -- >>> import qualified Data.Strict.Vector.Autogen as V --- >>> V.minimum $ V.fromList [2.0, 1.0] --- 1.0 +-- >>> V.minimum $ V.fromList [2, 1] +-- 1 +-- >>> import Data.Semigroup +-- >>> V.minimum $ V.fromList [Arg 2 'a', Arg 1 'b'] +-- Arg 1 'b' +-- >>> V.minimum $ V.fromList [Arg 1 'a', Arg 1 'b'] +-- Arg 1 'a' minimum :: Ord a => Vector a -> a {-# INLINE minimum #-} minimum = G.minimum --- | /O(n)/ Yield the minimum element of the vector according to the given --- comparison function. The vector may not be empty. +-- | /O(n)/ Yield the minimum element of the vector according to the +-- given comparison function. The vector may not be empty. In case of +-- a tie, the first occurrence wins. +-- +-- ==== __Examples__ +-- +-- >>> import Data.Ord +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> V.minimumBy (comparing fst) $ V.fromList [(2,'a'), (1,'b')] +-- (1,'b') +-- >>> V.minimumBy (comparing fst) $ V.fromList [(1,'a'), (1,'b')] +-- (1,'a') minimumBy :: (a -> a -> Ordering) -> Vector a -> a {-# INLINE minimumBy #-} minimumBy = G.minimumBy +-- | /O(n)/ Yield the minimum element of the vector by comparing the results +-- of a key function on each element. In case of a tie, the first occurrence +-- wins. The vector may not be empty. +-- +-- ==== __Examples__ +-- +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> V.minimumOn fst $ V.fromList [(2,'a'), (1,'b')] +-- (1,'b') +-- >>> V.minimumOn fst $ V.fromList [(1,'a'), (1,'b')] +-- (1,'a') +-- +-- @since 0.13.0.0 +minimumOn :: Ord b => (a -> b) -> Vector a -> a +{-# INLINE minimumOn #-} +minimumOn = G.minimumOn + -- | /O(n)/ Yield the index of the maximum element of the vector. The vector -- may not be empty. maxIndex :: Ord a => Vector a -> Int {-# INLINE maxIndex #-} maxIndex = G.maxIndex --- | /O(n)/ Yield the index of the maximum element of the vector according to --- the given comparison function. The vector may not be empty. +-- | /O(n)/ Yield the index of the maximum element of the vector +-- according to the given comparison function. The vector may not be +-- empty. In case of a tie, the first occurrence wins. +-- +-- ==== __Examples__ +-- +-- >>> import Data.Ord +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> V.maxIndexBy (comparing fst) $ V.fromList [(2,'a'), (1,'b')] +-- 0 +-- >>> V.maxIndexBy (comparing fst) $ V.fromList [(1,'a'), (1,'b')] +-- 0 maxIndexBy :: (a -> a -> Ordering) -> Vector a -> Int {-# INLINE maxIndexBy #-} maxIndexBy = G.maxIndexBy @@ -1706,6 +1805,15 @@ -- | /O(n)/ Yield the index of the minimum element of the vector according to -- the given comparison function. The vector may not be empty. +-- +-- ==== __Examples__ +-- +-- >>> import Data.Ord +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> V.minIndexBy (comparing fst) $ V.fromList [(2,'a'), (1,'b')] +-- 1 +-- >>> V.minIndexBy (comparing fst) $ V.fromList [(1,'a'), (1,'b')] +-- 0 minIndexBy :: (a -> a -> Ordering) -> Vector a -> Int {-# INLINE minIndexBy #-} minIndexBy = G.minIndexBy @@ -1713,66 +1821,66 @@ -- Monadic folds -- ------------- --- | /O(n)/ Monadic fold +-- | /O(n)/ Monadic fold. foldM :: Monad m => (a -> b -> m a) -> a -> Vector b -> m a {-# INLINE foldM #-} foldM = G.foldM --- | /O(n)/ Monadic fold (action applied to each element and its index) +-- | /O(n)/ Monadic fold using a function applied to each element and its index. ifoldM :: Monad m => (a -> Int -> b -> m a) -> a -> Vector b -> m a {-# INLINE ifoldM #-} ifoldM = G.ifoldM --- | /O(n)/ Monadic fold over non-empty vectors +-- | /O(n)/ Monadic fold over non-empty vectors. fold1M :: Monad m => (a -> a -> m a) -> Vector a -> m a {-# INLINE fold1M #-} fold1M = G.fold1M --- | /O(n)/ Monadic fold with strict accumulator +-- | /O(n)/ Monadic fold with strict accumulator. foldM' :: Monad m => (a -> b -> m a) -> a -> Vector b -> m a {-# INLINE foldM' #-} foldM' = G.foldM' --- | /O(n)/ Monadic fold with strict accumulator (action applied to each --- element and its index) +-- | /O(n)/ Monadic fold with strict accumulator using a function applied to each +-- element and its index. ifoldM' :: Monad m => (a -> Int -> b -> m a) -> a -> Vector b -> m a {-# INLINE ifoldM' #-} ifoldM' = G.ifoldM' --- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator +-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator. fold1M' :: Monad m => (a -> a -> m a) -> Vector a -> m a {-# INLINE fold1M' #-} fold1M' = G.fold1M' --- | /O(n)/ Monadic fold that discards the result +-- | /O(n)/ Monadic fold that discards the result. foldM_ :: Monad m => (a -> b -> m a) -> a -> Vector b -> m () {-# INLINE foldM_ #-} foldM_ = G.foldM_ --- | /O(n)/ Monadic fold that discards the result (action applied to each --- element and its index) +-- | /O(n)/ Monadic fold that discards the result using a function applied to +-- each element and its index. ifoldM_ :: Monad m => (a -> Int -> b -> m a) -> a -> Vector b -> m () {-# INLINE ifoldM_ #-} ifoldM_ = G.ifoldM_ --- | /O(n)/ Monadic fold over non-empty vectors that discards the result +-- | /O(n)/ Monadic fold over non-empty vectors that discards the result. fold1M_ :: Monad m => (a -> a -> m a) -> Vector a -> m () {-# INLINE fold1M_ #-} fold1M_ = G.fold1M_ --- | /O(n)/ Monadic fold with strict accumulator that discards the result +-- | /O(n)/ Monadic fold with strict accumulator that discards the result. foldM'_ :: Monad m => (a -> b -> m a) -> a -> Vector b -> m () {-# INLINE foldM'_ #-} foldM'_ = G.foldM'_ -- | /O(n)/ Monadic fold with strict accumulator that discards the result --- (action applied to each element and its index) +-- using a function applied to each element and its index. ifoldM'_ :: Monad m => (a -> Int -> b -> m a) -> a -> Vector b -> m () {-# INLINE ifoldM'_ #-} ifoldM'_ = G.ifoldM'_ -- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator --- that discards the result +-- that discards the result. fold1M'_ :: Monad m => (a -> a -> m a) -> Vector a -> m () {-# INLINE fold1M'_ #-} fold1M'_ = G.fold1M'_ @@ -1780,155 +1888,210 @@ -- Monadic sequencing -- ------------------ --- | Evaluate each action and collect the results +-- | Evaluate each action and collect the results. sequence :: Monad m => Vector (m a) -> m (Vector a) {-# INLINE sequence #-} sequence = G.sequence --- | Evaluate each action and discard the results +-- | Evaluate each action and discard the results. sequence_ :: Monad m => Vector (m a) -> m () {-# INLINE sequence_ #-} sequence_ = G.sequence_ --- Prefix sums (scans) --- ------------------- +-- Scans +-- ----- --- | /O(n)/ Prescan +-- | /O(n)/ Left-to-right prescan. -- -- @ -- prescanl f z = 'init' . 'scanl' f z -- @ -- --- Example: @prescanl (+) 0 \<1,2,3,4\> = \<0,1,3,6\>@ +-- ==== __Examples__ -- +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> V.prescanl (+) 0 (V.fromList [1,2,3,4]) +-- [0,1,3,6] prescanl :: (a -> b -> a) -> a -> Vector b -> Vector a {-# INLINE prescanl #-} prescanl = G.prescanl --- | /O(n)/ Prescan with strict accumulator +-- | /O(n)/ Left-to-right prescan with strict accumulator. prescanl' :: (a -> b -> a) -> a -> Vector b -> Vector a {-# INLINE prescanl' #-} prescanl' = G.prescanl' --- | /O(n)/ Scan +-- | /O(n)/ Left-to-right postscan. -- -- @ -- postscanl f z = 'tail' . 'scanl' f z -- @ -- --- Example: @postscanl (+) 0 \<1,2,3,4\> = \<1,3,6,10\>@ +-- ==== __Examples__ -- +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> V.postscanl (+) 0 (V.fromList [1,2,3,4]) +-- [1,3,6,10] postscanl :: (a -> b -> a) -> a -> Vector b -> Vector a {-# INLINE postscanl #-} postscanl = G.postscanl --- | /O(n)/ Scan with strict accumulator +-- | /O(n)/ Left-to-right postscan with strict accumulator. postscanl' :: (a -> b -> a) -> a -> Vector b -> Vector a {-# INLINE postscanl' #-} postscanl' = G.postscanl' --- | /O(n)/ Haskell-style scan +-- | /O(n)/ Left-to-right scan. -- -- > scanl f z = -- > where y1 = z -- > yi = f y(i-1) x(i-1) -- --- Example: @scanl (+) 0 \<1,2,3,4\> = \<0,1,3,6,10\>@ +-- ==== __Examples__ -- +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> V.scanl (+) 0 (V.fromList [1,2,3,4]) +-- [0,1,3,6,10] scanl :: (a -> b -> a) -> a -> Vector b -> Vector a {-# INLINE scanl #-} scanl = G.scanl --- | /O(n)/ Haskell-style scan with strict accumulator +-- | /O(n)/ Left-to-right scan with strict accumulator. scanl' :: (a -> b -> a) -> a -> Vector b -> Vector a {-# INLINE scanl' #-} scanl' = G.scanl' --- | /O(n)/ Scan over a vector with its index +-- | /O(n)/ Left-to-right scan over a vector with its index. -- -- @since 0.12.0.0 iscanl :: (Int -> a -> b -> a) -> a -> Vector b -> Vector a {-# INLINE iscanl #-} iscanl = G.iscanl --- | /O(n)/ Scan over a vector (strictly) with its index +-- | /O(n)/ Left-to-right scan over a vector (strictly) with its index. -- -- @since 0.12.0.0 iscanl' :: (Int -> a -> b -> a) -> a -> Vector b -> Vector a {-# INLINE iscanl' #-} iscanl' = G.iscanl' --- | /O(n)/ Scan over a non-empty vector +-- | /O(n)/ Initial-value free left-to-right scan over a vector. -- -- > scanl f = -- > where y1 = x1 -- > yi = f y(i-1) xi -- +-- Note: Since 0.13, application of this to an empty vector no longer +-- results in an error; instead it produces an empty vector. +-- +-- ==== __Examples__ +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> V.scanl1 min $ V.fromListN 5 [4,2,4,1,3] +-- [4,2,2,1,1] +-- >>> V.scanl1 max $ V.fromListN 5 [1,3,2,5,4] +-- [1,3,3,5,5] +-- >>> V.scanl1 min (V.empty :: V.Vector Int) +-- [] scanl1 :: (a -> a -> a) -> Vector a -> Vector a {-# INLINE scanl1 #-} scanl1 = G.scanl1 --- | /O(n)/ Scan over a non-empty vector with a strict accumulator +-- | /O(n)/ Initial-value free left-to-right scan over a vector with a strict accumulator. +-- +-- Note: Since 0.13, application of this to an empty vector no longer +-- results in an error; instead it produces an empty vector. +-- +-- ==== __Examples__ +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> V.scanl1' min $ V.fromListN 5 [4,2,4,1,3] +-- [4,2,2,1,1] +-- >>> V.scanl1' max $ V.fromListN 5 [1,3,2,5,4] +-- [1,3,3,5,5] +-- >>> V.scanl1' min (V.empty :: V.Vector Int) +-- [] scanl1' :: (a -> a -> a) -> Vector a -> Vector a {-# INLINE scanl1' #-} scanl1' = G.scanl1' --- | /O(n)/ Right-to-left prescan +-- | /O(n)/ Right-to-left prescan. -- -- @ -- prescanr f z = 'reverse' . 'prescanl' (flip f) z . 'reverse' -- @ --- prescanr :: (a -> b -> b) -> b -> Vector a -> Vector b {-# INLINE prescanr #-} prescanr = G.prescanr --- | /O(n)/ Right-to-left prescan with strict accumulator +-- | /O(n)/ Right-to-left prescan with strict accumulator. prescanr' :: (a -> b -> b) -> b -> Vector a -> Vector b {-# INLINE prescanr' #-} prescanr' = G.prescanr' --- | /O(n)/ Right-to-left scan +-- | /O(n)/ Right-to-left postscan. postscanr :: (a -> b -> b) -> b -> Vector a -> Vector b {-# INLINE postscanr #-} postscanr = G.postscanr --- | /O(n)/ Right-to-left scan with strict accumulator +-- | /O(n)/ Right-to-left postscan with strict accumulator. postscanr' :: (a -> b -> b) -> b -> Vector a -> Vector b {-# INLINE postscanr' #-} postscanr' = G.postscanr' --- | /O(n)/ Right-to-left Haskell-style scan +-- | /O(n)/ Right-to-left scan. scanr :: (a -> b -> b) -> b -> Vector a -> Vector b {-# INLINE scanr #-} scanr = G.scanr --- | /O(n)/ Right-to-left Haskell-style scan with strict accumulator +-- | /O(n)/ Right-to-left scan with strict accumulator. scanr' :: (a -> b -> b) -> b -> Vector a -> Vector b {-# INLINE scanr' #-} scanr' = G.scanr' --- | /O(n)/ Right-to-left scan over a vector with its index +-- | /O(n)/ Right-to-left scan over a vector with its index. -- -- @since 0.12.0.0 iscanr :: (Int -> a -> b -> b) -> b -> Vector a -> Vector b {-# INLINE iscanr #-} iscanr = G.iscanr --- | /O(n)/ Right-to-left scan over a vector (strictly) with its index +-- | /O(n)/ Right-to-left scan over a vector (strictly) with its index. -- -- @since 0.12.0.0 iscanr' :: (Int -> a -> b -> b) -> b -> Vector a -> Vector b {-# INLINE iscanr' #-} iscanr' = G.iscanr' --- | /O(n)/ Right-to-left scan over a non-empty vector +-- | /O(n)/ Right-to-left, initial-value free scan over a vector. +-- +-- Note: Since 0.13, application of this to an empty vector no longer +-- results in an error; instead it produces an empty vector. +-- +-- ==== __Examples__ +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> V.scanr1 min $ V.fromListN 5 [3,1,4,2,4] +-- [1,1,2,2,4] +-- >>> V.scanr1 max $ V.fromListN 5 [4,5,2,3,1] +-- [5,5,3,3,1] +-- >>> V.scanr1 min (V.empty :: V.Vector Int) +-- [] scanr1 :: (a -> a -> a) -> Vector a -> Vector a {-# INLINE scanr1 #-} scanr1 = G.scanr1 --- | /O(n)/ Right-to-left scan over a non-empty vector with a strict --- accumulator +-- | /O(n)/ Right-to-left, initial-value free scan over a vector with a strict +-- accumulator. +-- +-- Note: Since 0.13, application of this to an empty vector no longer +-- results in an error; instead it produces an empty vector. +-- +-- ==== __Examples__ +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> V.scanr1' min $ V.fromListN 5 [3,1,4,2,4] +-- [1,1,2,2,4] +-- >>> V.scanr1' max $ V.fromListN 5 [4,5,2,3,1] +-- [5,5,3,3,1] +-- >>> V.scanr1' min (V.empty :: V.Vector Int) +-- [] scanr1' :: (a -> a -> a) -> Vector a -> Vector a {-# INLINE scanr1' #-} scanr1' = G.scanr1' @@ -1936,7 +2099,7 @@ -- Comparisons -- ------------------------ --- | /O(n)/ Check if two vectors are equal using supplied equality +-- | /O(n)/ Check if two vectors are equal using the supplied equality -- predicate. -- -- @since 0.12.2.0 @@ -1944,8 +2107,8 @@ {-# INLINE eqBy #-} eqBy = G.eqBy --- | /O(n)/ Compare two vectors using supplied comparison function for --- vector elements. Comparison works same as for lists. +-- | /O(n)/ Compare two vectors using the supplied comparison function for +-- vector elements. Comparison works the same as for lists. -- -- > cmpBy compare == compare -- @@ -1956,17 +2119,21 @@ -- Conversions - Lists -- ------------------------ --- | /O(n)/ Convert a vector to a list +-- | /O(n)/ Convert a vector to a list. toList :: Vector a -> [a] {-# INLINE toList #-} toList = G.toList --- | /O(n)/ Convert a list to a vector +-- | /O(n)/ Convert a list to a vector. fromList :: [a] -> Vector a {-# INLINE fromList #-} fromList = G.fromList --- | /O(n)/ Convert the first @n@ elements of a list to a vector +-- | /O(n)/ Convert the first @n@ elements of a list to a vector. It's +-- expected that the supplied list will be exactly @n@ elements long. As +-- an optimization, this function allocates a buffer for @n@ elements, which +-- could be used for DoS-attacks by exhausting the memory if an attacker controls +-- that parameter. -- -- @ -- fromListN n xs = 'fromList' ('take' n xs) @@ -1983,42 +2150,92 @@ -- @since 0.12.2.0 fromArray :: Array a -> Vector a {-# INLINE fromArray #-} -fromArray x = Vector 0 (sizeofArray x) x +fromArray arr = Vector 0 (sizeofArray arr) arr -- | /O(n)/ Convert a vector to an array. -- -- @since 0.12.2.0 toArray :: Vector a -> Array a {-# INLINE toArray #-} -toArray (Vector offset size arr) - | offset == 0 && size == sizeofArray arr = arr - | otherwise = cloneArray arr offset size +toArray (Vector offset len arr) + | offset == 0 && len == sizeofArray arr = arr + | otherwise = cloneArray arr offset len +-- | /O(1)/ Extract the underlying `Array`, offset where vector starts and the +-- total number of elements in the vector. Below property always holds: +-- +-- > let (array, offset, len) = toArraySlice v +-- > v === unsafeFromArraySlice len offset array +-- +-- @since 0.13.0.0 +toArraySlice :: Vector a -> (Array a, Int, Int) +{-# INLINE toArraySlice #-} +toArraySlice (Vector offset len arr) = (arr, offset, len) + + +-- | /O(1)/ Convert an array slice to a vector. This function is very unsafe, +-- because constructing an invalid vector can yield almost all other safe +-- functions in this module unsafe. These are equivalent: +-- +-- > unsafeFromArraySlice len offset === unsafeTake len . unsafeDrop offset . fromArray +-- +-- @since 0.13.0.0 +unsafeFromArraySlice :: + Array a -- ^ Immutable boxed array. + -> Int -- ^ Offset + -> Int -- ^ Length + -> Vector a +{-# INLINE unsafeFromArraySlice #-} +unsafeFromArraySlice arr offset len = Vector offset len arr + -- Conversions - Mutable vectors -- ----------------------------- --- | /O(1)/ Unsafe convert a mutable vector to an immutable one without +-- | /O(1)/ Unsafely convert a mutable vector to an immutable one without -- copying. The mutable vector may not be used after this operation. unsafeFreeze :: PrimMonad m => MVector (PrimState m) a -> m (Vector a) {-# INLINE unsafeFreeze #-} unsafeFreeze = G.unsafeFreeze --- | /O(1)/ Unsafely convert an immutable vector to a mutable one without --- copying. The immutable vector may not be used after this operation. +-- | /O(n)/ Yield an immutable copy of the mutable vector. +freeze :: PrimMonad m => MVector (PrimState m) a -> m (Vector a) +{-# INLINE freeze #-} +freeze = G.freeze + +-- | /O(1)/ Unsafely convert an immutable vector to a mutable one +-- without copying. Note that this is a very dangerous function and +-- generally it's only safe to read from the resulting vector. In this +-- case, the immutable vector could be used safely as well. +-- +-- Problems with mutation happen because GHC has a lot of freedom to +-- introduce sharing. As a result mutable vectors produced by +-- @unsafeThaw@ may or may not share the same underlying buffer. For +-- example: +-- +-- > foo = do +-- > let vec = V.generate 10 id +-- > mvec <- V.unsafeThaw vec +-- > do_something mvec +-- +-- Here GHC could lift @vec@ outside of foo which means that all calls to +-- @do_something@ will use same buffer with possibly disastrous +-- results. Whether such aliasing happens or not depends on the program in +-- question, optimization levels, and GHC flags. +-- +-- All in all, attempts to modify a vector produced by @unsafeThaw@ fall out of +-- domain of software engineering and into realm of black magic, dark +-- rituals, and unspeakable horrors. The only advice that could be given +-- is: "Don't attempt to mutate a vector produced by @unsafeThaw@ unless you +-- know how to prevent GHC from aliasing buffers accidentally. We don't." unsafeThaw :: PrimMonad m => Vector a -> m (MVector (PrimState m) a) {-# INLINE unsafeThaw #-} unsafeThaw = G.unsafeThaw --- | /O(n)/ Yield a mutable copy of the immutable vector. +-- | /O(n)/ Yield a mutable copy of an immutable vector. thaw :: PrimMonad m => Vector a -> m (MVector (PrimState m) a) {-# INLINE thaw #-} thaw = G.thaw --- | /O(n)/ Yield an immutable copy of the mutable vector. -freeze :: PrimMonad m => MVector (PrimState m) a -> m (Vector a) -{-# INLINE freeze #-} -freeze = G.freeze - -- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must -- have the same length. This is not checked. unsafeCopy :: PrimMonad m => MVector (PrimState m) a -> Vector a -> m () @@ -2030,3 +2247,6 @@ copy :: PrimMonad m => MVector (PrimState m) a -> Vector a -> m () {-# INLINE copy #-} copy = G.copy + +-- $setup +-- >>> :set -Wno-type-defaults diff --git a/src/Data/Strict/Vector/Autogen/Internal/Check.hs b/src/Data/Strict/Vector/Autogen/Internal/Check.hs new file mode 100644 --- /dev/null +++ b/src/Data/Strict/Vector/Autogen/Internal/Check.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- Module : Data.Strict.Vector.Autogen.Internal.Check +-- Copyright : (c) Roman Leshchinskiy 2009 +-- Alexey Kuleshevich 2020-2022 +-- Aleksey Khudyakov 2020-2022 +-- Andrew Lelechenko 2020-2022 +-- License : BSD-style +-- +-- Maintainer : Haskell Libraries Team +-- Stability : experimental +-- Portability : non-portable +-- +-- Bounds checking infrastructure +-- +module Data.Strict.Vector.Autogen.Internal.Check ( + HasCallStack, + Checks(..), doChecks, + + internalError, + check, checkIndex, checkLength, checkSlice, + inRange +) where + +import GHC.Exts (Int(..), Int#) +import Prelude hiding( error, (&&), (||), not ) +import qualified Prelude as P +import GHC.Stack (HasCallStack) + +-- NOTE: This is a workaround for GHC's weird behaviour where it doesn't inline +-- these functions into unfoldings which makes the intermediate code size +-- explode. See http://hackage.haskell.org/trac/ghc/ticket/5539. +infixr 2 || +infixr 3 && + +not :: Bool -> Bool +{-# INLINE not #-} +not True = False +not False = True + +(&&) :: Bool -> Bool -> Bool +{-# INLINE (&&) #-} +False && _ = False +True && x = x + +(||) :: Bool -> Bool -> Bool +{-# INLINE (||) #-} +True || _ = True +False || x = x + + +data Checks = Bounds | Unsafe | Internal deriving( Eq ) + +doBoundsChecks :: Bool +#ifdef VECTOR_BOUNDS_CHECKS +doBoundsChecks = True +#else +doBoundsChecks = False +#endif + +doUnsafeChecks :: Bool +#ifdef VECTOR_UNSAFE_CHECKS +doUnsafeChecks = True +#else +doUnsafeChecks = False +#endif + +doInternalChecks :: Bool +#ifdef VECTOR_INTERNAL_CHECKS +doInternalChecks = True +#else +doInternalChecks = False +#endif + + +doChecks :: Checks -> Bool +{-# INLINE doChecks #-} +doChecks Bounds = doBoundsChecks +doChecks Unsafe = doUnsafeChecks +doChecks Internal = doInternalChecks + +internalError :: HasCallStack => String -> a +{-# NOINLINE internalError #-} +internalError msg + = P.error $ unlines + ["*** Internal error in package vector ***" + ,"*** Please submit a bug report at http://github.com/haskell/vector" + ,msg] + + +checkError :: HasCallStack => Checks -> String -> a +{-# NOINLINE checkError #-} +checkError kind msg + = case kind of + Internal -> internalError msg + _ -> P.error msg + +check :: HasCallStack => Checks -> String -> Bool -> a -> a +{-# INLINE check #-} +check kind msg cond x + | not (doChecks kind) || cond = x + | otherwise = checkError kind msg + +checkIndex_msg :: Int -> Int -> String +{-# INLINE checkIndex_msg #-} +checkIndex_msg (I# i#) (I# n#) = checkIndex_msg# i# n# + +checkIndex_msg# :: Int# -> Int# -> String +{-# NOINLINE checkIndex_msg# #-} +checkIndex_msg# i# n# = "index out of bounds " ++ show (I# i#, I# n#) + +checkIndex :: HasCallStack => Checks -> Int -> Int -> a -> a +{-# INLINE checkIndex #-} +checkIndex kind i n x + = check kind (checkIndex_msg i n) (inRange i n) x + + +checkLength_msg :: Int -> String +{-# INLINE checkLength_msg #-} +checkLength_msg (I# n#) = checkLength_msg# n# + +checkLength_msg# :: Int# -> String +{-# NOINLINE checkLength_msg# #-} +checkLength_msg# n# = "negative length " ++ show (I# n#) + +checkLength :: HasCallStack => Checks -> Int -> a -> a +{-# INLINE checkLength #-} +checkLength kind n = check kind (checkLength_msg n) (n >= 0) + + +checkSlice_msg :: Int -> Int -> Int -> String +{-# INLINE checkSlice_msg #-} +checkSlice_msg (I# i#) (I# m#) (I# n#) = checkSlice_msg# i# m# n# + +checkSlice_msg# :: Int# -> Int# -> Int# -> String +{-# NOINLINE checkSlice_msg# #-} +checkSlice_msg# i# m# n# = "invalid slice " ++ show (I# i#, I# m#, I# n#) + +checkSlice :: HasCallStack => Checks -> Int -> Int -> Int -> a -> a +{-# INLINE checkSlice #-} +checkSlice kind i m n x + = check kind (checkSlice_msg i m n) (i >= 0 && m >= 0 && m <= n - i) x + +-- Lengths are never negative, so we can check @0 <= i < length v@ +-- using one unsigned comparison. +inRange :: Int -> Int -> Bool +{-# INLINE inRange #-} +inRange i n = (fromIntegral i :: Word) < (fromIntegral n :: Word) diff --git a/src/Data/Strict/Vector/Autogen/Mutable.hs b/src/Data/Strict/Vector/Autogen/Mutable.hs --- a/src/Data/Strict/Vector/Autogen/Mutable.hs +++ b/src/Data/Strict/Vector/Autogen/Mutable.hs @@ -1,20 +1,27 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, BangPatterns, TypeFamilies #-} - +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.Strict.Vector.Autogen.Mutable -- Copyright : (c) Roman Leshchinskiy 2008-2010 +-- Alexey Kuleshevich 2020-2022 +-- Aleksey Khudyakov 2020-2022 +-- Andrew Lelechenko 2020-2022 -- License : BSD-style -- --- Maintainer : Roman Leshchinskiy +-- Maintainer : Haskell Libraries Team -- Stability : experimental -- Portability : non-portable -- -- Mutable boxed vectors. --- module Data.Strict.Vector.Autogen.Mutable ( -- * Mutable boxed vectors - MVector(..), IOVector, STVector, + MVector(MVector), IOVector, STVector, -- * Accessors @@ -40,7 +47,7 @@ clear, -- * Accessing individual elements - read, write, modify, modifyM, swap, exchange, + read, readMaybe, write, modify, modifyM, swap, exchange, unsafeRead, unsafeWrite, unsafeModify, unsafeModifyM, unsafeSwap, unsafeExchange, -- * Folds @@ -54,15 +61,18 @@ nextPermutation, -- ** Filling and copying - set, copy, move, unsafeCopy, unsafeMove, -- ** Arrays - fromMutableArray, toMutableArray + fromMutableArray, toMutableArray, + + -- * Re-exports + PrimMonad, PrimState, RealWorld ) where import Control.Monad (when, liftM) import qualified Data.Vector.Generic.Mutable as G +import Data.Strict.Vector.Autogen.Internal.Check import Data.Primitive.Array import Control.Monad.Primitive @@ -73,10 +83,16 @@ #include "vector.h" - +type role MVector nominal representational -- | Mutable boxed vectors keyed on the monad they live in ('IO' or @'ST' s@). -data MVector s a = MVector {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !(MutableArray s a) +data MVector s a = MVector { _offset :: {-# UNPACK #-} !Int + -- ^ Offset in underlying array + , _size :: {-# UNPACK #-} !Int + -- ^ Size of slice + , _array :: {-# UNPACK #-} !(MutableArray s a) + -- ^ Underlying array + } deriving ( Typeable ) type IOVector = MVector RealWorld @@ -158,14 +174,14 @@ {-# INLINE moveBackwards #-} moveBackwards :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m () moveBackwards !arr !dstOff !srcOff !len = - INTERNAL_CHECK(check) "moveBackwards" "not a backwards move" (dstOff < srcOff) + check Internal "not a backwards move" (dstOff < srcOff) $ loopM len $ \ i -> readArray arr (srcOff + i) >>= writeArray arr (dstOff + i) {-# INLINE moveForwardsSmallOverlap #-} -- Performs a move when dstOff > srcOff, optimized for when the overlap of the intervals is small. moveForwardsSmallOverlap :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m () moveForwardsSmallOverlap !arr !dstOff !srcOff !len = - INTERNAL_CHECK(check) "moveForwardsSmallOverlap" "not a forward move" (dstOff > srcOff) + check Internal "not a forward move" (dstOff > srcOff) $ do tmp <- newArray overlap uninitialised loopM overlap $ \ i -> readArray arr (dstOff + i) >>= writeArray tmp i @@ -176,7 +192,7 @@ -- Performs a move when dstOff > srcOff, optimized for when the overlap of the intervals is large. moveForwardsLargeOverlap :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m () moveForwardsLargeOverlap !arr !dstOff !srcOff !len = - INTERNAL_CHECK(check) "moveForwardsLargeOverlap" "not a forward move" (dstOff > srcOff) + check Internal "not a forward move" (dstOff > srcOff) $ do queue <- newArray nonOverlap uninitialised loopM nonOverlap $ \ i -> readArray arr (srcOff + i) >>= writeArray queue i @@ -206,7 +222,7 @@ {-# INLINE length #-} length = G.length --- | Check whether the vector is empty +-- | Check whether the vector is empty. null :: MVector s a -> Bool {-# INLINE null #-} null = G.null @@ -223,22 +239,37 @@ {-# INLINE slice #-} slice = G.slice +-- | Take the @n@ first elements of the mutable vector without making a +-- copy. For negative @n@, the empty vector is returned. If @n@ is larger +-- than the vector's length, the vector is returned unchanged. take :: Int -> MVector s a -> MVector s a {-# INLINE take #-} take = G.take +-- | Drop the @n@ first element of the mutable vector without making a +-- copy. For negative @n@, the vector is returned unchanged. If @n@ is +-- larger than the vector's length, the empty vector is returned. drop :: Int -> MVector s a -> MVector s a {-# INLINE drop #-} drop = G.drop -{-# INLINE splitAt #-} +-- | /O(1)/ Split the mutable vector into the first @n@ elements +-- and the remainder, without copying. +-- +-- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@, +-- but slightly more efficient. splitAt :: Int -> MVector s a -> (MVector s a, MVector s a) +{-# INLINE splitAt #-} splitAt = G.splitAt +-- | Drop the last element of the mutable vector without making a copy. +-- If the vector is empty, an exception is thrown. init :: MVector s a -> MVector s a {-# INLINE init #-} init = G.init +-- | Drop the first element of the mutable vector without making a copy. +-- If the vector is empty, an exception is thrown. tail :: MVector s a -> MVector s a {-# INLINE tail #-} tail = G.tail @@ -252,18 +283,24 @@ {-# INLINE unsafeSlice #-} unsafeSlice = G.unsafeSlice +-- | Unsafe variant of 'take'. If @n@ is out of range, it will +-- simply create an invalid slice that likely violate memory safety. unsafeTake :: Int -> MVector s a -> MVector s a {-# INLINE unsafeTake #-} unsafeTake = G.unsafeTake +-- | Unsafe variant of 'drop'. If @n@ is out of range, it will +-- simply create an invalid slice that likely violate memory safety. unsafeDrop :: Int -> MVector s a -> MVector s a {-# INLINE unsafeDrop #-} unsafeDrop = G.unsafeDrop +-- | Same as 'init', but doesn't do range checks. unsafeInit :: MVector s a -> MVector s a {-# INLINE unsafeInit #-} unsafeInit = G.unsafeInit +-- | Same as 'tail', but doesn't do range checks. unsafeTail :: MVector s a -> MVector s a {-# INLINE unsafeTail #-} unsafeTail = G.unsafeTail @@ -285,7 +322,7 @@ new = G.new -- | Create a mutable vector of the given length. The vector elements --- are set to bottom so accessing them will cause an exception. +-- are set to bottom, so accessing them will cause an exception. -- -- @since 0.5 unsafeNew :: PrimMonad m => Int -> m (MVector (PrimState m) a) @@ -306,6 +343,7 @@ -- | /O(n)/ Create a mutable vector of the given length (0 if the length is negative) -- and fill it with the results of applying the function to each index. +-- Iteration starts at index 0. -- -- @since 0.12.3.0 generate :: (PrimMonad m) => Int -> (Int -> a) -> m (MVector (PrimState m) a) @@ -330,14 +368,14 @@ -- ------- -- | Grow a boxed vector by the given number of elements. The number must be --- non-negative. Same semantics as in `G.grow` for generic vector. It differs +-- non-negative. This has the same semantics as 'G.grow' for generic vectors. It differs -- from @grow@ functions for unpacked vectors, however, in that only pointers to --- values are copied over, therefore values themselves will be shared between +-- values are copied over, therefore the values themselves will be shared between the -- two vectors. This is an important distinction to know about during memory --- usage analysis and in case when values themselves are of a mutable type, eg. --- `Data.IORef.IORef` or another mutable vector. +-- usage analysis and in case the values themselves are of a mutable type, e.g. +-- 'Data.IORef.IORef' or another mutable vector. -- --- ====__Examples__ +-- ==== __Examples__ -- -- >>> import qualified Data.Strict.Vector.Autogen as V -- >>> import qualified Data.Strict.Vector.Autogen.Mutable as MV @@ -350,30 +388,30 @@ -- -- >>> MV.write mv' 3 999 -- >>> MV.write mv' 4 777 --- >>> V.unsafeFreeze mv' +-- >>> V.freeze mv' -- [10,20,30,999,777] -- -- It is important to note that the source mutable vector is not affected when -- the newly allocated one is mutated. -- -- >>> MV.write mv' 2 888 --- >>> V.unsafeFreeze mv' +-- >>> V.freeze mv' -- [10,20,888,999,777] --- >>> V.unsafeFreeze mv +-- >>> V.freeze mv -- [10,20,30] -- -- @since 0.5 grow :: PrimMonad m - => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) + => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) {-# INLINE grow #-} grow = G.grow --- | Grow a vector by the given number of elements. The number must be non-negative but --- this is not checked. Same semantics as in `G.unsafeGrow` for generic vector. +-- | Grow a vector by the given number of elements. The number must be non-negative, but +-- this is not checked. This has the same semantics as 'G.unsafeGrow' for generic vectors. -- -- @since 0.5 unsafeGrow :: PrimMonad m - => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) + => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) {-# INLINE unsafeGrow #-} unsafeGrow = G.unsafeGrow @@ -381,7 +419,7 @@ -- ------------------------ -- | Reset all elements of the vector to some undefined value, clearing all --- references to external objects. This is usually a noop for unboxed vectors. +-- references to external objects. clear :: PrimMonad m => MVector (PrimState m) a -> m () {-# INLINE clear #-} clear = G.clear @@ -389,11 +427,36 @@ -- Accessing individual elements -- ----------------------------- --- | Yield the element at the given position. +-- | Yield the element at the given position. Will throw an exception if +-- the index is out of range. +-- +-- ==== __Examples__ +-- +-- >>> import qualified Data.Strict.Vector.Autogen.Mutable as MV +-- >>> v <- MV.generate 10 (\x -> x*x) +-- >>> MV.read v 3 +-- 9 read :: PrimMonad m => MVector (PrimState m) a -> Int -> m a {-# INLINE read #-} read = G.read +-- | Yield the element at the given position. Returns 'Nothing' if +-- the index is out of range. +-- +-- @since 0.13 +-- +-- ==== __Examples__ +-- +-- >>> import qualified Data.Strict.Vector.Autogen.Mutable as MV +-- >>> v <- MV.generate 10 (\x -> x*x) +-- >>> MV.readMaybe v 3 +-- Just 9 +-- >>> MV.readMaybe v 13 +-- Nothing +readMaybe :: (PrimMonad m) => MVector (PrimState m) a -> Int -> m (Maybe a) +{-# INLINE readMaybe #-} +readMaybe = G.readMaybe + -- | Replace the element at the given position. write :: PrimMonad m => MVector (PrimState m) a -> Int -> a -> m () {-# INLINE write #-} @@ -472,7 +535,7 @@ copy = G.copy -- | Copy a vector. The two vectors must have the same length and may not --- overlap. This is not checked. +-- overlap, but this is not checked. unsafeCopy :: PrimMonad m => MVector (PrimState m) a -- ^ target -> MVector (PrimState m) a -- ^ source -> m () @@ -505,13 +568,15 @@ {-# INLINE unsafeMove #-} unsafeMove = G.unsafeMove --- | Compute the next (lexicographically) permutation of given vector in-place. --- Returns False when input is the last permutation -nextPermutation :: (PrimMonad m,Ord e) => MVector (PrimState m) e -> m Bool +-- Modifying vectors +-- ----------------- + +-- | Compute the (lexicographically) next permutation of the given vector in-place. +-- Returns False when the input is the last permutation. +nextPermutation :: (PrimMonad m, Ord e) => MVector (PrimState m) e -> m Bool {-# INLINE nextPermutation #-} nextPermutation = G.nextPermutation - -- Folds -- ----- @@ -530,7 +595,7 @@ imapM_ = G.imapM_ -- | /O(n)/ Apply the monadic action to every element of the vector, --- discarding the results. It's same as the @flip mapM_@. +-- discarding the results. It's the same as @flip mapM_@. -- -- @since 0.12.3.0 forM_ :: (PrimMonad m) => MVector (PrimState m) a -> (a -> m b) -> m () @@ -538,7 +603,7 @@ forM_ = G.forM_ -- | /O(n)/ Apply the monadic action to every element of the vector --- and its index, discarding the results. It's same as the @flip imapM_@. +-- and its index, discarding the results. It's the same as @flip imapM_@. -- -- @since 0.12.3.0 iforM_ :: (PrimMonad m) => MVector (PrimState m) a -> (Int -> a -> m b) -> m () @@ -559,14 +624,14 @@ {-# INLINE foldl' #-} foldl' = G.foldl' --- | /O(n)/ Pure left fold (function applied to each element and its index). +-- | /O(n)/ Pure left fold using a function applied to each element and its index. -- -- @since 0.12.3.0 ifoldl :: (PrimMonad m) => (b -> Int -> a -> b) -> b -> MVector (PrimState m) a -> m b {-# INLINE ifoldl #-} ifoldl = G.ifoldl --- | /O(n)/ Pure left fold with strict accumulator (function applied to each element and its index). +-- | /O(n)/ Pure left fold with strict accumulator using a function applied to each element and its index. -- -- @since 0.12.3.0 ifoldl' :: (PrimMonad m) => (b -> Int -> a -> b) -> b -> MVector (PrimState m) a -> m b @@ -587,15 +652,15 @@ {-# INLINE foldr' #-} foldr' = G.foldr' --- | /O(n)/ Pure right fold (function applied to each element and its index). +-- | /O(n)/ Pure right fold using a function applied to each element and its index. -- -- @since 0.12.3.0 ifoldr :: (PrimMonad m) => (Int -> a -> b -> b) -> b -> MVector (PrimState m) a -> m b {-# INLINE ifoldr #-} ifoldr = G.ifoldr --- | /O(n)/ Pure right fold with strict accumulator (function applied --- to each element and its index). +-- | /O(n)/ Pure right fold with strict accumulator using a function applied +-- to each element and its index. -- -- @since 0.12.3.0 ifoldr' :: (PrimMonad m) => (Int -> a -> b -> b) -> b -> MVector (PrimState m) a -> m b @@ -616,14 +681,14 @@ {-# INLINE foldM' #-} foldM' = G.foldM' --- | /O(n)/ Monadic fold (action applied to each element and its index). +-- | /O(n)/ Monadic fold using a function applied to each element and its index. -- -- @since 0.12.3.0 ifoldM :: (PrimMonad m) => (b -> Int -> a -> m b) -> b -> MVector (PrimState m) a -> m b {-# INLINE ifoldM #-} ifoldM = G.ifoldM --- | /O(n)/ Monadic fold with strict accumulator (action applied to each element and its index). +-- | /O(n)/ Monadic fold with strict accumulator using a function applied to each element and its index. -- -- @since 0.12.3.0 ifoldM' :: (PrimMonad m) => (b -> Int -> a -> m b) -> b -> MVector (PrimState m) a -> m b @@ -644,15 +709,15 @@ {-# INLINE foldrM' #-} foldrM' = G.foldrM' --- | /O(n)/ Monadic right fold (action applied to each element and its index). +-- | /O(n)/ Monadic right fold using a function applied to each element and its index. -- -- @since 0.12.3.0 ifoldrM :: (PrimMonad m) => (Int -> a -> b -> m b) -> b -> MVector (PrimState m) a -> m b {-# INLINE ifoldrM #-} ifoldrM = G.ifoldrM --- | /O(n)/ Monadic right fold with strict accumulator (action applied --- to each element and its index). +-- | /O(n)/ Monadic right fold with strict accumulator using a function applied +-- to each element and its index. -- -- @since 0.12.3.0 ifoldrM' :: (PrimMonad m) => (Int -> a -> b -> m b) -> b -> MVector (PrimState m) a -> m b @@ -669,7 +734,7 @@ {-# INLINE fromMutableArray #-} fromMutableArray marr = let size = sizeofMutableArray marr - in MVector 0 size `liftM` cloneMutableArray marr 0 size + in MVector 0 size `liftM` cloneMutableArray marr 0 size -- | /O(n)/ Make a copy of a mutable vector into a new mutable array. -- diff --git a/strict-containers.cabal b/strict-containers.cabal --- a/strict-containers.cabal +++ b/strict-containers.cabal @@ -1,5 +1,6 @@ +Cabal-Version: 2.2 Name: strict-containers -Version: 0.1 +Version: 0.2 Synopsis: Strict containers. Category: Data, Data Structures Description: @@ -38,30 +39,32 @@ . -- generated list for versions -- DO NOT EDIT below, AUTOGEN versions - * containers v0.6.4.1 - * unordered-containers v0.2.13.0 - * vector v0.12.3.0 + * containers v0.6.6 + * unordered-containers v0.2.19.1 + * vector vector-0.13.0.0 -- DO NOT EDIT above, AUTOGEN versions -License: BSD3 +License: BSD-3-Clause License-File: LICENSE Maintainer: Ximin Luo Copyright: (c) 2021 by Ximin Luo Homepage: https://github.com/haskellari/strict-containers -Cabal-Version: >= 1.10 Build-type: Simple extra-source-files: CHANGELOG.md -- generated list for includes -- DO NOT EDIT below, AUTOGEN includes + include/vector.h include/containers.h -- DO NOT EDIT above, AUTOGEN includes tested-with: GHC ==8.2.2 || ==8.4.4 || ==8.6.5 - || ==8.8.3 - || ==8.10.4 - || ==9.0.1 + || ==8.8.4 + || ==8.10.7 + || ==9.0.2 + || ==9.2.4 + || ==9.4.2 library default-language: Haskell2010 @@ -69,18 +72,19 @@ ghc-options: -Wall build-depends: - base >= 4.5.0.0 && < 5 - , array >= 0.4.0.0 - , binary >= 0.8.4.1 && < 0.9 - , containers >= 0.5.9.2 && < 0.7 - , deepseq >= 1.2 && < 1.5 - , indexed-traversable >= 0.1.1 && < 0.2 - , hashable >= 1.2.7.0 && < 1.4 - , primitive >= 0.6.4.0 && < 0.8 - , unordered-containers >= 0.2 && < 0.3 - , strict >= 0.4 && < 0.5 - , vector >= 0.12 && < 0.13 - , vector-binary-instances >= 0.2 && < 0.3 + base >= 4.5.0.0 && < 5 + , array >= 0.4.0.0 + , binary >= 0.8.4.1 && < 0.9 + , containers >= 0.6.6 && < 0.7 + , deepseq >= 1.2 && < 1.5 + , indexed-traversable >= 0.1.1 && < 0.2 + , hashable >= 1.2.7.0 && < 1.5 + , primitive >= 0.6.4.0 && < 0.8 + , unordered-containers >= 0.2.19.1 && < 0.3 + , strict >= 0.4 && < 0.5 + , template-haskell + , vector >= 0.13.0.0 && < 0.14 + , vector-binary-instances >= 0.2.2.0 && < 0.3 exposed-modules: Data.Strict.HashMap @@ -92,7 +96,6 @@ Data.Strict.HashMap.Autogen.Internal.Array Data.Strict.HashMap.Autogen.Internal.Strict Data.Strict.HashMap.Autogen.Internal.List - Data.Strict.HashMap.Autogen.Internal.Unsafe -- DO NOT EDIT above, AUTOGEN HashMap Data.Strict.HashSet Data.Strict.IntMap @@ -144,53 +147,51 @@ -- DO NOT EDIT below, AUTOGEN Vector Data.Strict.Vector.Autogen Data.Strict.Vector.Autogen.Mutable + Data.Strict.Vector.Autogen.Internal.Check -- DO NOT EDIT above, AUTOGEN Vector include-dirs: include -- generated list for tests -- DO NOT EDIT below, AUTOGEN tests +common containers-deps + build-depends: + array >=0.4.0.0 + , base >=4.9.1 && <5 + , deepseq >=1.2 && <1.5 + , template-haskell + +common containers-test-deps + import: containers-deps + build-depends: + strict-containers,containers + , QuickCheck >=2.7.1 + , tasty + , tasty-hunit + , tasty-quickcheck + , transformers + test-suite map-strict-properties + import: containers-test-deps default-language: Haskell2010 hs-source-dirs: tests main-is: map-properties.hs type: exitcode-stdio-1.0 - build-depends: containers, strict-containers - build-depends: - array >=0.4.0.0 - , base >=4.6 && <5 - , deepseq >=1.2 && <1.5 - cpp-options: -DSTRICT + ghc-options: -O2 other-extensions: BangPatterns CPP - build-depends: - HUnit - , QuickCheck >=2.7.1 - , test-framework - , test-framework-hunit - , test-framework-quickcheck2 - , transformers - test-suite map-strictness-properties + import: containers-test-deps default-language: Haskell2010 hs-source-dirs: tests main-is: map-strictness.hs type: exitcode-stdio-1.0 - build-depends: containers, strict-containers build-depends: - array >=0.4.0.0 - , base >=4.6 && <5 - , ChasingBottoms - , deepseq >=1.2 && <1.5 - , HUnit - , QuickCheck >=2.7.1 - , test-framework >=0.3.3 - , test-framework-quickcheck2 >=0.2.9 - , test-framework-hunit + ChasingBottoms ghc-options: -Wall other-extensions: @@ -200,33 +201,28 @@ other-modules: Utils.IsUnit + if impl(ghc >= 8.6) + build-depends: + nothunks + other-modules: + Utils.NoThunks + test-suite intmap-strict-properties + import: containers-test-deps default-language: Haskell2010 hs-source-dirs: tests main-is: intmap-properties.hs type: exitcode-stdio-1.0 cpp-options: -DSTRICT other-modules: IntMapValidity - build-depends: strict-containers - build-depends: - array >=0.4.0.0 - , base >=4.6 && <5 - , deepseq >=1.2 && <1.5 ghc-options: -O2 other-extensions: BangPatterns CPP - build-depends: containers, strict-containers - build-depends: - HUnit - , QuickCheck >=2.7.1 - , test-framework - , test-framework-hunit - , test-framework-quickcheck2 - test-suite intmap-strictness-properties + import: containers-test-deps default-language: Haskell2010 hs-source-dirs: tests main-is: intmap-strictness.hs @@ -235,64 +231,32 @@ BangPatterns CPP - build-depends: containers, strict-containers build-depends: - array >=0.4.0.0 - , base >=4.6 && <5 - , ChasingBottoms - , deepseq >=1.2 && <1.5 - , HUnit - , QuickCheck >=2.7.1 - , test-framework >=0.3.3 - , test-framework-quickcheck2 >=0.2.9 - , test-framework-hunit + ChasingBottoms ghc-options: -Wall other-modules: Utils.IsUnit + if impl(ghc >= 8.6) + build-depends: + nothunks + other-modules: + Utils.NoThunks + test-suite seq-properties + import: containers-test-deps default-language: Haskell2010 hs-source-dirs: tests main-is: seq-properties.hs type: exitcode-stdio-1.0 - build-depends: strict-containers - build-depends: - array >=0.4.0.0 - , base >=4.6 && <5 - , deepseq >=1.2 && <1.5 ghc-options: -O2 other-extensions: BangPatterns CPP - build-depends: - QuickCheck >=2.7.1 - , test-framework - , test-framework-quickcheck2 - , transformers - -test-suite hashmap-strict-properties - hs-source-dirs: tests - main-is: HashMapProperties.hs - type: exitcode-stdio-1.0 - - build-depends: - base, - containers >= 0.5.8, - hashable >= 1.0.1.1, - QuickCheck >= 2.4.0.1, - test-framework >= 0.3.3, - test-framework-quickcheck2 >= 0.2.9, - strict-containers, - unordered-containers - - default-language: Haskell2010 - ghc-options: -Wall - cpp-options: -DASSERTS -DSTRICT - test-suite vector-tests-O0 Default-Language: Haskell2010 type: exitcode-stdio-1.0 @@ -313,21 +277,20 @@ QuickCheck >= 2.9 && < 2.15, HUnit, tasty, tasty-hunit, tasty-quickcheck, transformers >= 0.2.0.0 - if !impl(ghc > 8.0) - Build-Depends: semigroups default-extensions: CPP, ScopedTypeVariables, PatternGuards, MultiParamTypeClasses, FlexibleContexts, - Rank2Types, + RankNTypes, TypeSynonymInstances, TypeFamilies, TemplateHaskell Ghc-Options: -O0 -threaded Ghc-Options: -Wall + -- DO NOT EDIT above, AUTOGEN tests diff --git a/tests/HashMapProperties.hs b/tests/HashMapProperties.hs deleted file mode 100644 --- a/tests/HashMapProperties.hs +++ /dev/null @@ -1,591 +0,0 @@ -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- because of Arbitrary (HashMap k v) - --- | Tests for the 'Data.Strict.HashMap.Autogen.Lazy' module. We test functions by --- comparing them to a simpler model, an association list. - -module Main (main) where - -import Control.Monad ( guard ) -import qualified Data.Foldable as Foldable -#if MIN_VERSION_base(4,10,0) -import Data.Bifoldable -#endif -import Data.Function (on) -import Data.Hashable (Hashable(hashWithSalt)) -import qualified Data.List as L -import Data.Ord (comparing) -#if defined(STRICT) -import Data.Strict.HashMap.Autogen.Strict (HashMap) -import qualified Data.Strict.HashMap.Autogen.Strict as HM -import qualified Data.Map.Strict as M -#else -import Data.Strict.HashMap.Autogen.Lazy (HashMap) -import qualified Data.Strict.HashMap.Autogen.Lazy as HM -import qualified Data.Map.Lazy as M -#endif -import Test.QuickCheck (Arbitrary(..), Property, (==>), (===), forAll, elements) -import Test.Framework (Test, defaultMain, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity (..)) -#endif -import Control.Applicative (Const (..)) -import Test.QuickCheck.Function (Fun, apply) -import Test.QuickCheck.Poly (A, B) - --- Key type that generates more hash collisions. -newtype Key = K { unK :: Int } - deriving (Arbitrary, Eq, Ord, Read, Show) - -instance Hashable Key where - hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20 - -instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where - arbitrary = fmap (HM.fromList) arbitrary - ------------------------------------------------------------------------- --- * Properties - ------------------------------------------------------------------------- --- ** Instances - -pEq :: [(Key, Int)] -> [(Key, Int)] -> Bool -pEq xs = (M.fromList xs ==) `eq` (HM.fromList xs ==) - -pNeq :: [(Key, Int)] -> [(Key, Int)] -> Bool -pNeq xs = (M.fromList xs /=) `eq` (HM.fromList xs /=) - --- We cannot compare to `Data.Map` as ordering is different. -pOrd1 :: [(Key, Int)] -> Bool -pOrd1 xs = compare x x == EQ - where - x = HM.fromList xs - -pOrd2 :: [(Key, Int)] -> [(Key, Int)] -> [(Key, Int)] -> Bool -pOrd2 xs ys zs = case (compare x y, compare y z) of - (EQ, o) -> compare x z == o - (o, EQ) -> compare x z == o - (LT, LT) -> compare x z == LT - (GT, GT) -> compare x z == GT - (LT, GT) -> True -- ys greater than xs and zs. - (GT, LT) -> True - where - x = HM.fromList xs - y = HM.fromList ys - z = HM.fromList zs - -pOrd3 :: [(Key, Int)] -> [(Key, Int)] -> Bool -pOrd3 xs ys = case (compare x y, compare y x) of - (EQ, EQ) -> True - (LT, GT) -> True - (GT, LT) -> True - _ -> False - where - x = HM.fromList xs - y = HM.fromList ys - -pOrdEq :: [(Key, Int)] -> [(Key, Int)] -> Bool -pOrdEq xs ys = case (compare x y, x == y) of - (EQ, True) -> True - (LT, False) -> True - (GT, False) -> True - _ -> False - where - x = HM.fromList xs - y = HM.fromList ys - -pReadShow :: [(Key, Int)] -> Bool -pReadShow xs = M.fromList xs == read (show (M.fromList xs)) - -pFunctor :: [(Key, Int)] -> Bool -pFunctor = fmap (+ 1) `eq_` fmap (+ 1) - -pFoldable :: [(Int, Int)] -> Bool -pFoldable = (L.sort . Foldable.foldr (:) []) `eq` - (L.sort . Foldable.foldr (:) []) - -pHashable :: [(Key, Int)] -> [Int] -> Int -> Property -pHashable xs is salt = - x == y ==> hashWithSalt salt x === hashWithSalt salt y - where - xs' = L.nubBy (\(k,_) (k',_) -> k == k') xs - ys = shuffle is xs' - x = HM.fromList xs' - y = HM.fromList ys - -- Shuffle the list using indexes in the second - shuffle :: [Int] -> [a] -> [a] - shuffle idxs = L.map snd - . L.sortBy (comparing fst) - . L.zip (idxs ++ [L.maximum (0:is) + 1 ..]) - ------------------------------------------------------------------------- --- ** Basic interface - -pSize :: [(Key, Int)] -> Bool -pSize = M.size `eq` HM.size - -pMember :: Key -> [(Key, Int)] -> Bool -pMember k = M.member k `eq` HM.member k - -pLookup :: Key -> [(Key, Int)] -> Bool -pLookup k = M.lookup k `eq` HM.lookup k - -pLookupOperator :: Key -> [(Key, Int)] -> Bool -pLookupOperator k = M.lookup k `eq` (HM.!? k) - -pInsert :: Key -> Int -> [(Key, Int)] -> Bool -pInsert k v = M.insert k v `eq_` HM.insert k v - -pDelete :: Key -> [(Key, Int)] -> Bool -pDelete k = M.delete k `eq_` HM.delete k - -newtype AlwaysCollide = AC Int - deriving (Arbitrary, Eq, Ord, Show) - -instance Hashable AlwaysCollide where - hashWithSalt _ _ = 1 - --- White-box test that tests the case of deleting one of two keys from --- a map, where the keys' hash values collide. -pDeleteCollision :: AlwaysCollide -> AlwaysCollide -> AlwaysCollide -> Int - -> Property -pDeleteCollision k1 k2 k3 idx = (k1 /= k2) && (k2 /= k3) && (k1 /= k3) ==> - HM.member toKeep $ HM.delete toDelete $ - HM.fromList [(k1, 1 :: Int), (k2, 2), (k3, 3)] - where - which = idx `mod` 3 - toDelete - | which == 0 = k1 - | which == 1 = k2 - | which == 2 = k3 - | otherwise = error "Impossible" - toKeep - | which == 0 = k2 - | which == 1 = k3 - | which == 2 = k1 - | otherwise = error "Impossible" - -pInsertWith :: Key -> [(Key, Int)] -> Bool -pInsertWith k = M.insertWith (+) k 1 `eq_` HM.insertWith (+) k 1 - -pAdjust :: Key -> [(Key, Int)] -> Bool -pAdjust k = M.adjust succ k `eq_` HM.adjust succ k - -pUpdateAdjust :: Key -> [(Key, Int)] -> Bool -pUpdateAdjust k = M.update (Just . succ) k `eq_` HM.update (Just . succ) k - -pUpdateDelete :: Key -> [(Key, Int)] -> Bool -pUpdateDelete k = M.update (const Nothing) k `eq_` HM.update (const Nothing) k - -pAlterAdjust :: Key -> [(Key, Int)] -> Bool -pAlterAdjust k = M.alter (fmap succ) k `eq_` HM.alter (fmap succ) k - -pAlterInsert :: Key -> [(Key, Int)] -> Bool -pAlterInsert k = M.alter (const $ Just 3) k `eq_` HM.alter (const $ Just 3) k - -pAlterDelete :: Key -> [(Key, Int)] -> Bool -pAlterDelete k = M.alter (const Nothing) k `eq_` HM.alter (const Nothing) k - - --- We choose the list functor here because we don't fuss with --- it in alterF rules and because it has a sufficiently interesting --- structure to have a good chance of breaking if something is wrong. -pAlterF :: Key -> Fun (Maybe A) [Maybe A] -> [(Key, A)] -> Property -pAlterF k f xs = - fmap M.toAscList (M.alterF (apply f) k (M.fromList xs)) - === - fmap toAscList (HM.alterF (apply f) k (HM.fromList xs)) - -#if !MIN_VERSION_base(4,8,0) -newtype Identity a = Identity {runIdentity :: a} -instance Functor Identity where - fmap f (Identity x) = Identity (f x) -#endif - -pAlterFAdjust :: Key -> [(Key, Int)] -> Bool -pAlterFAdjust k = - runIdentity . M.alterF (Identity . fmap succ) k `eq_` - runIdentity . HM.alterF (Identity . fmap succ) k - -pAlterFInsert :: Key -> [(Key, Int)] -> Bool -pAlterFInsert k = - runIdentity . M.alterF (const . Identity . Just $ 3) k `eq_` - runIdentity . HM.alterF (const . Identity . Just $ 3) k - -pAlterFInsertWith :: Key -> Fun Int Int -> [(Key, Int)] -> Bool -pAlterFInsertWith k f = - runIdentity . M.alterF (Identity . Just . maybe 3 (apply f)) k `eq_` - runIdentity . HM.alterF (Identity . Just . maybe 3 (apply f)) k - -pAlterFDelete :: Key -> [(Key, Int)] -> Bool -pAlterFDelete k = - runIdentity . M.alterF (const (Identity Nothing)) k `eq_` - runIdentity . HM.alterF (const (Identity Nothing)) k - -pAlterFLookup :: Key - -> Fun (Maybe A) B - -> [(Key, A)] -> Bool -pAlterFLookup k f = - getConst . M.alterF (Const . apply f :: Maybe A -> Const B (Maybe A)) k - `eq` - getConst . HM.alterF (Const . apply f) k - -pSubmap :: [(Key, Int)] -> [(Key, Int)] -> Bool -pSubmap xs ys = M.isSubmapOf (M.fromList xs) (M.fromList ys) == - HM.isSubmapOf (HM.fromList xs) (HM.fromList ys) - -pSubmapReflexive :: HashMap Key Int -> Bool -pSubmapReflexive m = HM.isSubmapOf m m - -pSubmapUnion :: HashMap Key Int -> HashMap Key Int -> Bool -pSubmapUnion m1 m2 = HM.isSubmapOf m1 (HM.union m1 m2) - -pNotSubmapUnion :: HashMap Key Int -> HashMap Key Int -> Property -pNotSubmapUnion m1 m2 = not (HM.isSubmapOf m1 m2) ==> HM.isSubmapOf m1 (HM.union m1 m2) - -pSubmapDifference :: HashMap Key Int -> HashMap Key Int -> Bool -pSubmapDifference m1 m2 = HM.isSubmapOf (HM.difference m1 m2) m1 - -pNotSubmapDifference :: HashMap Key Int -> HashMap Key Int -> Property -pNotSubmapDifference m1 m2 = - not (HM.null (HM.intersection m1 m2)) ==> - not (HM.isSubmapOf m1 (HM.difference m1 m2)) - -pSubmapDelete :: HashMap Key Int -> Property -pSubmapDelete m = not (HM.null m) ==> - forAll (elements (HM.keys m)) $ \k -> - HM.isSubmapOf (HM.delete k m) m - -pNotSubmapDelete :: HashMap Key Int -> Property -pNotSubmapDelete m = - not (HM.null m) ==> - forAll (elements (HM.keys m)) $ \k -> - not (HM.isSubmapOf m (HM.delete k m)) - -pSubmapInsert :: Key -> Int -> HashMap Key Int -> Property -pSubmapInsert k v m = not (HM.member k m) ==> HM.isSubmapOf m (HM.insert k v m) - -pNotSubmapInsert :: Key -> Int -> HashMap Key Int -> Property -pNotSubmapInsert k v m = not (HM.member k m) ==> not (HM.isSubmapOf (HM.insert k v m) m) - ------------------------------------------------------------------------- --- ** Combine - -pUnion :: [(Key, Int)] -> [(Key, Int)] -> Bool -pUnion xs ys = M.union (M.fromList xs) `eq_` HM.union (HM.fromList xs) $ ys - -pUnionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool -pUnionWith xs ys = M.unionWith (-) (M.fromList xs) `eq_` - HM.unionWith (-) (HM.fromList xs) $ ys - -pUnionWithKey :: [(Key, Int)] -> [(Key, Int)] -> Bool -pUnionWithKey xs ys = M.unionWithKey go (M.fromList xs) `eq_` - HM.unionWithKey go (HM.fromList xs) $ ys - where - go :: Key -> Int -> Int -> Int - go (K k) i1 i2 = k - i1 + i2 - -pUnions :: [[(Key, Int)]] -> Bool -pUnions xss = M.toAscList (M.unions (map M.fromList xss)) == - toAscList (HM.unions (map HM.fromList xss)) - ------------------------------------------------------------------------- --- ** Transformations - -pMap :: [(Key, Int)] -> Bool -pMap = M.map (+ 1) `eq_` HM.map (+ 1) - -pTraverse :: [(Key, Int)] -> Bool -pTraverse xs = - L.sort (fmap (L.sort . M.toList) (M.traverseWithKey (\_ v -> [v + 1, v + 2]) (M.fromList (take 10 xs)))) - == L.sort (fmap (L.sort . HM.toList) (HM.traverseWithKey (\_ v -> [v + 1, v + 2]) (HM.fromList (take 10 xs)))) - ------------------------------------------------------------------------- --- ** Difference and intersection - -pDifference :: [(Key, Int)] -> [(Key, Int)] -> Bool -pDifference xs ys = M.difference (M.fromList xs) `eq_` - HM.difference (HM.fromList xs) $ ys - -pDifferenceWith :: [(Key, Int)] -> [(Key, Int)] -> Bool -pDifferenceWith xs ys = M.differenceWith f (M.fromList xs) `eq_` - HM.differenceWith f (HM.fromList xs) $ ys - where - f x y = if x == 0 then Nothing else Just (x - y) - -pIntersection :: [(Key, Int)] -> [(Key, Int)] -> Bool -pIntersection xs ys = M.intersection (M.fromList xs) `eq_` - HM.intersection (HM.fromList xs) $ ys - -pIntersectionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool -pIntersectionWith xs ys = M.intersectionWith (-) (M.fromList xs) `eq_` - HM.intersectionWith (-) (HM.fromList xs) $ ys - -pIntersectionWithKey :: [(Key, Int)] -> [(Key, Int)] -> Bool -pIntersectionWithKey xs ys = M.intersectionWithKey go (M.fromList xs) `eq_` - HM.intersectionWithKey go (HM.fromList xs) $ ys - where - go :: Key -> Int -> Int -> Int - go (K k) i1 i2 = k - i1 - i2 - ------------------------------------------------------------------------- --- ** Folds - -pFoldr :: [(Int, Int)] -> Bool -pFoldr = (L.sort . M.foldr (:) []) `eq` (L.sort . HM.foldr (:) []) - -pFoldl :: [(Int, Int)] -> Bool -pFoldl = (L.sort . M.foldl (flip (:)) []) `eq` (L.sort . HM.foldl (flip (:)) []) - -#if MIN_VERSION_base(4,10,0) -pBifoldMap :: [(Int, Int)] -> Bool -pBifoldMap xs = concatMap f (HM.toList m) == bifoldMap (:[]) (:[]) m - where f (k, v) = [k, v] - m = HM.fromList xs - -pBifoldr :: [(Int, Int)] -> Bool -pBifoldr xs = concatMap f (HM.toList m) == bifoldr (:) (:) [] m - where f (k, v) = [k, v] - m = HM.fromList xs - -pBifoldl :: [(Int, Int)] -> Bool -pBifoldl xs = reverse (concatMap f $ HM.toList m) == bifoldl (flip (:)) (flip (:)) [] m - where f (k, v) = [k, v] - m = HM.fromList xs -#endif - -pFoldrWithKey :: [(Int, Int)] -> Bool -pFoldrWithKey = (sortByKey . M.foldrWithKey f []) `eq` - (sortByKey . HM.foldrWithKey f []) - where f k v z = (k, v) : z - -pFoldMapWithKey :: [(Int, Int)] -> Bool -pFoldMapWithKey = (sortByKey . M.foldMapWithKey f) `eq` - (sortByKey . HM.foldMapWithKey f) - where f k v = [(k, v)] - -pFoldrWithKey' :: [(Int, Int)] -> Bool -pFoldrWithKey' = (sortByKey . M.foldrWithKey' f []) `eq` - (sortByKey . HM.foldrWithKey' f []) - where f k v z = (k, v) : z - -pFoldlWithKey :: [(Int, Int)] -> Bool -pFoldlWithKey = (sortByKey . M.foldlWithKey f []) `eq` - (sortByKey . HM.foldlWithKey f []) - where f z k v = (k, v) : z - -pFoldlWithKey' :: [(Int, Int)] -> Bool -pFoldlWithKey' = (sortByKey . M.foldlWithKey' f []) `eq` - (sortByKey . HM.foldlWithKey' f []) - where f z k v = (k, v) : z - -pFoldl' :: [(Int, Int)] -> Bool -pFoldl' = (L.sort . M.foldl' (flip (:)) []) `eq` (L.sort . HM.foldl' (flip (:)) []) - -pFoldr' :: [(Int, Int)] -> Bool -pFoldr' = (L.sort . M.foldr' (:) []) `eq` (L.sort . HM.foldr' (:) []) - ------------------------------------------------------------------------- --- ** Filter - -pMapMaybeWithKey :: [(Key, Int)] -> Bool -pMapMaybeWithKey = M.mapMaybeWithKey f `eq_` HM.mapMaybeWithKey f - where f k v = guard (odd (unK k + v)) >> Just (v + 1) - -pMapMaybe :: [(Key, Int)] -> Bool -pMapMaybe = M.mapMaybe f `eq_` HM.mapMaybe f - where f v = guard (odd v) >> Just (v + 1) - -pFilter :: [(Key, Int)] -> Bool -pFilter = M.filter odd `eq_` HM.filter odd - -pFilterWithKey :: [(Key, Int)] -> Bool -pFilterWithKey = M.filterWithKey p `eq_` HM.filterWithKey p - where p k v = odd (unK k + v) - ------------------------------------------------------------------------- --- ** Conversions - --- The free magma is used to test that operations are applied in the --- same order. -data Magma a - = Leaf a - | Op (Magma a) (Magma a) - deriving (Show, Eq, Ord) - -instance Hashable a => Hashable (Magma a) where - hashWithSalt s (Leaf a) = hashWithSalt s (hashWithSalt (1::Int) a) - hashWithSalt s (Op m n) = hashWithSalt s (hashWithSalt (hashWithSalt (2::Int) m) n) - --- 'eq_' already calls fromList. -pFromList :: [(Key, Int)] -> Bool -pFromList = id `eq_` id - -pFromListWith :: [(Key, Int)] -> Bool -pFromListWith kvs = (M.toAscList $ M.fromListWith Op kvsM) == - (toAscList $ HM.fromListWith Op kvsM) - where kvsM = fmap (fmap Leaf) kvs - -pFromListWithKey :: [(Key, Int)] -> Bool -pFromListWithKey kvs = (M.toAscList $ M.fromListWithKey combine kvsM) == - (toAscList $ HM.fromListWithKey combine kvsM) - where kvsM = fmap (\(K k,v) -> (Leaf k, Leaf v)) kvs - combine k v1 v2 = Op k (Op v1 v2) - -pToList :: [(Key, Int)] -> Bool -pToList = M.toAscList `eq` toAscList - -pElems :: [(Key, Int)] -> Bool -pElems = (L.sort . M.elems) `eq` (L.sort . HM.elems) - -pKeys :: [(Key, Int)] -> Bool -pKeys = (L.sort . M.keys) `eq` (L.sort . HM.keys) - ------------------------------------------------------------------------- --- * Test list - -tests :: [Test] -tests = - [ - -- Instances - testGroup "instances" - [ testProperty "==" pEq - , testProperty "/=" pNeq - , testProperty "compare reflexive" pOrd1 - , testProperty "compare transitive" pOrd2 - , testProperty "compare antisymmetric" pOrd3 - , testProperty "Ord => Eq" pOrdEq - , testProperty "Read/Show" pReadShow - , testProperty "Functor" pFunctor - , testProperty "Foldable" pFoldable - , testProperty "Hashable" pHashable - ] - -- Basic interface - , testGroup "basic interface" - [ testProperty "size" pSize - , testProperty "member" pMember - , testProperty "lookup" pLookup - , testProperty "!?" pLookupOperator - , testProperty "insert" pInsert - , testProperty "delete" pDelete - , testProperty "deleteCollision" pDeleteCollision - , testProperty "insertWith" pInsertWith - , testProperty "adjust" pAdjust - , testProperty "updateAdjust" pUpdateAdjust - , testProperty "updateDelete" pUpdateDelete - , testProperty "alterAdjust" pAlterAdjust - , testProperty "alterInsert" pAlterInsert - , testProperty "alterDelete" pAlterDelete - , testProperty "alterF" pAlterF - , testProperty "alterFAdjust" pAlterFAdjust - , testProperty "alterFInsert" pAlterFInsert - , testProperty "alterFInsertWith" pAlterFInsertWith - , testProperty "alterFDelete" pAlterFDelete - , testProperty "alterFLookup" pAlterFLookup - , testGroup "isSubmapOf" - [ testProperty "container compatibility" pSubmap - , testProperty "m ⊆ m" pSubmapReflexive - , testProperty "m1 ⊆ m1 ∪ m2" pSubmapUnion - , testProperty "m1 ⊈ m2 ⇒ m1 ∪ m2 ⊈ m1" pNotSubmapUnion - , testProperty "m1\\m2 ⊆ m1" pSubmapDifference - , testProperty "m1 ∩ m2 ≠ ∅ ⇒ m1 ⊈ m1\\m2 " pNotSubmapDifference - , testProperty "delete k m ⊆ m" pSubmapDelete - , testProperty "m ⊈ delete k m " pNotSubmapDelete - , testProperty "k ∉ m ⇒ m ⊆ insert k v m" pSubmapInsert - , testProperty "k ∉ m ⇒ insert k v m ⊈ m" pNotSubmapInsert - ] - ] - -- Combine - , testProperty "union" pUnion - , testProperty "unionWith" pUnionWith - , testProperty "unionWithKey" pUnionWithKey - , testProperty "unions" pUnions - -- Transformations - , testProperty "map" pMap - , testProperty "traverse" pTraverse - -- Folds - , testGroup "folds" - [ testProperty "foldr" pFoldr - , testProperty "foldl" pFoldl -#if MIN_VERSION_base(4,10,0) - , testProperty "bifoldMap" pBifoldMap - , testProperty "bifoldr" pBifoldr - , testProperty "bifoldl" pBifoldl -#endif - , testProperty "foldrWithKey" pFoldrWithKey - , testProperty "foldlWithKey" pFoldlWithKey - , testProperty "foldrWithKey'" pFoldrWithKey' - , testProperty "foldlWithKey'" pFoldlWithKey' - , testProperty "foldl'" pFoldl' - , testProperty "foldr'" pFoldr' - , testProperty "foldMapWithKey" pFoldMapWithKey - ] - , testGroup "difference and intersection" - [ testProperty "difference" pDifference - , testProperty "differenceWith" pDifferenceWith - , testProperty "intersection" pIntersection - , testProperty "intersectionWith" pIntersectionWith - , testProperty "intersectionWithKey" pIntersectionWithKey - ] - -- Filter - , testGroup "filter" - [ testProperty "filter" pFilter - , testProperty "filterWithKey" pFilterWithKey - , testProperty "mapMaybe" pMapMaybe - , testProperty "mapMaybeWithKey" pMapMaybeWithKey - ] - -- Conversions - , testGroup "conversions" - [ testProperty "elems" pElems - , testProperty "keys" pKeys - , testProperty "fromList" pFromList - , testProperty "fromListWith" pFromListWith - , testProperty "fromListWithKey" pFromListWithKey - , testProperty "toList" pToList - ] - ] - ------------------------------------------------------------------------- --- * Model - -type Model k v = M.Map k v - --- | Check that a function operating on a 'HashMap' is equivalent to --- one operating on a 'Model'. -eq :: (Eq a, Eq k, Hashable k, Ord k) - => (Model k v -> a) -- ^ Function that modifies a 'Model' - -> (HM.HashMap k v -> a) -- ^ Function that modified a 'HashMap' in the same - -- way - -> [(k, v)] -- ^ Initial content of the 'HashMap' and 'Model' - -> Bool -- ^ True if the functions are equivalent -eq f g xs = g (HM.fromList xs) == f (M.fromList xs) - -infix 4 `eq` - -eq_ :: (Eq k, Eq v, Hashable k, Ord k) - => (Model k v -> Model k v) -- ^ Function that modifies a 'Model' - -> (HM.HashMap k v -> HM.HashMap k v) -- ^ Function that modified a - -- 'HashMap' in the same way - -> [(k, v)] -- ^ Initial content of the 'HashMap' - -- and 'Model' - -> Bool -- ^ True if the functions are - -- equivalent -eq_ f g = (M.toAscList . f) `eq` (toAscList . g) - -infix 4 `eq_` - ------------------------------------------------------------------------- --- * Test harness - -main :: IO () -main = defaultMain tests - ------------------------------------------------------------------------- --- * Helpers - -sortByKey :: Ord k => [(k, v)] -> [(k, v)] -sortByKey = L.sortBy (compare `on` fst) - -toAscList :: Ord k => HM.HashMap k v -> [(k, v)] -toAscList = L.sortBy (compare `on` fst) . HM.toList diff --git a/tests/IntMapValidity.hs b/tests/IntMapValidity.hs --- a/tests/IntMapValidity.hs +++ b/tests/IntMapValidity.hs @@ -2,7 +2,7 @@ import Data.Bits (xor, (.&.)) import Data.Strict.IntMap.Autogen.Internal -import Test.QuickCheck (Property, counterexample, property, (.&&.)) +import Test.Tasty.QuickCheck (Property, counterexample, property, (.&&.)) import Data.Strict.ContainersUtils.Autogen.BitUtil (bitcount) {-------------------------------------------------------------------- diff --git a/tests/Tests/Bundle.hs b/tests/Tests/Bundle.hs --- a/tests/Tests/Bundle.hs +++ b/tests/Tests/Bundle.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} module Tests.Bundle ( tests ) where import Boilerplater @@ -13,16 +14,11 @@ import Text.Show.Functions () import Data.List (foldl', foldl1', unfoldr, find, findIndex) --- migration from testframework to tasty -type Test = TestTree -#define COMMON_CONTEXT(a) \ - VANILLA_CONTEXT(a) - -#define VANILLA_CONTEXT(a) \ - Eq a, Show a, Arbitrary a, CoArbitrary a, TestData a, Model a ~ a, EqTest a ~ Property +type CommonContext a = ( Eq a, Show a, Arbitrary a, CoArbitrary a, TestData a + , Model a ~ a, EqTest a ~ Property) -testSanity :: forall v a. (COMMON_CONTEXT(a)) => S.Bundle v a -> [Test] +testSanity :: forall v a. (CommonContext a) => S.Bundle v a -> [TestTree] testSanity _ = [ testProperty "fromList.toList == id" prop_fromList_toList, testProperty "toList.fromList == id" prop_toList_fromList @@ -33,7 +29,7 @@ prop_toList_fromList :: P ([a] -> [a]) = (S.toList . (S.fromList :: [a] -> S.Bundle v a)) `eq` id -testPolymorphicFunctions :: forall v a. (COMMON_CONTEXT(a)) => S.Bundle v a -> [Test] +testPolymorphicFunctions :: forall v a. (CommonContext a) => S.Bundle v a -> [TestTree] testPolymorphicFunctions _ = $(testProperties [ 'prop_eq, @@ -151,7 +147,7 @@ = (\n f a -> S.unfoldr (limitUnfolds f) (a, n)) `eq` (\n f a -> unfoldr (limitUnfolds f) (a, n)) -testBoolFunctions :: forall v. S.Bundle v Bool -> [Test] +testBoolFunctions :: forall v. S.Bundle v Bool -> [TestTree] testBoolFunctions _ = $(testProperties ['prop_and, 'prop_or ]) where prop_and :: P (S.Bundle v Bool -> Bool) = S.and `eq` and diff --git a/tests/Tests/Vector/Boxed.hs b/tests/Tests/Vector/Boxed.hs --- a/tests/Tests/Vector/Boxed.hs +++ b/tests/Tests/Vector/Boxed.hs @@ -8,7 +8,9 @@ import GHC.Exts (inline) -testGeneralBoxedVector :: forall a. (CommonContext a Data.Strict.Vector.Vector, Ord a, Data a) => Data.Strict.Vector.Vector a -> [Test] +testGeneralBoxedVector + :: forall a. (CommonContext a Data.Strict.Vector.Vector, Ord a, Data a) + => Data.Strict.Vector.Vector a -> [TestTree] testGeneralBoxedVector dummy = concatMap ($ dummy) [ testSanity @@ -31,7 +33,9 @@ , testBoolFunctions ] -testNumericBoxedVector :: forall a. (CommonContext a Data.Strict.Vector.Vector, Ord a, Num a, Enum a, Random a, Data a) => Data.Strict.Vector.Vector a -> [Test] +testNumericBoxedVector + :: forall a. (CommonContext a Data.Strict.Vector.Vector, Ord a, Num a, Enum a, Random a, Data a) + => Data.Strict.Vector.Vector a -> [TestTree] testNumericBoxedVector dummy = concatMap ($ dummy) [ testGeneralBoxedVector @@ -44,4 +48,5 @@ testBoolBoxedVector (undefined :: Data.Strict.Vector.Vector Bool) , testGroup "Int" $ testNumericBoxedVector (undefined :: Data.Strict.Vector.Vector Int) + , testGroup "unstream" $ testUnstream (undefined :: Data.Strict.Vector.Vector Int) ] diff --git a/tests/Tests/Vector/Property.hs b/tests/Tests/Vector/Property.hs --- a/tests/Tests/Vector/Property.hs +++ b/tests/Tests/Vector/Property.hs @@ -18,10 +18,10 @@ , testNumFunctions , testNestedVectorFunctions , testDataFunctions + , testUnstream -- re-exports , Data , Random - , Test ) where import Boilerplater @@ -30,8 +30,6 @@ import Control.Monad import Control.Monad.ST import qualified Data.Traversable as T (Traversable(..)) -import Data.Foldable (Foldable(foldMap)) -import Data.Functor.Identity import Data.Orphans () import Data.Foldable (foldrM) import qualified Data.Vector.Generic as V @@ -46,7 +44,6 @@ import Text.Show.Functions () import Data.List -import Data.Monoid import qualified Control.Applicative as Applicative import System.Random (Random) @@ -67,8 +64,6 @@ type VectorContext a v = ( Eq (v a), Show (v a), Arbitrary (v a), CoArbitrary (v a) , TestData (v a), Model (v a) ~ [a], EqTest (v a) ~ Property, V.Vector v a) --- | migration hack for moving from TestFramework to Tasty -type Test = TestTree -- TODO: implement Vector equivalents of list functions for some of the commented out properties -- TODO: add tests for the other extra functions @@ -77,7 +72,7 @@ -- new, -- unsafeSlice, unsafeIndex, -testSanity :: forall a v. (CommonContext a v) => v a -> [Test] +testSanity :: forall a v. (CommonContext a v) => v a -> [TestTree] {-# INLINE testSanity #-} testSanity _ = [ testProperty "fromList.toList == id" prop_fromList_toList, @@ -91,7 +86,7 @@ prop_unstream_stream (v :: v a) = (V.unstream . V.stream) v == v prop_stream_unstream (s :: S.Bundle v a) = ((V.stream :: v a -> S.Bundle v a) . V.unstream) s == s -testPolymorphicFunctions :: forall a v. (CommonContext a v, VectorContext Int v) => v a -> [Test] +testPolymorphicFunctions :: forall a v. (CommonContext a v, VectorContext Int v) => v a -> [TestTree] -- FIXME: inlining of unboxed properties blows up the memory during compilation. See #272 --{-# INLINE testPolymorphicFunctions #-} testPolymorphicFunctions _ = $(testProperties [ @@ -174,6 +169,7 @@ 'prop_partition, {- 'prop_unstablePartition, -} 'prop_partitionWith, 'prop_span, 'prop_break, + 'prop_groupBy, -- Searching 'prop_elem, 'prop_notElem, @@ -339,6 +335,7 @@ = V.partitionWith `eq` partitionWith prop_span :: P ((a -> Bool) -> v a -> (v a, v a)) = V.span `eq` span prop_break :: P ((a -> Bool) -> v a -> (v a, v a)) = V.break `eq` break + prop_groupBy :: P ((a -> a -> Bool) -> v a -> [v a]) = V.groupBy `eq` groupBy prop_elem :: P (a -> v a -> Bool) = V.elem `eq` elem prop_notElem :: P (a -> v a -> Bool) = V.notElem `eq` notElem @@ -398,10 +395,10 @@ = V.scanl `eq` scanl prop_scanl' :: P ((a -> a -> a) -> a -> v a -> v a) = V.scanl' `eq` scanl - prop_scanl1 :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> - V.scanl1 `eq` scanl1 - prop_scanl1' :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> - V.scanl1' `eq` scanl1 + prop_scanl1 :: P ((a -> a -> a) -> v a -> v a) + = V.scanl1 `eq` scanl1 + prop_scanl1' :: P ((a -> a -> a) -> v a -> v a) + = V.scanl1' `eq` scanl1 prop_iscanl :: P ((Int -> a -> a -> a) -> a -> v a -> v a) = V.iscanl `eq` iscanl prop_iscanl' :: P ((Int -> a -> a -> a) -> a -> v a -> v a) @@ -423,10 +420,10 @@ = V.iscanr `eq` iscanr prop_iscanr' :: P ((Int -> a -> a -> a) -> a -> v a -> v a) = V.iscanr' `eq` iscanr - prop_scanr1 :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> - V.scanr1 `eq` scanr1 - prop_scanr1' :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> - V.scanr1' `eq` scanr1 + prop_scanr1 :: P ((a -> a -> a) -> v a -> v a) + = V.scanr1 `eq` scanr1 + prop_scanr1' :: P ((a -> a -> a) -> v a -> v a) + = V.scanr1' `eq` scanr1 prop_concatMap = forAll arbitrary $ \xs -> forAll (sized (\n -> resize (n `div` V.length xs) arbitrary)) $ \f -> unP prop f xs @@ -604,7 +601,7 @@ , VectorContext (a, a, a) v , VectorContext (Int, a) v ) - => v a -> [Test] + => v a -> [TestTree] {-# INLINE testTuplyFunctions #-} testTuplyFunctions _ = $(testProperties [ 'prop_zip, 'prop_zip3 , 'prop_unzip, 'prop_unzip3 @@ -623,30 +620,34 @@ where prop :: P (v a -> [(Int,a)] -> v a) = (V.//) `eq` (//) -testOrdFunctions :: forall a v. (CommonContext a v, Ord a, Ord (v a)) => v a -> [Test] +testOrdFunctions :: forall a v. (CommonContext a v, Ord a, Ord (v a)) => v a -> [TestTree] {-# INLINE testOrdFunctions #-} testOrdFunctions _ = $(testProperties ['prop_compare, 'prop_maximum, 'prop_minimum, 'prop_minIndex, 'prop_maxIndex, 'prop_maximumBy, 'prop_minimumBy, + 'prop_maximumOn, 'prop_minimumOn, 'prop_maxIndexBy, 'prop_minIndexBy, - 'prop_ListLastMaxIndexWins, 'prop_FalseListFirstMaxIndexWins ]) + 'prop_ListFirstMaxIndexWins, 'prop_FalseListFirstMaxIndexWins ]) where prop_compare :: P (v a -> v a -> Ordering) = compare `eq` compare prop_maximum :: P (v a -> a) = not . V.null ===> V.maximum `eq` maximum prop_minimum :: P (v a -> a) = not . V.null ===> V.minimum `eq` minimum prop_minIndex :: P (v a -> Int) = not . V.null ===> V.minIndex `eq` minIndex - prop_maxIndex :: P (v a -> Int) = not . V.null ===> V.maxIndex `eq` listMaxIndexFMW + prop_maxIndex :: P (v a -> Int) = not . V.null ===> V.maxIndex `eq` maxIndex prop_maximumBy :: P (v a -> a) = not . V.null ===> V.maximumBy compare `eq` maximum prop_minimumBy :: P (v a -> a) = not . V.null ===> V.minimumBy compare `eq` minimum + prop_maximumOn :: P (v a -> a) = + not . V.null ===> V.maximumOn id `eq` maximum + prop_minimumOn :: P (v a -> a) = + not . V.null ===> V.minimumOn id `eq` minimum prop_maxIndexBy :: P (v a -> Int) = - not . V.null ===> V.maxIndexBy compare `eq` listMaxIndexFMW - --- (maxIndex) - prop_ListLastMaxIndexWins :: P (v a -> Int) = - not . V.null ===> ( maxIndex . V.toList) `eq` listMaxIndexLMW + not . V.null ===> V.maxIndexBy compare `eq` maxIndex + prop_ListFirstMaxIndexWins :: P (v a -> Int) = + not . V.null ===> ( maxIndex . V.toList) `eq` listMaxIndexFMW prop_FalseListFirstMaxIndexWinsDesc :: P (v a -> Int) = (\x -> not $ V.null x && (V.uniq x /= x ) )===> ( maxIndex . V.toList) `eq` listMaxIndexFMW prop_FalseListFirstMaxIndexWins :: Property @@ -657,9 +658,6 @@ listMaxIndexFMW :: Ord a => [a] -> Int listMaxIndexFMW = ( fst . extractFMW . sconcat . DLE.fromList . fmap FMW . zip [0 :: Int ..]) -listMaxIndexLMW :: Ord a => [a] -> Int -listMaxIndexLMW = ( fst . extractLMW . sconcat . DLE.fromList . fmap LMW . zip [0 :: Int ..]) - newtype LastMaxWith a i = LMW {extractLMW:: (i,a)} deriving(Eq,Show,Read) instance (Ord a) => Semigroup (LastMaxWith a i) where @@ -674,7 +672,7 @@ | otherwise = x -testEnumFunctions :: forall a v. (CommonContext a v, Enum a, Ord a, Num a, Random a) => v a -> [Test] +testEnumFunctions :: forall a v. (CommonContext a v, Enum a, Ord a, Num a, Random a) => v a -> [TestTree] {-# INLINE testEnumFunctions #-} testEnumFunctions _ = $(testProperties [ 'prop_enumFromN, 'prop_enumFromThenN, @@ -706,7 +704,7 @@ where d = abs (j-i) -testMonoidFunctions :: forall a v. (CommonContext a v, Monoid (v a)) => v a -> [Test] +testMonoidFunctions :: forall a v. (CommonContext a v, Monoid (v a)) => v a -> [TestTree] {-# INLINE testMonoidFunctions #-} testMonoidFunctions _ = $(testProperties [ 'prop_mempty, 'prop_mappend, 'prop_mconcat ]) @@ -715,14 +713,14 @@ prop_mappend :: P (v a -> v a -> v a) = mappend `eq` mappend prop_mconcat :: P ([v a] -> v a) = mconcat `eq` mconcat -testFunctorFunctions :: forall a v. (CommonContext a v, Functor v) => v a -> [Test] +testFunctorFunctions :: forall a v. (CommonContext a v, Functor v) => v a -> [TestTree] {-# INLINE testFunctorFunctions #-} testFunctorFunctions _ = $(testProperties [ 'prop_fmap ]) where prop_fmap :: P ((a -> a) -> v a -> v a) = fmap `eq` fmap -testMonadFunctions :: forall a v. (CommonContext a v, VectorContext (a, a) v, MonadZip v) => v a -> [Test] +testMonadFunctions :: forall a v. (CommonContext a v, VectorContext (a, a) v, MonadZip v) => v a -> [TestTree] {-# INLINE testMonadFunctions #-} testMonadFunctions _ = $(testProperties [ 'prop_return, 'prop_bind , 'prop_mzip, 'prop_munzip @@ -741,7 +739,7 @@ , Show (v (Writer [a] a)) , TestData (v (Writer [a] a)) ) - => v a -> [Test] + => v a -> [TestTree] testSequenceFunctions _ = $(testProperties [ 'prop_sequence, 'prop_sequence_ ]) where @@ -750,7 +748,7 @@ prop_sequence_ :: P (v (Writer [a] a) -> Writer [a] ()) = V.sequence_ `eq` sequence_ -testApplicativeFunctions :: forall a v. (CommonContext a v, V.Vector v (a -> a), Applicative.Applicative v) => v a -> [Test] +testApplicativeFunctions :: forall a v. (CommonContext a v, V.Vector v (a -> a), Applicative.Applicative v) => v a -> [TestTree] {-# INLINE testApplicativeFunctions #-} testApplicativeFunctions _ = $(testProperties [ 'prop_applicative_pure, 'prop_applicative_appl ]) @@ -760,7 +758,7 @@ prop_applicative_appl :: [a -> a] -> P (v a -> v a) = \fs -> (Applicative.<*>) (V.fromList fs) `eq` (Applicative.<*>) fs -testAlternativeFunctions :: forall a v. (CommonContext a v, Applicative.Alternative v) => v a -> [Test] +testAlternativeFunctions :: forall a v. (CommonContext a v, Applicative.Alternative v) => v a -> [TestTree] {-# INLINE testAlternativeFunctions #-} testAlternativeFunctions _ = $(testProperties [ 'prop_alternative_empty, 'prop_alternative_or ]) @@ -769,21 +767,21 @@ prop_alternative_or :: P (v a -> v a -> v a) = (Applicative.<|>) `eq` (Applicative.<|>) -testBoolFunctions :: forall v. (CommonContext Bool v) => v Bool -> [Test] +testBoolFunctions :: forall v. (CommonContext Bool v) => v Bool -> [TestTree] {-# INLINE testBoolFunctions #-} testBoolFunctions _ = $(testProperties ['prop_and, 'prop_or]) where prop_and :: P (v Bool -> Bool) = V.and `eq` and prop_or :: P (v Bool -> Bool) = V.or `eq` or -testNumFunctions :: forall a v. (CommonContext a v, Num a) => v a -> [Test] +testNumFunctions :: forall a v. (CommonContext a v, Num a) => v a -> [TestTree] {-# INLINE testNumFunctions #-} testNumFunctions _ = $(testProperties ['prop_sum, 'prop_product]) where prop_sum :: P (v a -> a) = V.sum `eq` sum prop_product :: P (v a -> a) = V.product `eq` product -testNestedVectorFunctions :: forall a v. (CommonContext a v) => v a -> [Test] +testNestedVectorFunctions :: forall a v. (CommonContext a v) => v a -> [TestTree] {-# INLINE testNestedVectorFunctions #-} testNestedVectorFunctions _ = $(testProperties [ 'prop_concat @@ -791,7 +789,7 @@ where prop_concat :: P ([v a] -> v a) = V.concat `eq` concat -testDataFunctions :: forall a v. (CommonContext a v, Data a, Data (v a)) => v a -> [Test] +testDataFunctions :: forall a v. (CommonContext a v, Data a, Data (v a)) => v a -> [TestTree] {-# INLINE testDataFunctions #-} testDataFunctions _ = $(testProperties ['prop_glength]) where @@ -802,3 +800,32 @@ toA :: Data b => b -> Int toA x = maybe (glength x) (const 1) (cast x :: Maybe a) + +testUnstream :: forall v. (CommonContext Int v) => v Int -> [TestTree] +{-# INLINE testUnstream #-} +testUnstream _ = + [ testProperty "unstream == vunstream (exact)" $ \(n :: Int) -> + let v1,v2 :: v Int + v1 = runST $ V.freeze =<< MV.unstream (streamExact n) + v2 = runST $ V.freeze =<< MV.vunstream (streamExact n) + in v1 == v2 + , testProperty "unstream == vunstream (unknown)" $ \(n :: Int) -> + let v1,v2 :: v Int + v1 = runST $ V.freeze =<< MV.unstream (streamUnknown n) + v2 = runST $ V.freeze =<< MV.vunstream (streamUnknown n) + in v1 == v2 + -- + , testProperty "unstreamR ~= vunstream (exact)" $ \(n :: Int) -> + let v1,v2 :: v Int + v1 = runST $ V.freeze =<< MV.unstreamR (streamExact n) + v2 = runST $ V.freeze =<< MV.vunstream (streamExact n) + in V.reverse v1 == v2 + , testProperty "unstreamR ~= vunstream (unknown)" $ \(n :: Int) -> + let v1,v2 :: v Int + v1 = runST $ V.freeze =<< MV.unstreamR (streamUnknown n) + v2 = runST $ V.freeze =<< MV.vunstream (streamUnknown n) + in V.reverse v1 == v2 + ] + where + streamExact n = S.generate (abs n) id + streamUnknown = S.unfoldr (\i -> if i > 0 then (Just (i-1,i-1)) else Nothing) . abs diff --git a/tests/Tests/Vector/UnitTests.hs b/tests/Tests/Vector/UnitTests.hs --- a/tests/Tests/Vector/UnitTests.hs +++ b/tests/Tests/Vector/UnitTests.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} + {-# LANGUAGE ScopedTypeVariables #-} module Tests.Vector.UnitTests (tests) where @@ -13,6 +13,7 @@ import qualified Data.List as List import qualified Data.Vector.Generic as Generic import qualified Data.Strict.Vector as Boxed +import qualified Data.Strict.Vector.Autogen.Internal.Check as Check import qualified Data.Strict.Vector.Autogen.Mutable as MBoxed import qualified Data.Vector.Primitive as Primitive import qualified Data.Vector.Storable as Storable @@ -44,6 +45,12 @@ dummy :: a dummy = undefined +withBoundsChecksOnly :: [TestTree] -> [TestTree] +withBoundsChecksOnly ts = + if Check.doChecks Check.Bounds + then ts + else [] + tests :: [TestTree] tests = [ testGroup "Data.Vector.Storable.Vector Alignment" @@ -67,14 +74,15 @@ , regression188 ([] :: [Char]) ] ] - , testGroup "Negative tests" - [ testGroup "slice out of bounds #257" + , testGroup "Negative tests" $ + withBoundsChecksOnly [ testGroup "slice out of bounds #257" [ testGroup "Boxed" $ testsSliceOutOfBounds Boxed.slice , testGroup "Primitive" $ testsSliceOutOfBounds Primitive.slice , testGroup "Storable" $ testsSliceOutOfBounds Storable.slice , testGroup "Unboxed" $ testsSliceOutOfBounds Unboxed.slice - ] - , testGroup "take #282" + ]] + ++ + [ testGroup "take #282" [ testCase "Boxed" $ testTakeOutOfMemory Boxed.take , testCase "Primitive" $ testTakeOutOfMemory Primitive.take , testCase "Storable" $ testTakeOutOfMemory Storable.take @@ -84,6 +92,8 @@ , testGroup "Data.Vector" [ testCase "MonadFix" checkMonadFix , testCase "toFromArray" toFromArray + , testCase "toFromArraySlice" toFromArraySlice + , testCase "toFromArraySliceUnsafe" toFromArraySliceUnsafe , testCase "toFromMutableArray" toFromMutableArray ] ] @@ -130,7 +140,7 @@ in assertBool assertMsg (errSuffix `List.isSuffixOf` err) where errSuffix = - "(slice): invalid slice (" ++ + "invalid slice (" ++ show i ++ "," ++ show m ++ "," ++ show (List.length xs) ++ ")" {-# INLINE sliceTest #-} @@ -156,13 +166,11 @@ alignedIntVec :: Storable.Vector (Aligned Int) alignedIntVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5] -#if __GLASGOW_HASKELL__ >= 800 -- Ensure that Mutable is really an injective type family by typechecking a -- function which relies on injectivity. _f :: (Generic.Vector v a, Generic.Vector w a, PrimMonad f) => Generic.Mutable v (PrimState f) a -> f (w a) _f v = Generic.convert `fmap` Generic.unsafeFreeze v -#endif checkMonadFix :: Assertion checkMonadFix = assertBool "checkMonadFix" $ @@ -196,6 +204,22 @@ toFromArray = mkArrayRoundtrip $ \name v -> assertEqual name v $ Boxed.fromArray (Boxed.toArray v) + +toFromArraySlice :: Assertion +toFromArraySlice = + mkArrayRoundtrip $ \name v -> + case Boxed.toArraySlice v of + (arr, off, n) -> + assertEqual name v $ + Boxed.take n (Boxed.drop off (Boxed.fromArray arr)) + +toFromArraySliceUnsafe :: Assertion +toFromArraySliceUnsafe = + mkArrayRoundtrip $ \name v -> + case Boxed.toArraySlice v of + (arr, off, n) -> + assertEqual name v $ + Boxed.unsafeFromArraySlice arr off n toFromMutableArray :: Assertion toFromMutableArray = mkArrayRoundtrip assetRoundtrip diff --git a/tests/Utilities.hs b/tests/Utilities.hs --- a/tests/Utilities.hs +++ b/tests/Utilities.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE FlexibleInstances, GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} module Utilities where import Test.QuickCheck @@ -16,7 +17,6 @@ import Data.Function (on) import Data.Functor.Identity import Data.List ( sortBy ) -import Data.Monoid import Data.Maybe (catMaybes) instance Show a => Show (S.Bundle v a) where @@ -350,7 +350,7 @@ maxIndex :: Ord a => [a] -> Int maxIndex = fst . foldr1 imax . zip [0..] where - imax (i,x) (j,y) | x > y = (i,x) + imax (i,x) (j,y) | x >= y = (i,x) | otherwise = (j,y) iterateNM :: Monad m => Int -> (a -> m a) -> a -> m [a] diff --git a/tests/Utils/NoThunks.hs b/tests/Utils/NoThunks.hs new file mode 100644 --- /dev/null +++ b/tests/Utils/NoThunks.hs @@ -0,0 +1,15 @@ +module Utils.NoThunks (whnfHasNoThunks) where + +import Data.Maybe (isNothing) + +import NoThunks.Class (NoThunks, noThunks) +import Test.QuickCheck (Property, ioProperty) + +-- | Check that after evaluating the argument to weak head normal form there +-- are no thunks. +-- +whnfHasNoThunks :: NoThunks a => a -> Property +whnfHasNoThunks a = ioProperty + . fmap isNothing + . noThunks [] + $! a diff --git a/tests/intmap-properties.hs b/tests/intmap-properties.hs --- a/tests/intmap-properties.hs +++ b/tests/intmap-properties.hs @@ -27,18 +27,16 @@ import Data.List (nub,sort) import qualified Data.List as List import qualified Data.IntSet as IntSet -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 -import Test.HUnit hiding (Test, Testable) -import Test.QuickCheck -import Test.QuickCheck.Function (Fun(..), apply) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Test.QuickCheck.Function (apply) import Test.QuickCheck.Poly (A, B, C) default (Int) main :: IO () -main = defaultMain +main = defaultMain $ testGroup "intmap-properties" [ testCase "index" test_index , testCase "index_lookup" test_index_lookup @@ -133,10 +131,8 @@ , testCase "maxView" test_maxView , testCase "minViewWithKey" test_minViewWithKey , testCase "maxViewWithKey" test_maxViewWithKey -#if MIN_VERSION_base(4,8,0) , testCase "minimum" test_minimum , testCase "maximum" test_maximum -#endif , testProperty "valid" prop_valid , testProperty "empty valid" prop_emptyValid , testProperty "insert to singleton" prop_singleton @@ -238,16 +234,6 @@ type SMap = IntMap String ---------------------------------------------------------------- - -tests :: [Test] -tests = [ testGroup "Test Case" [ - ] - , testGroup "Property Test" [ - ] - ] - - ----------------------------------------------------------------- -- Unit tests ---------------------------------------------------------------- @@ -307,12 +293,17 @@ test_lookup :: Assertion test_lookup = do - employeeCurrency 1 @?= Just 1 - employeeCurrency 2 @?= Nothing + employeeCurrency 1 @?= Just 1 + employeeCurrency 2 @?= Just 2 + employeeCurrency 3 @?= Just 3 + employeeCurrency 4 @?= Just 4 + employeeCurrency 5 @?= Nothing + employeeCurrency (2^10) @?= Just 42 + employeeCurrency 6 @?= Nothing where - employeeDept = fromList([(1,2), (3,1)]) - deptCountry = fromList([(1,1), (2,2)]) - countryCurrency = fromList([(1, 2), (2, 1)]) + employeeDept = fromList [(1,2), (2, 14), (3, 10), (4, 18), (2^10, 100)] + deptCountry = fromList [(1,1), (14, 14), (10, 10), (18, 18), (100, 100), (2,2)] + countryCurrency = fromList [(1, 2), (2, 1), (14, 2), (10, 3), (18, 4), (100, 42)] employeeCurrency :: Int -> Maybe Int employeeCurrency name = do dept <- lookup name employeeDept @@ -1117,8 +1108,6 @@ maxViewWithKey (fromList [(5,"a"), (-3,"b")]) @?= Just ((5,"a"), singleton (-3) "b") maxViewWithKey (empty :: SMap) @?= Nothing - -#if MIN_VERSION_base(4,8,0) test_minimum :: Assertion test_minimum = do getOW (minimum testOrdMap) @?= "min" @@ -1139,8 +1128,6 @@ instance Ord a => Ord (OrdWith a) where OrdWith _ a1 <= OrdWith _ a2 = a1 <= a2 -#endif - ---------------------------------------------------------------- -- Valid IntMaps diff --git a/tests/intmap-strictness.hs b/tests/intmap-strictness.hs --- a/tests/intmap-strictness.hs +++ b/tests/intmap-strictness.hs @@ -5,12 +5,13 @@ module Main (main) where import Test.ChasingBottoms.IsBottom -import Test.Framework (Test, TestName, defaultMain, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Arbitrary(arbitrary)) -import Test.QuickCheck.Function (Fun(..), apply) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) +import Test.Tasty (TestTree, TestName, defaultMain, testGroup) +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck (testProperty, Arbitrary(arbitrary), Fun) +#if __GLASGOW_HASKELL__ >= 806 +import Test.Tasty.QuickCheck (Property) +#endif +import Test.QuickCheck.Function (apply) import Data.Strict.IntMap.Autogen.Strict (IntMap) import qualified Data.Strict.IntMap.Autogen.Strict as M @@ -18,6 +19,9 @@ import qualified Data.IntSet as IntSet import Utils.IsUnit +#if __GLASGOW_HASKELL__ >= 806 +import Utils.NoThunks +#endif instance Arbitrary v => Arbitrary (IntMap v) where arbitrary = M.fromList `fmap` arbitrary @@ -103,6 +107,16 @@ where elems = [(k, v) | k <- nubInt ks, v <- [undefined, undefined, ()]] +#if __GLASGOW_HASKELL__ >= 806 +pStrictFoldr' :: IntMap Int -> Property +pStrictFoldr' m = whnfHasNoThunks (M.foldr' (:) [] m) +#endif + +#if __GLASGOW_HASKELL__ >= 806 +pStrictFoldl' :: IntMap Int -> Property +pStrictFoldl' m = whnfHasNoThunks (M.foldl' (flip (:)) [] m) +#endif + -- copy over definitions from Data.Containers.Utils so we can support older GHC -- that have older versions of containers without this module nubInt :: [Int] -> [Int] @@ -130,7 +144,7 @@ -- in most cases. An exception is `L.fromListWith const`, which cannot -- evaluate the `const` calls. -tExtraThunksM :: Test +tExtraThunksM :: TestTree tExtraThunksM = testGroup "IntMap.Strict - extra thunks" $ if not isUnitSupported then [] else -- for strict maps, all the values should be evaluated to () @@ -145,15 +159,15 @@ ] where m0 = M.singleton 42 () - check :: TestName -> IntMap () -> Test + check :: TestName -> IntMap () -> TestTree check n m = testCase n $ case M.lookup 42 m of Just v -> assertBool msg (isUnit v) - _ -> assertString "key not found" + _ -> assertBool "key not found" False where msg = "too lazy -- expected fully evaluated ()" -tExtraThunksL :: Test -tExtraThunksL = testGroup "IntMap.Strict - extra thunks" $ +tExtraThunksL :: TestTree +tExtraThunksL = testGroup "IntMap.Lazy - extra thunks" $ if not isUnitSupported then [] else -- for lazy maps, the *With functions should leave `const () ()` thunks, -- but the other functions should produce fully evaluated (). @@ -171,10 +185,10 @@ ] where m0 = L.singleton 42 () - check :: TestName -> Bool -> L.IntMap () -> Test + check :: TestName -> Bool -> L.IntMap () -> TestTree check n e m = testCase n $ case L.lookup 42 m of Just v -> assertBool msg (e == isUnit v) - _ -> assertString "key not found" + _ -> assertBool "key not found" False where msg | e = "too lazy -- expected fully evaluated ()" | otherwise = "too strict -- expected a thunk" @@ -182,7 +196,7 @@ ------------------------------------------------------------------------ -- * Test list -tests :: [Test] +tests :: [TestTree] tests = [ -- Basic interface @@ -208,6 +222,10 @@ pInsertLookupWithKeyValueStrict , testProperty "fromAscList is somewhat value-lazy" pFromAscListLazy , testProperty "fromAscList is somewhat value-strict" pFromAscListStrict +#if __GLASGOW_HASKELL__ >= 806 + , testProperty "strict foldr'" pStrictFoldr' + , testProperty "strict foldl'" pStrictFoldl' +#endif ] , tExtraThunksM , tExtraThunksL @@ -217,7 +235,7 @@ -- * Test harness main :: IO () -main = defaultMain tests +main = defaultMain $ testGroup "intmap-strictness" tests ------------------------------------------------------------------------ -- * Utilities diff --git a/tests/map-properties.hs b/tests/map-properties.hs --- a/tests/map-properties.hs +++ b/tests/map-properties.hs @@ -19,6 +19,7 @@ import Data.Maybe hiding (mapMaybe) import qualified Data.Maybe as Maybe (mapMaybe) import Data.Ord +import Data.Semigroup (Arg(..)) import Data.Function import qualified Data.Foldable as Foldable #if MIN_VERSION_base(4,10,0) @@ -30,12 +31,10 @@ import Data.List (nub,sort) import qualified Data.List as List import qualified Data.Set as Set -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 -import Test.HUnit hiding (Test, Testable) -import Test.QuickCheck -import Test.QuickCheck.Function (Fun (..), apply) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Test.QuickCheck.Function (apply) import Test.QuickCheck.Poly (A, B) import Control.Arrow (first) @@ -48,7 +47,7 @@ apply2 f a b = apply f (a, b) main :: IO () -main = defaultMain +main = defaultMain $ testGroup "map-properties" [ testCase "ticket4242" test_ticket4242 , testCase "index" test_index , testCase "size" test_size @@ -101,7 +100,9 @@ , testCase "keys" test_keys , testCase "assocs" test_assocs , testCase "keysSet" test_keysSet + , testCase "argSet" test_argSet , testCase "fromSet" test_fromSet + , testCase "fromArgSet" test_fromArgSet , testCase "toList" test_toList , testCase "fromList" test_fromList , testCase "fromListWith" test_fromListWith @@ -240,7 +241,9 @@ , testProperty "bifoldl'" prop_bifoldl' #endif , testProperty "keysSet" prop_keysSet + , testProperty "argSet" prop_argSet , testProperty "fromSet" prop_fromSet + , testProperty "fromArgSet" prop_fromArgSet , testProperty "takeWhileAntitone" prop_takeWhileAntitone , testProperty "dropWhileAntitone" prop_dropWhileAntitone , testProperty "spanAntitone" prop_spanAntitone @@ -713,11 +716,21 @@ keysSet (fromList [(5,"a"), (3,"b")]) @?= Set.fromList [3,5] keysSet (empty :: UMap) @?= Set.empty +test_argSet :: Assertion +test_argSet = do + argSet (fromList [(5,"a"), (3,"b")]) @?= Set.fromList [Arg 3 "b",Arg 5 "a"] + argSet (empty :: UMap) @?= Set.empty + test_fromSet :: Assertion test_fromSet = do fromSet (\k -> replicate k 'a') (Set.fromList [3, 5]) @?= fromList [(5,"aaaaa"), (3,"aaa")] fromSet undefined Set.empty @?= (empty :: IMap) +test_fromArgSet :: Assertion +test_fromArgSet = do + fromArgSet (Set.fromList [Arg 3 "aaa", Arg 5 "aaaaa"]) @?= fromList [(5,"aaaaa"), (3,"aaa")] + fromArgSet Set.empty @?= (empty :: IMap) + ---------------------------------------------------------------- -- Lists @@ -1558,7 +1571,16 @@ prop_keysSet xs = keysSet (fromList xs) == Set.fromList (List.map fst xs) +prop_argSet :: [(Int, Int)] -> Bool +prop_argSet xs = + argSet (fromList xs) == Set.fromList (List.map (uncurry Arg) xs) + prop_fromSet :: [(Int, Int)] -> Bool prop_fromSet ys = let xs = List.nubBy ((==) `on` fst) ys in fromSet (\k -> fromJust $ List.lookup k xs) (Set.fromList $ List.map fst xs) == fromList xs + +prop_fromArgSet :: [(Int, Int)] -> Bool +prop_fromArgSet ys = + let xs = List.nubBy ((==) `on` fst) ys + in fromArgSet (Set.fromList $ List.map (uncurry Arg) xs) == fromList xs diff --git a/tests/map-strictness.hs b/tests/map-strictness.hs --- a/tests/map-strictness.hs +++ b/tests/map-strictness.hs @@ -1,20 +1,26 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where import Test.ChasingBottoms.IsBottom -import Test.Framework (Test, TestName, defaultMain, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Arbitrary(arbitrary)) -import Test.QuickCheck.Function (Fun(..), apply) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) +import Test.Tasty (TestTree, TestName, defaultMain, testGroup) +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck (testProperty, Arbitrary(arbitrary), Fun) +#if __GLASGOW_HASKELL__ >= 806 +import Test.Tasty.QuickCheck (Property) +#endif +import Test.QuickCheck.Function (apply) import Data.Strict.Map.Autogen.Strict (Map) import qualified Data.Strict.Map.Autogen.Strict as M import qualified Data.Map.Lazy as L import Utils.IsUnit +#if __GLASGOW_HASKELL__ >= 806 +import Utils.NoThunks +#endif instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (Map k v) where @@ -82,6 +88,26 @@ not (isBottom $ M.insertLookupWithKey (const3 1) k bottom m) | otherwise = isBottom $ M.insertLookupWithKey (apply3 f) k bottom m +#if __GLASGOW_HASKELL__ >= 806 +pStrictFoldr' :: Map Int Int -> Property +pStrictFoldr' m = whnfHasNoThunks (M.foldr' (:) [] m) +#endif + +#if __GLASGOW_HASKELL__ >= 806 +pStrictFoldl' :: Map Int Int -> Property +pStrictFoldl' m = whnfHasNoThunks (M.foldl' (flip (:)) [] m) +#endif + +#if __GLASGOW_HASKELL__ >= 806 +pStrictFoldrWithKey' :: Map Int Int -> Property +pStrictFoldrWithKey' m = whnfHasNoThunks (M.foldrWithKey' (\_ a as -> a : as) [] m) +#endif + +#if __GLASGOW_HASKELL__ >= 806 +pStrictFoldlWithKey' :: Map Int Int -> Property +pStrictFoldlWithKey' m = whnfHasNoThunks (M.foldlWithKey' (\as _ a -> a : as) [] m) +#endif + ------------------------------------------------------------------------ -- check for extra thunks -- @@ -90,7 +116,7 @@ -- in most cases. An exception is `L.fromListWith const`, which cannot -- evaluate the `const` calls. -tExtraThunksM :: Test +tExtraThunksM :: TestTree tExtraThunksM = testGroup "Map.Strict - extra thunks" $ if not isUnitSupported then [] else -- for strict maps, all the values should be evaluated to () @@ -105,14 +131,14 @@ ] where m0 = M.singleton 42 () - check :: TestName -> M.Map Int () -> Test + check :: TestName -> M.Map Int () -> TestTree check n m = testCase n $ case M.lookup 42 m of Just v -> assertBool msg (isUnit v) - _ -> assertString "key not found" + _ -> assertBool "key not found" False where msg = "too lazy -- expected fully evaluated ()" -tExtraThunksL :: Test +tExtraThunksL :: TestTree tExtraThunksL = testGroup "Map.Lazy - extra thunks" $ if not isUnitSupported then [] else -- for lazy maps, the *With functions should leave `const () ()` thunks, @@ -128,10 +154,10 @@ ] where m0 = L.singleton 42 () - check :: TestName -> Bool -> L.Map Int () -> Test + check :: TestName -> Bool -> L.Map Int () -> TestTree check n e m = testCase n $ case L.lookup 42 m of Just v -> assertBool msg (e == isUnit v) - _ -> assertString "key not found" + _ -> assertBool "key not found" False where msg | e = "too lazy -- expected fully evaluated ()" | otherwise = "too strict -- expected a thunk" @@ -139,7 +165,7 @@ ------------------------------------------------------------------------ -- * Test list -tests :: [Test] +tests :: [TestTree] tests = [ -- Basic interface @@ -162,6 +188,12 @@ pInsertLookupWithKeyKeyStrict , testProperty "insertLookupWithKey is value-strict" pInsertLookupWithKeyValueStrict +#if __GLASGOW_HASKELL__ >= 806 + , testProperty "strict foldr'" pStrictFoldr' + , testProperty "strict foldl'" pStrictFoldl' + , testProperty "strict foldrWithKey'" pStrictFoldrWithKey' + , testProperty "strict foldlWithKey'" pStrictFoldlWithKey' +#endif ] , tExtraThunksM , tExtraThunksL @@ -171,7 +203,7 @@ -- * Test harness main :: IO () -main = defaultMain tests +main = defaultMain $ testGroup "map-strictness" tests ------------------------------------------------------------------------ -- * Utilities @@ -184,3 +216,4 @@ const3 :: a -> b -> c -> d -> a const3 x _ _ _ = x + diff --git a/tests/seq-properties.hs b/tests/seq-properties.hs --- a/tests/seq-properties.hs +++ b/tests/seq-properties.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TemplateHaskell #-} #include "containers.h" @@ -25,9 +26,7 @@ import Data.Maybe import Data.Function (on) import Data.Monoid (Monoid(..), All(..), Endo(..), Dual(..)) -#if MIN_VERSION_base(4,9,0) import Data.Semigroup (stimes, stimesMonoid) -#endif import Data.Traversable (Traversable(traverse), sequenceA) import Prelude hiding ( lookup, null, length, take, drop, splitAt, @@ -36,22 +35,24 @@ all, sum) import qualified Prelude import qualified Data.List -import Test.QuickCheck hiding ((><)) -import Test.QuickCheck.Poly -#if __GLASGOW_HASKELL__ >= 800 -import Test.QuickCheck.Property -#endif -import Test.QuickCheck.Function -import Test.Framework -import Test.Framework.Providers.QuickCheck2 +import Test.Tasty +import Test.Tasty.QuickCheck hiding ((><)) +import Test.QuickCheck.Function (apply) +import Test.QuickCheck.Poly (A, OrdA, B(..), OrdB, C) import Control.Monad.Zip (MonadZip (..)) import Control.DeepSeq (deepseq) import Control.Monad.Fix (MonadFix (..)) +import Test.Tasty.HUnit +import qualified Language.Haskell.TH.Syntax as TH main :: IO () -main = defaultMain - [ testProperty "fmap" prop_fmap +main = defaultMain $ testGroup "seq-properties" + [ test_lift +#if MIN_VERSION_template_haskell(2,16,0) + , test_liftTyped +#endif + , testProperty "fmap" prop_fmap , testProperty "(<$)" prop_constmap , testProperty "foldr" prop_foldr , testProperty "foldr'" prop_foldr' @@ -148,17 +149,13 @@ , testProperty "intersperse" prop_intersperse , testProperty ">>=" prop_bind , testProperty "mfix" test_mfix -#if __GLASGOW_HASKELL__ >= 800 , testProperty "Empty pattern" prop_empty_pat , testProperty "Empty constructor" prop_empty_con , testProperty "Left view pattern" prop_viewl_pat , testProperty "Left view constructor" prop_viewl_con , testProperty "Right view pattern" prop_viewr_pat , testProperty "Right view constructor" prop_viewr_con -#endif -#if MIN_VERSION_base(4,9,0) , testProperty "stimes" prop_stimes -#endif ] ------------------------------------------------------------------------ @@ -598,21 +595,13 @@ prop_sortOn (Fun _ f) xs = toList' (sortOn f xs) ~= listSortOn f (toList xs) where -#if MIN_VERSION_base(4,8,0) listSortOn = Data.List.sortOn -#else - listSortOn k = Data.List.sortBy (compare `on` k) -#endif prop_sortOnStable :: Fun A UnstableOrd -> Seq A -> Bool prop_sortOnStable (Fun _ f) xs = toList' (sortOn f xs) ~= listSortOn f (toList xs) where -#if MIN_VERSION_base(4,8,0) listSortOn = Data.List.sortOn -#else - listSortOn k = Data.List.sortBy (compare `on` k) -#endif prop_unstableSort :: Seq OrdA -> Bool prop_unstableSort xs = @@ -858,7 +847,6 @@ prop_cycleTaking n xs = (n <= 0 || not (null xs)) ==> toList' (cycleTaking n xs) ~= Data.List.take n (Data.List.cycle (toList xs)) -#if __GLASGOW_HASKELL__ >= 800 prop_empty_pat :: Seq A -> Bool prop_empty_pat xs@Empty = null xs prop_empty_pat xs = not (null xs) @@ -869,8 +857,8 @@ prop_viewl_pat :: Seq A -> Property prop_viewl_pat xs@(y :<| ys) | z :< zs <- viewl xs = y === z .&&. ys === zs - | otherwise = property failed -prop_viewl_pat xs = property . liftBool $ null xs + | otherwise = property False +prop_viewl_pat xs = property $ null xs prop_viewl_con :: A -> Seq A -> Property prop_viewl_con x xs = x :<| xs === x <| xs @@ -878,12 +866,11 @@ prop_viewr_pat :: Seq A -> Property prop_viewr_pat xs@(ys :|> y) | zs :> z <- viewr xs = y === z .&&. ys === zs - | otherwise = property failed -prop_viewr_pat xs = property . liftBool $ null xs + | otherwise = property False +prop_viewr_pat xs = property $ null xs prop_viewr_con :: Seq A -> A -> Property prop_viewr_con xs x = xs :|> x === xs |> x -#endif -- Monad operations @@ -893,11 +880,9 @@ -- Semigroup operations -#if MIN_VERSION_base(4,9,0) prop_stimes :: NonNegative Int -> Seq A -> Property prop_stimes (NonNegative n) s = stimes n s === stimesMonoid n s -#endif -- MonadFix operation @@ -930,7 +915,6 @@ Action m f <*> Action n x = Action (m+n) (f x) instance Monad M where - return x = Action 0 x Action m x >>= f = let Action n y = f x in Action (m+n) y instance Foldable M where @@ -938,3 +922,21 @@ instance Traversable M where traverse f (Action n x) = Action n <$> f x + +-- ---------- +-- +-- Unit tests +-- +-- ---------- + +test_lift :: TestTree +test_lift = testCase "lift" $ do + (mempty :: Seq Int) @=? $([| $(TH.lift (fromList [] :: Seq Integer)) |]) + fromList [1..3 :: Int] @=? $([| $(TH.lift (fromList [1..3 :: Integer])) |]) + +#if MIN_VERSION_template_haskell(2,16,0) +test_liftTyped :: TestTree +test_liftTyped = testCase "liftTyped" $ do + (mempty :: Seq Int) @=? $$([|| $$(TH.liftTyped (fromList [])) ||]) + fromList [1..3 :: Int] @=? $$([|| $$(TH.liftTyped (fromList [1..3])) ||]) +#endif