enummapmap 0.5.0 → 0.6.0
raw patch · 10 files changed
+679/−95 lines, 10 filesdep +cerealdep +safecopy
Dependencies added: cereal, safecopy
Files
- Data/EnumMapMap/Base.hs +139/−18
- Data/EnumMapMap/Lazy.hs +61/−15
- Data/EnumMapMap/Strict.hs +65/−17
- Data/EnumMapSet.hs +3/−0
- Data/EnumMapSet/Base.hs +53/−14
- enummapmap.cabal +46/−1
- test/EnumMapMapVsIntMap.hs +79/−13
- test/UnitBoth.hs +83/−0
- test/UnitEnumMapMap.hs +75/−15
- test/UnitEnumMapSet.hs +75/−2
Data/EnumMapMap/Base.hs view
@@ -1,6 +1,17 @@-{-# LANGUAGE MagicHash, TypeFamilies, MultiParamTypeClasses,- BangPatterns, FlexibleInstances, TypeOperators,- FlexibleContexts, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE+ BangPatterns,+ DeriveDataTypeable,+ FlexibleContexts,+ FlexibleInstances,+ GeneralizedNewtypeDeriving,+ MagicHash,+ MultiParamTypeClasses,+ OverlappingInstances,+ StandaloneDeriving,+ TypeFamilies,+ TypeOperators,+ UndecidableInstances+ #-} ----------------------------------------------------------------------------- -- |@@ -28,6 +39,7 @@ Plus, SubKey(..), -- * Internal+ MkNestedPair(..), -- ** IsEMM EMM(..), IsKey(..),@@ -38,6 +50,8 @@ -- ** EMM internals mergeWithKey', mapWithKey_,+ mapMaybeWithKey_,+ traverseWithKey_, foldrWithKey_, foldlStrict, -- ** IntMap internals@@ -67,12 +81,16 @@ null, init, head, tail) +import Control.Applicative (Applicative(pure,(<*>)),(<$>)) import Control.DeepSeq (NFData(rnf)) import Data.Bits import Data.Default import qualified Data.Foldable as FOLD import Data.Maybe (fromMaybe)+import Data.SafeCopy import Data.Semigroup+import Data.Traversable (Traversable(traverse))+import Data.Typeable import GHC.Exts (Word(..), Int(..), uncheckedShiftRL#, uncheckedShiftL#) @@ -157,6 +175,21 @@ type family Plus k1 k2 :: * type instance Plus (k1 :& t) k2 = k1 :& Plus t k2 +-- | This is used by the SafeCopy instance. It strips the constructors and Enum+-- from the key so that+-- > NestedPair (T1 :& T2 :& K T3) v ~ (Int, (Int, (Int, v)))+class MkNestedPair k v where+ type NestedPair k v :: *+ nestedPair :: k -> v -> NestedPair k v+ unNestedPair :: NestedPair k v -> (k ,v)++instance (MkNestedPair t v, Enum k) => MkNestedPair (k :& t) v where+ type NestedPair (k :& t) v = (Int, NestedPair t v)+ nestedPair (k :& t) v = (fromEnum k, nestedPair t v)+ unNestedPair (k, x) = (toEnum k :& t, v)+ where+ (t, v) = unNestedPair x+ class SubKey k1 k2 v where -- | k1 should be a prefix of k2. If @k1 ~ k2@ then the 'Result' will be -- @v@.@@ -199,7 +232,7 @@ insertWith :: (IsKey k1, IsKey k2) => (Result k1 k2 v -> Result k1 k2 v -> Result k1 k2 v) -> k1 -> Result k1 k2 v -> EnumMapMap k2 v -> EnumMapMap k2 v- insertWith f = insertWithKey (\_ -> f)+ insertWith f = insertWithKey (const f) -- | Insert with a combining function. Can also insert submaps. insertWithKey :: (IsKey k1, IsKey k2) =>@@ -238,7 +271,7 @@ toK :: Skey k -> k instance (HasSKey t) => HasSKey (k :& t) where- type Skey (k :& t) = k :& (Skey t)+ type Skey (k :& t) = k :& Skey t toS (k :& t) = (:&) k $! toS t toK (k :& t) = (:&) k $! toK t @@ -301,22 +334,48 @@ alter :: (Maybe v -> Maybe v) -> k -> EnumMapMap k v -> EnumMapMap k v -- | Map a function over all values in the 'EnumMapMap'. map :: (v -> t) -> EnumMapMap k v -> EnumMapMap k t- map f = mapWithKey (\_ -> f)+ map f = mapWithKey (const f)+ -- | Map values and collect the 'Just' results.+ mapMaybe :: (v -> Maybe t) -> EnumMapMap k v -> EnumMapMap k t+ mapMaybe f = mapMaybeWithKey (\_ x -> f x)+ -- | Map keys\/values and collect the 'Just' results.+ mapMaybeWithKey :: (k -> v -> Maybe t) -> EnumMapMap k v -> EnumMapMap k t -- | Map a function over all key\/value pairs in the 'EnumMapMap'. mapWithKey :: (k -> v -> t) -> EnumMapMap k v -> EnumMapMap k t- -- | Fold the values in the 'EnumMapMap' using the given right-associative- -- binary operator+ -- | @TraverseWithKey@ behaves exactly like a regular 'traverse' except that+ -- the traversing function also has access to the key associated with a+ -- value.+ traverseWithKey :: (Applicative t) =>+ (k -> a -> t b) -> EnumMapMap k a -> t (EnumMapMap k b)+ -- | Fold the values in the 'EnumMapMap' using the given+ -- right-associative binary operator foldr :: (v -> t -> t) -> t -> EnumMapMap k v -> t -- | Fold the keys and values in the 'EnumMapMap' using the given right-associative -- binary operator. foldrWithKey :: (k -> v -> t -> t) -> t -> EnumMapMap k v -> t- -- | Convert the 'EnumMapMap' to a list of key\/value pairs.+ -- | Convert the 'EnumMapMap' to a list of key\/value pairs. toList :: SubKey k k v => EnumMapMap k v -> [(k, v)] toList = foldrWithKey (\k x xs -> (k, x):xs) []- -- | Create a 'EnumMapMap' from a list of key\/value pairs.+ -- | Convert the 'EnumMapMap' to a list of nested tuples+ toNestedPairList :: (SubKey k k v, MkNestedPair k v) =>+ EnumMapMap k v -> [NestedPair k v]+ toNestedPairList = foldrWithKey (\k x xs -> (nestedPair k x):xs) []+ -- | Create an 'EnumMapMap' from a list of key\/value pairs. fromList :: (SubKey k k v, Result k k v ~ v) => [(k, v)] -> EnumMapMap k v fromList = foldlStrict (\t (k, x) -> insert k x t) empty+ -- | Create an 'EnumMapMap' from a list of nested tuples+ fromNestedPairList :: (SubKey k k v, Result k k v ~ v, MkNestedPair k v) =>+ [NestedPair k v] -> EnumMapMap k v+ fromNestedPairList = foldlStrict f empty+ where+ f :: (IsKey k, SubKey k k v, Result k k v ~ v, MkNestedPair k v) =>+ EnumMapMap k v -> NestedPair k v -> EnumMapMap k v+ f emm = g emm . unNestedPair+ g :: (IsKey k, SubKey k k v, Result k k v ~ v) =>+ EnumMapMap k v -> (k, v) -> EnumMapMap k v+ g emm (k, v) = insert k v emm+ -- | List of elements in ascending order of keys elems :: EnumMapMap k v -> [v] elems = foldr (:) []@@ -353,7 +412,7 @@ -- | The union with a combining function. unionWith :: (v -> v -> v) -> EnumMapMap k v -> EnumMapMap k v -> EnumMapMap k v- unionWith f = unionWithKey (\_ -> f)+ unionWith f = unionWithKey (const f) -- | The union with a combining function. unionWithKey :: (k -> v -> v -> v) -> EnumMapMap k v -> EnumMapMap k v -> EnumMapMap k v@@ -364,7 +423,7 @@ -> EnumMapMap k v1 -> EnumMapMap k v2 -> EnumMapMap k v1- differenceWith f = differenceWithKey (\_ -> f)+ differenceWith f = differenceWithKey (const f) -- | Difference with a combining function. differenceWithKey :: (k -> v1 -> v2 -> Maybe v1) -> EnumMapMap k v1@@ -379,7 +438,7 @@ -> EnumMapMap k v1 -> EnumMapMap k v2 -> EnumMapMap k v3- intersectionWith f = intersectionWithKey (\_ -> f)+ intersectionWith f = intersectionWithKey (const f) -- | The intersection with a combining function. intersectionWithKey :: (k -> v1 -> v2 -> v3) -> EnumMapMap k v1@@ -464,7 +523,7 @@ Tip k v -> tip k (removeEmpties v) Nil -> Nil - unsafeJoinKey (KCC emm) = KCC $ mapWithKey_ (\_ -> unsafeJoinKey) emm+ unsafeJoinKey (KCC emm) = KCC $ mapWithKey_ (const unsafeJoinKey) emm empty = KCC Nil @@ -486,13 +545,21 @@ where go k = mapWithKey (\nxt -> f $! k :& nxt) + mapMaybeWithKey f (KCC emm) = KCC $ mapMaybeWithKey_ go emm+ where+ go k = mapMaybeWithKey (\nxt -> f $! k :& nxt)++ traverseWithKey f (KCC emm) = KCC <$> traverseWithKey_ go emm+ where+ go k = traverseWithKey (\nxt -> f $! k :& nxt)+ foldr f init (KCC emm) = foldrWithKey_ (\_ val z -> foldr f z val) init emm foldrWithKey f init (KCC emm) = foldrWithKey_ go init emm where go k val z = foldrWithKey (\nxt -> f $! k :& nxt) z val - keysSet (KCC emm) = KCC $ mapWithKey_ (\_ -> keysSet) emm+ keysSet (KCC emm) = KCC $ mapWithKey_ (const keysSet) emm fromSet f (KCC ems) = KCC $ mapWithKey_ go ems where@@ -512,7 +579,7 @@ go Nil = error "findMin: Nil" minViewWithKey (KCC emm) =- goat emm >>= \(r, emm') -> return (r, KCC $ emm')+ goat emm >>= \(r, emm') -> return (r, KCC emm') where goat t = case t of@@ -526,7 +593,7 @@ (result, l') -> (result, binD p m l' r) go (Tip k y) = case minViewWithKey y of Just ((t, v), y') ->- (((toEnum k) :& t, v), tip k y')+ ((toEnum k :& t, v), tip k y') Nothing -> error "minViewWithKey: Nothing" go Nil = error "minViewWithKey Nil" @@ -615,6 +682,25 @@ go Nil = Nil {-# INLINE mapWithKey_ #-} +mapMaybeWithKey_ :: (IsKey b, Enum key) =>+ (key -> EnumMapMap b v -> EnumMapMap b t) ->+ EMM a (EnumMapMap b v) ->+ EMM a (EnumMapMap b t)+mapMaybeWithKey_ f = go+ where+ go (Bin p m l r) = binD p m (go l) (go r)+ go (Tip k x) = tip k $ f (toEnum k) x+ go Nil = Nil+{-# INLINE mapMaybeWithKey_ #-}++traverseWithKey_ :: (Enum k, Applicative t) =>+ (k -> a -> t b) -> EMM k a -> t (EMM k b)+traverseWithKey_ f = go+ where+ go Nil = pure Nil+ go (Tip k v) = Tip k <$> f (toEnum k) v+ go (Bin p m l r) = Bin p m <$> go l <*> go r+ foldrWithKey_ :: (Enum k) => (k -> v -> t -> t) -> t -> EMM k v -> t foldrWithKey_ f z = \emm -> case emm of Bin _ m l r | m < 0 -> go (go z l) r@@ -739,6 +825,8 @@ where rnf (k :& t) = rnf k `seq` rnf t +-- Foldable+ instance (FOLD.Foldable (EnumMapMap t), Enum k, Eq k, IsKey t, HasSKey t) => FOLD.Foldable (EnumMapMap (k :& t)) where fold (KCC emm) = go emm@@ -753,9 +841,42 @@ go (Tip _ v) = FOLD.foldMap f v go (Bin _ _ l r) = go l `mappend` go r +instance (IsKey k, FOLD.Foldable (EnumMapMap k)) =>+ Traversable (EnumMapMap k) where+ traverse f = traverseWithKey (\_ -> f)++-- Default+ instance (IsKey k) => Default (EnumMapMap k v) where def = empty +-- Typeable++deriving instance Typeable2 (:&)+deriving instance Typeable2 EnumMapMap++-- SafeCopy++instance (Enum a, SafeCopy b) => SafeCopy (a :& b) where+ getCopy = contain $ do+ a <- safeGet+ b <- safeGet+ return (toEnum a :& b)+ putCopy (a :& b) = contain $ do+ safePut $ fromEnum a+ safePut b+ errorTypeName _ = "(:&)"++-- We only define this for (k :& t) here because the more general version+-- causes overlaps between EnumMapMap and EnumMapSet.+instance (SafeCopy k, SafeCopy (NestedPair k v), IsKey k,+ Result k k v ~ v, SubKey k k v,+ MkNestedPair k v) =>+ SafeCopy (EnumMapMap k v) where+ getCopy = contain $ fmap fromNestedPairList safeGet+ putCopy = contain . safePut . toNestedPairList+ errorTypeName _ = "EnumMapMap"+ {-------------------------------------------------------------------- Nat conversion --------------------------------------------------------------------}@@ -888,7 +1009,7 @@ x3 -> case (x3 .|. shiftRL x3 8) of x4 -> case (x4 .|. shiftRL x4 16) of x5 -> case (x5 .|. shiftRL x5 32) of -- for 64 bit platforms- x6 -> (x6 `xor` (shiftRL x6 1))+ x6 -> (x6 `xor` shiftRL x6 1) {-# INLINE highestBitMask #-} {--------------------------------------------------------------------
Data/EnumMapMap/Lazy.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE CPP, BangPatterns, FlexibleInstances, GeneralizedNewtypeDeriving,- MagicHash, MultiParamTypeClasses, TypeFamilies, TypeOperators #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}- ----------------------------------------------------------------------------- -- | -- Module : Data.EnumMapMap.Lazy@@ -29,6 +25,20 @@ -- The functions are lazy on values, but strict on keys. ----------------------------------------------------------------------------- +{-# LANGUAGE+ BangPatterns,+ CPP,+ DeriveDataTypeable,+ FlexibleInstances,+ GeneralizedNewtypeDeriving,+ MagicHash,+ MultiParamTypeClasses,+ StandaloneDeriving,+ TypeFamilies,+ TypeOperators,+ UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+ module Data.EnumMapMap.Lazy ( emptySubTrees,@@ -73,6 +83,9 @@ -- * Map map, mapWithKey,+ mapMaybe,+ mapMaybeWithKey,+ traverseWithKey, -- * Folds foldr, foldrWithKey,@@ -97,10 +110,13 @@ import Prelude hiding (lookup,map,filter,foldr,foldl,null,init) +import Control.Applicative ((<$>)) import Control.DeepSeq (NFData(rnf)) import Data.Bits import qualified Data.Foldable as FOLD+import Data.SafeCopy import Data.Semigroup+import Data.Typeable import Data.EnumMapMap.Base import qualified Data.EnumMapSet.Base as EMS@@ -113,6 +129,11 @@ newtype K k = K k deriving (Show, Eq) +instance (Enum k) => MkNestedPair (K k) v where+ type NestedPair (K k) v = (Int, v)+ nestedPair (K k) v = (fromEnum k, v)+ unNestedPair (k, v) = (K $ toEnum k, v)+ instance (Enum k, Eq k) => IsKey (K k) where newtype EnumMapMap (K k) v = KEC (EMM k v) @@ -165,7 +186,17 @@ where key = fromEnum key' - mapWithKey f (KEC emm) = KEC $ mapWithKey_ (\k -> f $ K k) emm+ mapWithKey f (KEC emm) = KEC $ mapWithKey_ (f . K) emm+ mapMaybeWithKey f (KEC emm) = KEC $ go emm+ where+ go (Bin p m l r) = bin p m (go l) (go r)+ go (Tip k x) = case f (K $! toEnum k) x of+ Just y -> Tip k y+ Nothing -> Nil+ go Nil = Nil++ traverseWithKey f (KEC emm) = KEC <$> traverseWithKey_ (\k -> f $! K k) emm+ foldr f init (KEC emm) = case emm of Bin _ m l r | m < 0 -> go (go init l) r -- put negative numbers before | otherwise -> go (go init r) l@@ -174,7 +205,7 @@ go z' Nil = z' go z' (Tip _ x) = f x z' go z' (Bin _ _ l r) = go (go z' r) l- foldrWithKey f init (KEC emm) = foldrWithKey_ (\k -> f $ K k) init emm+ foldrWithKey f init (KEC emm) = foldrWithKey_ (f . K) init emm keysSet (KEC emm) = EMS.KSC $ go emm where@@ -201,7 +232,7 @@ go (Bin _ _ l' _) = go l' go Nil = error "findMin: Nil" minViewWithKey (KEC emm) =- goat emm >>= \(r, emm') -> return (r, KEC $ emm')+ goat emm >>= \(r, emm') -> return (r, KEC emm') where goat t = case t of Nil -> Nothing@@ -278,6 +309,23 @@ toS (K !k) = EMS.S k toK (EMS.S !k) = K k +deriving instance Typeable1 K++instance (Enum k) => SafeCopy (K k) where+ getCopy = contain $ do+ k <- safeGet+ return $ K $ toEnum k+ putCopy (K k) = contain $ safePut $ fromEnum k+ errorTypeName _ = "K"++-- We put this here so that it doesn't interfere with EnumMapSet version+instance (SafeCopy (K k), SafeCopy v, IsKey (K k),+ Result (K k) (K k) v ~ v, SubKey (K k) (K k) v) =>+ SafeCopy (EnumMapMap (K k) v) where+ getCopy = contain $ fmap fromList safeGet+ putCopy = contain . safePut . toList+ errorTypeName _ = "EnumMapMap K"+ {--------------------------------------------------------------------- Split/Join Keys ---------------------------------------------------------------------}@@ -287,7 +335,7 @@ instance IsSplit (k :& t) Z where type Head (k :& t) Z = K k type Tail (k :& t) Z = t- splitKey Z (KCC emm) = KEC $ emm+ splitKey Z (KCC emm) = KEC emm instance (Enum k1, k1 ~ k2) => SubKey (K k1) (k2 :& t2) v where type Result (K k1) (k2 :& t2) v = EnumMapMap t2 v@@ -318,12 +366,10 @@ differenceSet (KEC emm) (EMS.KSC ems) = KEC $ differenceSet_ emm ems member_ :: Key -> EMM k v -> Bool-member_ key emm = go emm+member_ key = go where go t = case t of- Bin _ m l r -> case zero key m of- True -> go l- False -> go r+ Bin _ m l r -> if zero key m then go l else go r Tip kx _ -> key == kx Nil -> False @@ -383,7 +429,7 @@ buildTree g !prefix !bmask bits = case bits of 0 -> Tip prefix (f prefix)- _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of+ _ -> case intFromNat (natFromInt bits `shiftRL` 1) of bits2 | bmask .&. ((1 `shiftLL` bits2) -1) == 0 -> buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2@@ -400,9 +446,9 @@ intersectSet_ :: EMM k v -> EMS.EMS k -> EMM k v intersectSet_ emm ems = mergeWithKey' bin const (const Nil) (const Nil) emm ems'- where ems' = fromSet_ (\_ -> ()) ems+ where ems' = fromSet_ (const ()) ems differenceSet_ :: EMM k v -> EMS.EMS k -> EMM k v differenceSet_ emm ems = mergeWithKey' bin (\_ _ -> Nil) id (const Nil) emm ems'- where ems' = fromSet_ (\_ -> ()) ems+ where ems' = fromSet_ (const ()) ems
Data/EnumMapMap/Strict.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE CPP, BangPatterns, FlexibleInstances, GeneralizedNewtypeDeriving,- MagicHash, MultiParamTypeClasses, TypeFamilies, TypeOperators #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- |@@ -29,6 +26,21 @@ -- The functions are strict on values and keys. ----------------------------------------------------------------------------- +{-# LANGUAGE+ CPP,+ BangPatterns,+ DeriveDataTypeable,+ FlexibleInstances,+ GeneralizedNewtypeDeriving,+ MagicHash,+ MultiParamTypeClasses,+ StandaloneDeriving,+ TypeFamilies,+ TypeOperators,+ UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++ module Data.EnumMapMap.Strict ( emptySubTrees,@@ -73,6 +85,9 @@ -- * Map map, mapWithKey,+ mapMaybe,+ mapMaybeWithKey,+ traverseWithKey, -- * Folds foldr, foldrWithKey,@@ -97,10 +112,13 @@ import Prelude hiding (lookup,map,filter,foldr,foldl,null, init) +import Control.Applicative ((<$>)) import Control.DeepSeq (NFData(rnf)) import Data.Bits import qualified Data.Foldable as FOLD+import Data.SafeCopy import Data.Semigroup+import Data.Typeable import Data.EnumMapMap.Base import qualified Data.EnumMapSet.Base as EMS@@ -113,6 +131,11 @@ newtype K k = K k deriving (Show, Eq) +instance (Enum k) => MkNestedPair (K k) v where+ type NestedPair (K k) v = (Int, v)+ nestedPair (K k) v = (fromEnum k, v)+ unNestedPair (k, v) = (K $ toEnum k, v)+ instance (Enum k, Eq k) => IsKey (K k) where newtype EnumMapMap (K k) v = KEC (EMM k v) @@ -165,7 +188,17 @@ where key = fromEnum key' - mapWithKey f (KEC emm) = KEC $ mapWithKey_ (\k -> id $! f $! K k) emm+ mapWithKey f (KEC emm) = KEC $ mapWithKey_ (\k -> f $! K k) emm+ mapMaybeWithKey f (KEC emm) = KEC $ go emm+ where+ go (Bin p m l r) = bin p m (go l) (go r)+ go (Tip k x) = case f (K $! toEnum k) x of+ Just !y -> Tip k y+ Nothing -> Nil+ go Nil = Nil++ traverseWithKey f (KEC emm) = KEC <$> traverseWithKey_ (\k -> f $! K k) emm+ foldr f init (KEC emm) = case emm of Bin _ m l r | m < 0 -> go (go init l) r | otherwise -> go (go init r) l@@ -199,7 +232,7 @@ go (Bin _ _ l' _) = go l' go Nil = error "findMin: Nil" minViewWithKey (KEC emm) =- goat emm >>= \(r, emm') -> return (r, KEC $ emm')+ goat emm >>= \(r, emm') -> return (r, KEC emm') where goat t = case t of Nil -> Nothing@@ -278,6 +311,23 @@ toS (K !k) = EMS.S k toK (EMS.S !k) = K k +deriving instance Typeable1 K++instance (Enum k) => SafeCopy (K k) where+ getCopy = contain $ do+ k <- safeGet+ return $ K $ toEnum k+ putCopy (K k) = contain $ safePut $ fromEnum k+ errorTypeName _ = "K"++-- We put this here so that it doesn't interfere with EnumMapSet version+instance (SafeCopy (K k), SafeCopy v, IsKey (K k),+ Result (K k) (K k) v ~ v, SubKey (K k) (K k) v) =>+ SafeCopy (EnumMapMap (K k) v) where+ getCopy = contain $ fmap fromList safeGet+ putCopy = contain . safePut . toList+ errorTypeName _ = "EnumMapMap K"+ {--------------------------------------------------------------------- Split/Join Keys ---------------------------------------------------------------------}@@ -287,7 +337,7 @@ instance IsSplit (k :& t) Z where type Head (k :& t) Z = K k type Tail (k :& t) Z = t- splitKey Z (KCC emm) = KEC $ emm+ splitKey Z (KCC emm) = KEC emm instance (Enum k1, k1 ~ k2) => SubKey (K k1) (k2 :& t2) v where type Result (K k1) (k2 :& t2) v = EnumMapMap t2 v@@ -303,7 +353,7 @@ member (K key) (KEC emm) = member_ (fromEnum key) emm singleton !(K key) !val = KEC $! Tip (fromEnum key) val lookup (K key') (KEC emm) = lookup_ (fromEnum key') emm- insert !(K key') !val (KEC emm) = KEC $ insert_ (fromEnum key') val emm+ insert !(K key') !val (KEC emm) = KEC $! insert_ (fromEnum key') val emm insertWithKey f !k@(K key') !val (KEC emm) = KEC $ insertWK (f k) (fromEnum key') val emm delete !(K key') (KEC emm) = KEC $ delete_ (fromEnum key') emm@@ -317,17 +367,15 @@ differenceSet (KEC emm) (EMS.KSC ems) = KEC $ differenceSet_ emm ems member_ :: Key -> EMM k v -> Bool-member_ key emm = go emm+member_ key = go where go t = case t of- Bin _ m l r -> case zero key m of- True -> go l- False -> go r+ Bin _ m l r -> if zero key m then go l else go r Tip kx _ -> key == kx Nil -> False lookup_ :: Key -> EMM k v -> Maybe v-lookup_ !key emm = go emm+lookup_ !key = go where go t = case t of Bin _ m l r@@ -363,7 +411,7 @@ Nil -> Tip key val delete_ :: Key -> EMM k v -> EMM k v-delete_ !key emm = go emm+delete_ !key = go where go t = case t of Bin p m l r | nomatch key p m -> t | zero key m -> bin p m (go l) r@@ -380,8 +428,8 @@ go (EMS.Tip key bm) = buildTree f key bm (EMS.suffixBitMask + 1) buildTree g !prefix !bmask bits = case bits of- 0 -> Tip prefix $! (f prefix)- _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of+ 0 -> Tip prefix $! f prefix+ _ -> case intFromNat (natFromInt bits `shiftRL` 1) of bits2 | bmask .&. ((1 `shiftLL` bits2) -1) == 0 -> buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2@@ -400,9 +448,9 @@ intersectSet_ :: EMM k v -> EMS.EMS k -> EMM k v intersectSet_ emm ems = mergeWithKey' bin const (const Nil) (const Nil) emm ems'- where ems' = fromSet_ (\_ -> ()) ems+ where ems' = fromSet_ (const ()) ems differenceSet_ :: EMM k v -> EMS.EMS k -> EMM k v differenceSet_ emm ems = mergeWithKey' bin (\_ _ -> Nil) id (const Nil) emm ems'- where ems' = fromSet_ (\_ -> ()) ems+ where ems' = fromSet_ (const ()) ems
Data/EnumMapSet.hs view
@@ -27,6 +27,9 @@ module Data.EnumMapSet ( EnumMapSet, S(..), (:&)(..),+ Result,+ IsKey,+ SubKey, -- * Query EMS.null, size,
Data/EnumMapSet/Base.hs view
@@ -1,8 +1,3 @@-{-# LANGUAGE BangPatterns, CPP, FlexibleContexts, FlexibleInstances,- GeneralizedNewtypeDeriving, MagicHash, MultiParamTypeClasses, TypeFamilies,- TypeOperators #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}- ----------------------------------------------------------------------------- -- | -- Module : Data.EnumMapSet@@ -17,9 +12,27 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE+ BangPatterns,+ CPP,+ DeriveDataTypeable,+ FlexibleInstances,+ FlexibleContexts,+ GeneralizedNewtypeDeriving,+ MagicHash,+ MultiParamTypeClasses,+ StandaloneDeriving,+ TypeFamilies,+ TypeOperators,+ UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+ module Data.EnumMapSet.Base ( EnumMapSet, S(..), (:&)(..),+ EMM.Result,+ EMM.IsKey,+ EMM.SubKey, -- * Query null, size,@@ -63,11 +76,14 @@ import Data.Bits import qualified Data.List as List import Data.Maybe (fromMaybe)+import Data.SafeCopy+import Data.Typeable import GHC.Exts (Word(..), Int(..)) import GHC.Prim (indexInt8OffAddr#) #include "MachDeps.h" import Data.EnumMapMap.Base ((:&)(..),+ MkNestedPair(..), IsKey, EnumMapMap, Prefix, Nat, Mask,@@ -91,6 +107,11 @@ newtype S k = S k deriving (Show, Eq) +instance (Enum k) => MkNestedPair (S k) () where+ type NestedPair (S k) () = Int+ nestedPair (S k) _ = fromEnum k+ unNestedPair k = (S $ toEnum k, ())+ -- This is used instead of @EMM k BitMap@ in order to unpack the 'BitMap' in -- 'Tip'. Hopefully this will lead to much optimisation by GHC. data EMS k = Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask@@ -137,7 +158,7 @@ go init' Nil = init' go init' (Tip kx bm) = foldrBits kx f' init' bm go init' (Bin _ _ l r) = go (go init' r) l- f' !k t = f (S $ toEnum k) undefined t+ f' !k = f (S $ toEnum k) $ error "foldrWihKey: No value in EnumMapSet" findMin (KSC ems) = case ems of@@ -263,7 +284,7 @@ equal (KSC ems1) (KSC ems2) = go ems1 ems2 where go (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)- = (m1 == m2) && (p1 == p2) && (go l1 l2) && (go r1 r2)+ = (m1 == m2) && (p1 == p2) && go l1 l2 && (go r1 r2) go (Tip kx1 bm1) (Tip kx2 bm2) = kx1 == kx2 && bm1 == bm2 go Nil Nil = True@@ -272,7 +293,7 @@ nequal (KSC ems1) (KSC ems2) = go ems1 ems2 where go (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)- = (m1 /= m2) || (p1 /= p2) || (go l1 l2) || (go r1 r2)+ = (m1 /= m2) || (p1 /= p2) || go l1 l2 || (go r1 r2) go (Tip kx1 bm1) (Tip kx2 bm2) = kx1 /= kx2 || bm1 /= bm2 go Nil Nil = False@@ -282,6 +303,8 @@ foldr = undefined map = undefined mapWithKey = undefined+ mapMaybeWithKey = undefined+ traverseWithKey = undefined unionWith = undefined unionWithKey = undefined differenceWith = undefined@@ -345,7 +368,7 @@ foldr :: (IsKey k) => (k -> t -> t) -> t -> EnumMapSet k -> t foldr f = EMM.foldrWithKey go where- go k _ z = f k z+ go k _ = f k all :: (IsKey k) => (k -> Bool) -> EnumMapSet k -> Bool all f = foldr go True@@ -388,7 +411,7 @@ fromList :: (IsKey k, EMM.SubKey k k (), EMM.Result k k () ~ ()) => [k] -> EnumMapSet k fromList xs- = foldlStrict (\t x -> insert x t) empty xs+ = foldlStrict (flip insert) empty xs toList :: IsKey k => EnumMapSet k -> [k] toList = foldr (:) []@@ -411,9 +434,7 @@ member !(S key') (EMM.KCC emm) = key `seq` go emm where go t = case t of- EMM.Bin _ m l r -> case zero key m of- True -> go l- False -> go r+ EMM.Bin _ m l r -> if zero key m then go l else go r EMM.Tip kx _ -> key == kx EMM.Nil -> False key = fromEnum key'@@ -487,6 +508,24 @@ instance (Show v) => Show (EnumMapMap (S k) v) where show (KSC ems) = show ems +deriving instance Typeable1 S++instance (Enum s) => SafeCopy (S s) where+ getCopy = contain $ do+ s <- safeGet+ return $ S $ toEnum s+ putCopy (S s) = contain $ safePut $ fromEnum s+ errorTypeName _ = "S"++-- This can't live in EnumMapMap.Base because it calls the undefined toList and+-- fromList functions+instance (SafeCopy (S k), EMM.IsKey (S k),+ EMM.Result (S k) (S k) () ~ (), EMM.SubKey (S k) (S k) ()) =>+ SafeCopy (EnumMapSet (S k)) where+ getCopy = contain $ fmap fromList safeGet+ putCopy = contain . safePut . toList+ errorTypeName _ = "EnumMapSet"+ {--------------------------------------------------------------------- Helper functions ---------------------------------------------------------------------}@@ -570,7 +609,7 @@ {-# INLINE bitmapOf #-} bitcount :: Int -> Word -> Int-bitcount a0 x0 = go a0 x0+bitcount = go where go a 0 = a go a x = go (a + 1) (x .&. (x-1)) {-# INLINE bitcount #-}
enummapmap.cabal view
@@ -1,5 +1,5 @@ name: enummapmap-version: 0.5.0+version: 0.6.0 synopsis: Map of maps using Enum types as keys description: This package provides 'maps of maps' using Enum types as keys. The code is based upon Data.IntMap in@@ -25,6 +25,7 @@ data-default, deepseq >= 1.2 && < 1.4, ghc-prim,+ safecopy >= 0.8 && < 0.9, semigroups >= 0.8 ghc-options: -Wall -O2 default-language: Haskell2010@@ -40,7 +41,9 @@ QuickCheck >= 2, hspec >= 1.3, hspec-expectations,+ cereal >= 0.4, deepseq >= 1.2 && < 1.4,+ safecopy >= 0.8 && < 0.9, semigroups >= 0.8, enummapmap cpp-options: -DTESTING -DLAZY@@ -72,7 +75,9 @@ QuickCheck >= 2, hspec >= 1.3, hspec-expectations,+ cereal >= 0.4, deepseq >= 1.2 && < 1.4,+ safecopy >= 0.8 && < 0.9, semigroups >= 0.8, enummapmap cpp-options: -DTESTING -DSTRICT@@ -104,7 +109,9 @@ QuickCheck >= 2, hspec >= 1.3, hspec-expectations,+ cereal >= 0.4, deepseq >= 1.2 && < 1.4,+ safecopy >= 0.8 && < 0.9, containers >= 0.4.2, enummapmap @@ -122,6 +129,44 @@ containers >= 0.4.2, enummapmap cpp-options: -DTESTING++Test-Suite test-both-lazy+ type: exitcode-stdio-1.0+ main-is: UnitBoth.hs+ hs-source-dirs: test+ ghc-options: -Wall -O2+ default-language: Haskell2010+ build-depends: base >= 4.0 && < 5,++ HUnit,+ hspec >= 0.9,+ QuickCheck >= 2,++ cereal >= 0.4,+ deepseq >= 1.2 && < 1.4,+ safecopy >= 0.8 && < 0.9,++ enummapmap+ cpp-options: -DTESTING -DLAZY++Test-Suite test-both-strict+ type: exitcode-stdio-1.0+ main-is: UnitBoth.hs+ hs-source-dirs: test+ ghc-options: -Wall -O2+ default-language: Haskell2010+ build-depends: base >= 4.0 && < 5,++ HUnit,+ hspec >= 0.9,+ QuickCheck >= 2,++ cereal >= 0.4,+ deepseq >= 1.2 && < 1.4,+ safecopy >= 0.8 && < 0.9,++ enummapmap+ cpp-options: -DTESTING -DSTRICT benchmark enummapmap-vs-intmap-bench type: exitcode-stdio-1.0
test/EnumMapMapVsIntMap.hs view
@@ -11,12 +11,14 @@ import Test.Hspec.QuickCheck (prop) import Test.QuickCheck ((==>)) +import Control.Monad(liftM) import qualified Data.IntSet as IS import Data.EnumMapSet (S(..)) import qualified Data.EnumMapSet as EMS import Data.Foldable (foldMap, fold) import qualified Data.List as L import Data.Semigroup+import Data.Traversable (Traversable(traverse)) #ifdef LAZY import qualified Data.IntMap as IM@@ -168,7 +170,7 @@ -> [(Int, Int)] -> Bool runPropL f g =- runProp (list2l1 . IM.toList . f) (EMM.toList . g)+ runProp (list2l1 . IM.toList . f) (EMM.toList . g) runPropDuoL :: (IM.IntMap Int -> IM.IntMap Int -> IM.IntMap Int) -> (TestMap -> TestMap -> TestMap)@@ -179,6 +181,14 @@ runPropDuo (\a b -> list2l1 $ IM.toList $ f a b) (\a b -> EMM.toList $ g a b) +runPropLM :: (Monad m, Eq (m [(K Int, Int)])) =>+ (IM.IntMap Int -> m (IM.IntMap Int))+ -> (TestMap -> m TestMap)+ -> [(Int, Int)]+ -> Bool+runPropLM f g =+ runProp (liftM (list2l1 . IM.toList) . f) (liftM EMM.toList . g)+ runPropL2 :: (IM.IntMap Int -> IM.IntMap Int) -> (TestMap2 -> TestMap2) -> Int@@ -197,6 +207,15 @@ runPropDuo2 (\a b -> list2l2 k1 $ IM.toList $ f a b) (\a b -> EMM.toList $ g a b) k1 +runPropLM2 :: (Monad m, Eq (m [(Int :& K Int, Int)])) =>+ (IM.IntMap Int -> m (IM.IntMap Int))+ -> (TestMap2 -> m TestMap2)+ -> Int+ -> [(Int, Int)]+ -> Bool+runPropLM2 f g k1 =+ runProp2 (liftM (list2l2 k1 . IM.toList) . f) (liftM EMM.toList . g) k1+ runPropL3 :: (IM.IntMap Int -> IM.IntMap Int) -> (TestMap3 -> TestMap3) -> Int@@ -403,20 +422,67 @@ prop "Level 4" $ runPropL4 (IM.mapWithKey f) (EMM.mapWithKey (f . unKey4)) + describe "mapMaybe" $ do+ let f a+ | a > 2 = Just $ 1 + a+ | otherwise = Nothing+ prop "Level 1" $+ runPropL (IM.mapMaybe f) (EMM.mapMaybe f)+ prop "Level 2" $+ runPropL2 (IM.mapMaybe f) (EMM.mapMaybe f)+ prop "Level 3" $+ runPropL3 (IM.mapMaybe f) (EMM.mapMaybe f)+ prop "Level 4" $+ runPropL4 (IM.mapMaybe f) (EMM.mapMaybe f)++ describe "mapMaybeWithKey" $ do+ let f k a+ | a > 2 = Just $ k + a+ | otherwise = Nothing+ prop "Level 1" $+ runPropL (IM.mapMaybeWithKey f) (EMM.mapMaybeWithKey (f . unKey1))+ prop "Level 2" $+ runPropL2 (IM.mapMaybeWithKey f) (EMM.mapMaybeWithKey (f . unKey2))+ prop "Level 3" $+ runPropL3 (IM.mapMaybeWithKey f) (EMM.mapMaybeWithKey (f . unKey3))+ prop "Level 4" $+ runPropL4 (IM.mapMaybeWithKey f) (EMM.mapMaybeWithKey (f . unKey4))++ describe "traverseWithKey" $ do+ let f k v = if odd k then+ Just (succ v)+ else+ Nothing++ prop "Level 1" $+ runPropLM (IM.traverseWithKey f) (EMM.traverseWithKey (f . unKey1))+ prop "Level 2" $+ runPropLM2 (IM.traverseWithKey f) (EMM.traverseWithKey (f . unKey2))++ describe "traverse" $ do+ let f v = if odd v then+ Just (succ v)+ else+ Nothing+ prop "Level 1" $+ runPropLM (traverse f) (traverse f)+ prop "Level 2" $+ runPropLM2 (traverse f) (traverse f)+ describe "findMin" $ do let go f (a, b) = (f a, b) prop "Level 1" $ \list -> (not $ L.null list) ==>- runProp (IM.findMin) (go unKey1 . EMM.findMin) list+ runProp IM.findMin (go unKey1 . EMM.findMin) list prop "Level 2" $ \k1 list -> (not $ L.null list) ==>- runProp2 (IM.findMin) (go unKey2 . EMM.findMin) k1 list+ runProp2 IM.findMin (go unKey2 . EMM.findMin) k1 list prop "Level 3" $ \k1 k2 list -> (not $ L.null list) ==>- runProp3 (IM.findMin) (go unKey3 . EMM.findMin) k1 k2 list+ runProp3 IM.findMin (go unKey3 . EMM.findMin) k1 k2 list prop "Level 4" $ \k1 k2 k3 list -> (not $ L.null list) ==>- runProp4 (IM.findMin) (go unKey4 . EMM.findMin) k1 k2 k3 list+ runProp4 IM.findMin (go unKey4 . EMM.findMin) k1 k2 k3 list describe "minViewWithKey" $ do let goe _ Nothing = Nothing@@ -514,23 +580,23 @@ describe "keys" $ do prop "Level 1" $- runProp (IM.keys) (map (\(K k) -> k) . EMM.keys)+ runProp IM.keys (map (\(K k) -> k) . EMM.keys) prop "Level 2" $- runProp2 (IM.keys) (map (\(k :& _) -> k) . EMM.keys)+ runProp2 IM.keys (map (\(k :& _) -> k) . EMM.keys) prop "Level 3" $- runProp3 (IM.keys) (map (\(k :& _) -> k) . EMM.keys)+ runProp3 IM.keys (map (\(k :& _) -> k) . EMM.keys) prop "Level 4" $- runProp4 (IM.keys) (map (\(k :& _) -> k) . EMM.keys)+ runProp4 IM.keys (map (\(k :& _) -> k) . EMM.keys) describe "elems" $ do prop "Level 1" $- runProp (IM.elems) (EMM.elems)+ runProp IM.elems EMM.elems prop "Level 2" $- runProp2 (IM.elems) (EMM.elems)+ runProp2 IM.elems EMM.elems prop "Level 3" $- runProp3 (IM.elems) (EMM.elems)+ runProp3 IM.elems EMM.elems prop "Level 4" $- runProp4 (IM.elems) (EMM.elems)+ runProp4 IM.elems EMM.elems describe "keysSet" $ do prop "Level 1" $
+ test/UnitBoth.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE+ CPP,+ DeriveDataTypeable,+ FlexibleInstances,+ GeneralizedNewtypeDeriving,+ OverlappingInstances,+ TypeFamilies,+ TypeOperators,+ TypeSynonymInstances,+ UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++import Test.Hspec.QuickCheck (prop)+import Test.Hspec+import Test.QuickCheck (Arbitrary, arbitrary, shrink, listOf)++import Control.Monad (liftM, liftM2)+import Data.SafeCopy+import Data.Serialize.Get (runGet)+import Data.Serialize.Put (runPut)+import Data.Typeable++#ifdef LAZY+import Data.EnumMapMap.Lazy(EnumMapMap, (:&)(..), K(..))+import qualified Data.EnumMapMap.Lazy as EMM+#else+import Data.EnumMapMap.Strict(EnumMapMap, (:&)(..), K(..))+import qualified Data.EnumMapMap.Strict as EMM+#endif++import Data.EnumMapSet (EnumMapSet, S(..))+import qualified Data.EnumMapSet as EMS++instance (Arbitrary a, Arbitrary b) => Arbitrary (a :& b) where+ arbitrary = liftM2 (:&) arbitrary arbitrary+ shrink (x :& y) = [ x' :& y | x' <- shrink x ]+ ++ [ x :& y' | y' <- shrink y ]++instance (Arbitrary s) => Arbitrary (S s) where+ arbitrary = liftM S arbitrary++instance (Arbitrary k, EMS.Result k k () ~ (), EMS.IsKey k, EMS.SubKey k k ()) =>+ Arbitrary (EnumMapSet k) where+ arbitrary = fmap EMS.fromList $ listOf arbitrary++instance (Arbitrary a) => Arbitrary (K a) where+ arbitrary = liftM K arbitrary++instance (Arbitrary k, Arbitrary v,+ EMM.IsKey k, EMM.SubKey k k v, EMM.Result k k v ~ v) =>+ Arbitrary (EnumMapMap k v) where+ arbitrary = fmap EMM.fromList $ listOf $ do+ key <- arbitrary+ val <- arbitrary+ return (key, val)++newtype ID1 = ID1 Int+ deriving (Show, Enum, Arbitrary, Eq, Num, Typeable)+newtype ID2 = ID2 Int+ deriving (Show, Enum, Arbitrary, Eq, Num, Typeable)+newtype ID3 = ID3 Int+ deriving (Show, Enum, Arbitrary, Eq, Num, Typeable)++type TestEmm2 = EnumMapMap (ID2 :& K ID1) Int+type TestEms2 = EnumMapSet (ID2 :& S ID1)++main :: IO ()+main =+ hspec $ do+ -- Tests repeated from UnitEnumMap*. Here we're checking+ -- for instance overlaps+ describe "EnumMapMap SafeCopy instance" $ do+ let testEq :: TestEmm2 -> Bool+ testEq emm = op == Right emm+ where+ op = runGet safeGet $ runPut $ safePut emm+ prop "Leaves data intact" testEq+ describe "EnumMapSet SafeCopy Instance" $ do+ let testEq :: TestEms2 -> Bool+ testEq ems = op == Right ems+ where+ op = runGet safeGet $ runPut $ safePut ems+ prop "Leaves data intact" testEq
test/UnitEnumMapMap.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP,+ DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,@@ -11,13 +12,20 @@ import Control.Exception import Control.Monad (liftM, liftM2)+import qualified Data.Foldable as Foldable+import Data.SafeCopy+import Data.Serialize.Get (runGet)+import Data.Serialize.Put (runPut) import Data.Semigroup+import Data.Typeable+ import Test.Hspec.Expectations import Test.Hspec.HUnit () import Test.Hspec import Test.Hspec.QuickCheck (prop) import Test.HUnit import Test.QuickCheck (Arbitrary, arbitrary, shrink, listOf)+ import qualified Data.EnumMapSet as EMS #ifdef LAZY@@ -45,11 +53,11 @@ return (key, val) newtype ID1 = ID1 Int- deriving (Show, Enum, Arbitrary, Eq, Num)+ deriving (Show, Enum, Arbitrary, Eq, Num, Typeable) newtype ID2 = ID2 Int- deriving (Show, Enum, Arbitrary, Eq, Num)+ deriving (Show, Enum, Arbitrary, Eq, Num, Typeable) newtype ID3 = ID3 Int- deriving (Show, Enum, Arbitrary, Eq, Num)+ deriving (Show, Enum, Arbitrary, Eq, Num, Typeable) type TestKey1 = K ID1 type TestEmm1 = EnumMapMap TestKey1 Int@@ -86,6 +94,8 @@ l1tens :: EnumMapMap I Int l1tens = EMM.fromList $ map (\(key, v) -> (K key, v)) $ zip [1..7] tens+l1IDtens :: TestEmm1+l1IDtens = EMM.fromList $ map (\(key, v) -> (K $ ID1 key, v)) $ zip [1..7] tens l2tens :: EnumMapMap (Int :& I) Int l2tens = EMM.fromList $ zip (do k1 <- [1, 2]@@ -117,6 +127,14 @@ emm1 = EMM.fromList l1 emm2 = EMM.fromList l2 +checkSubs1 :: (TestEmm3 -> TestEmm3)+ -> [(TestKey3, Int)]+ -> Bool+checkSubs1 f l1 =+ False == (EMM.emptySubTrees $ f emm1)+ where+ emm1 = EMM.fromList l1+ main :: IO () main = hspec $ do@@ -291,30 +309,44 @@ EMM.foldrWithKey (\(k1 :& K k2) _ -> (+) (k1 * k2)) 0 l2tens @?= 84 - describe "union" $ do+ describe "mapMaybe" $ do+ let f v+ | v > 2 = Just $ v+ | otherwise = Nothing+ prop "No empty subtrees" $+ checkSubs1 (EMM.mapMaybe f)++ describe "mapMaybeWithKey" $ do+ let f _ v+ | v > 2 = Just $ v+ | otherwise = Nothing+ prop "No empty subtrees" $+ checkSubs1 (EMM.mapMaybeWithKey f)++ describe "union" $ do describe "Level 1" $ do it "includes every key from each EnumMapMap" $ (EMM.union l1odds l1evens) @?= l1alls -- Just in case... prop "Leaves no empty subtrees" $ checkSubs EMM.union - describe "difference" $ do+ describe "difference" $ do prop "Leaves no empty subtrees" $ checkSubs EMM.difference - describe "differenceWithKey" $ do+ describe "differenceWithKey" $ do let f (k1 :& k2 :& K k3) v1 v2 = Just $ v1 + v2 + (fromEnum k1) + (fromEnum k2) + (fromEnum k3) prop "Leaves no empty subtrees" $ checkSubs (EMM.differenceWithKey f) - describe "intersection" $ do+ describe "intersection" $ do prop "Leaves no empty subtrees" $ checkSubs EMM.intersection - describe "intersectionWithKey" $ do+ describe "intersectionWithKey" $ do let f (k1 :& k2 :& K k3) v1 v2 = v1 + v2 + (fromEnum k1) + (fromEnum k2) + (fromEnum k3) prop "Leaves no empty subtrees" $ checkSubs (EMM.intersectionWithKey f) - describe "joinKey $ splitKey z t == t" $ do+ describe "joinKey $ splitKey z t == t" $ do let go21 :: [(Int :& K Int, Int)] -> Bool go21 l = emm == (EMM.joinKey $ EMM.splitKey EMM.d1 emm) where emm = EMM.fromList l@@ -330,7 +362,7 @@ where emm = EMM.fromList l prop "Level 3, depth = 2" go32 - describe "keysSet" $ do+ describe "keysSet" $ do describe "produces same result as keys" $ do let gol1 :: [(K Int, Int)] -> Bool gol1 list = EMM.keys emm == (map EMM.toK $ EMS.toList $ EMM.keysSet emm)@@ -338,7 +370,7 @@ emm = EMM.fromList list prop "Level 1" gol1 - describe "intersectSet" $ do+ describe "intersectSet" $ do it "leaves correct values" $ (EMM.intersectSet l1odds $ EMS.fromList [s 1, s 2, s 3]) @?= EMM.fromList [(k 1, 1), (k 3, 3)]@@ -347,7 +379,7 @@ @?= EMM.fromList [(1 :& k 1, 1), (1 :& k 3, 3), (1 :& k 5, 5)] -- TODO: check for empty subtrees - describe "differenceSet" $ do+ describe "differenceSet" $ do it "works correctly" $ (EMM.differenceSet l1fewOdds $ EMS.fromList [s 3, s 4, s 5]) @?= EMM.fromList [(k 1, 1)]@@ -355,17 +387,17 @@ (EMM.differenceSet l2odds $ EMS.fromList [s 3, s 4, s 5]) @?= EMM.fromList [(1 :& k 1, 1), (1 :& k 3, 3), (1 :& k 5, 5)] - describe "findMin" $ do+ describe "findMin" $ do it "throws an error when it is passed an empty EnumMapMap" $ do evaluate (EMM.findMin (EMM.empty :: EnumMapMap (K Int) Int)) `shouldThrow` anyErrorCall - describe "deleteFindMin" $ do+ describe "deleteFindMin" $ do it "throws an error when it is passed an empty EnumMapMap" $ do evaluate (EMM.deleteFindMin (EMM.empty :: EnumMapMap (K Int) Int)) `shouldThrow` anyErrorCall - describe "Monoid/Semigroup instances" $ do+ describe "Monoid/Semigroup instances" $ do let uvsm :: TestEmm3 -> TestEmm3 -> Bool uvsm emm1 emm2 = ((EMM.map Sum emm1) <> (EMM.map Sum emm2)) ==@@ -382,3 +414,31 @@ (EMM.map All $ EMM.unionsWith (&&) emms) prop "unionsWith (&&) works like mconcat All" bvsu + describe "Foldable instance" $ do+ describe "Foldable.all" $ do+ it "Level 1 true" $+ True @=? Foldable.all (> 0) l1tens+ it "Level 1 false" $+ False @=? Foldable.all (> 1) l1tens+ it "Level 1 true with newtype key" $+ True @=? Foldable.all (> 0) l1IDtens+ it "Level 1 false with newtype key" $+ False @=? Foldable.all (> 1) l1IDtens+ describe "Foldable.any" $ do+ it "Level 1 true" $+ False @=? Foldable.any (< 1) l1tens+ it "Level 1 false" $+ True @=? Foldable.any (< 2) l1tens++ describe "Typeable Instance" $ do+ it "TypeOf is unique when ID types differ" $+ ((typeOf l1IDtens) == (typeOf l1tens)) @?= False+ it "TypeOf is unique when different levels" $+ ((typeOf l2tens) == (typeOf l1tens)) @?= False++ describe "SafeCopy instance" $ do+ let testEq :: TestEmm3 -> Bool+ testEq emm = op == Right emm+ where+ op = runGet safeGet $ runPut $ safePut emm+ prop "Leaves data intact" testEq
test/UnitEnumMapSet.hs view
@@ -1,14 +1,68 @@-{-# LANGUAGE CPP, TypeOperators #-}+{-# LANGUAGE+ CPP,+ DeriveDataTypeable,+ FlexibleInstances,+ GeneralizedNewtypeDeriving,+ TypeFamilies,+ TypeOperators,+ TypeSynonymInstances,+ UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} import Test.Hspec.Expectations import Test.Hspec.HUnit () import Test.Hspec.QuickCheck (prop) import Test.Hspec+import Test.HUnit+import Test.QuickCheck (Arbitrary, arbitrary, shrink, listOf) +import Control.Monad (liftM, liftM2)+import qualified Data.List as List+import Data.SafeCopy+import Data.Serialize.Get (runGet)+import Data.Serialize.Put (runPut)+import Data.Typeable+ import Data.EnumMapSet (EnumMapSet, (:&)(..), S(..)) import qualified Data.EnumMapSet as EMS-import qualified Data.List as List +newtype ID1 = ID1 Int+ deriving (Show, Enum, Arbitrary, Eq, Num, Typeable)+newtype ID2 = ID2 Int+ deriving (Show, Enum, Arbitrary, Eq, Num, Typeable)++type TestKey1 = S ID1+type TestEms1 = EnumMapSet TestKey1+type TestKey2 = ID2 :& S ID1+type TestEms2 = EnumMapSet TestKey2++instance (Arbitrary a, Arbitrary b) => Arbitrary (a :& b) where+ arbitrary = liftM2 (:&) arbitrary arbitrary+ shrink (x :& y) = [ x' :& y | x' <- shrink x ]+ ++ [ x :& y' | y' <- shrink y ]++instance (Arbitrary s) => Arbitrary (S s) where+ arbitrary = liftM S arbitrary++instance (Arbitrary k, EMS.Result k k () ~ (), EMS.IsKey k, EMS.SubKey k k ()) =>+ Arbitrary (EnumMapSet k) where+ arbitrary = fmap EMS.fromList $ listOf arbitrary++tens :: [Int]+tens = [1, 10, 100, 1000, 10000, 100000, 1000000]++l1IDtens :: TestEms1+l1IDtens = EMS.fromList $ map (\k -> S $ ID1 k) tens++l1tens :: EnumMapSet (S Int)+l1tens = EMS.fromList $ map (\k -> S k) tens++l2tens :: TestEms2+l2tens = EMS.fromList $ do+ k1 <- [1, 5, 10]+ k2 <- tens+ return $ (ID2 k2) :& (S $ ID1 k1)+ main :: IO () main = hspec $ do@@ -30,3 +84,22 @@ EMS.all f (EMS.fromList list') == List.all f list' prop "is equivalent to List.all" prop_list + describe "toList and fromList" $ do+ let testEq :: TestEms2 -> Bool+ testEq emm = op == emm+ where+ op = EMS.fromList $ EMS.toList emm+ prop "Leaves data intact" testEq++ describe "Typeable Instance" $ do+ it "TypeOf is unique when ID types differ" $+ ((typeOf l1IDtens) == (typeOf l1tens)) @?= False+ it "TypeOf is unique when different levels" $+ ((typeOf l2tens) == (typeOf l1tens)) @?= False++ describe "SafeCopy Instance" $ do+ let testEq :: TestEms2 -> Bool+ testEq ems = op == Right ems+ where+ op = runGet safeGet $ runPut $ safePut ems+ prop "Leaves data intact" testEq