enummapmap (empty) → 0.0.2
raw patch · 8 files changed
+1975/−0 lines, 8 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, containers, deepseq, enummapmap, hspec
Files
- Data/EnumMapMap/Base.hs +715/−0
- Data/EnumMapMap/Lazy.hs +242/−0
- Data/EnumMapMap/Strict.hs +243/−0
- LICENSE +26/−0
- Setup.hs +6/−0
- enummapmap.cabal +83/−0
- test/EnumMapMapVsIntMap.hs +411/−0
- test/UnitEnumMapMap.hs +249/−0
+ Data/EnumMapMap/Base.hs view
@@ -0,0 +1,715 @@+{-# LANGUAGE MagicHash, TypeFamilies, MultiParamTypeClasses,+ BangPatterns, FlexibleInstances, TypeOperators,+ FlexibleContexts #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.EnumMapMap.Base+-- Copyright : (c) Daan Leijen 2002+-- (c) Andriy Palamarchuk 2008+-- (c) Matthew West 2012+-- License : BSD-style+-- Maintainer :+-- Stability : experimental+-- Portability : Uses GHC extensions+--+-- Based on Data.IntMap.Base.+--+-- This defines the EnumMapMap (k :& t) v instance, and the Key data types. The+-- terminating key type is K, and the EnumMapMap (K k) v instances are defined+-- in EnumMapMap.Lazy and EnumMapMap.Strict.+-----------------------------------------------------------------------------++module Data.EnumMapMap.Base(+ -- * Key types+ (:&)(..), K(..), N(..), Z(..),+ d1, d2, d3, d4, d5, d6, d7, d8, d9, d10,+ -- * Split/Join Keys+ IsSplit(..),+ Plus,+ -- * Internal+ -- ** IsEMM+ EMM(..),+ IsEmm(..),+ EnumMapMap(..),+ -- ** EMM internals+ mergeWithKey',+ mapWithKey_,+ foldrWithKey_,+ foldlStrict,+ -- ** IntMap internals+ Key,+ bin,+ tip,+ nomatch,+ match,+ join,+ zero+) where++import Prelude hiding (lookup,+ map,+ filter,+ foldr, foldl,+ null, init,+ head, tail)++import Control.DeepSeq (NFData(rnf))+import Data.Bits+import Data.Monoid (Monoid(..))+import GHC.Exts (Word(..), Int(..), shiftRL#)++data EMM k v = Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask+ !(EMM k v) !(EMM k v)+ | Tip {-# UNPACK #-} !Int v+ | Nil+ deriving (Show)++type Nat = Word+type Key = Int+type Prefix = Int+type Mask = Int++infixr 3 :&+-- | Multiple keys are joined by the (':&') constructor and terminated with 'K'.+--+-- > multiKey :: Int :& Int :& K Int+-- > multiKey = 5 :& 6 :& K 5+--+data k :& t = !k :& !t+ deriving (Show, Eq)+-- | Keys are terminated with the 'K' type+--+-- > singleKey :: K Int+-- > singleKey = K 5+--+data K k = K !k+ deriving (Show, Eq)+data Z = Z+data N n = N n++-- | Split after 1 key.+--+-- > emm :: EnumMapMap (T1 :& T2 :& K T3) v+-- > splitKey d1 emm :: EnumMapMap (T1 :& K T2) (EnumMapMap (K T3) v)+d1 :: Z+d1 = Z+-- | Split after 2 keys.+--+-- > emm :: EnumMapMap (T1 :& T2 :& K T3) v+-- > splitKey d1 emm :: EnumMapMap (K T1) (EnumMapMap (T2 :& K T3) v)+d2 :: N(Z)+d2 = N d1+d3 :: N(N(Z))+d3 = N d2+d4 :: N(N(N(Z)))+d4 = N d3+d5 :: N(N(N(N(Z))))+d5 = N d4+d6 :: N(N(N(N(N(Z)))))+d6 = N d5+d7 :: N(N(N(N(N(N(Z))))))+d7 = N d6+d8 :: N(N(N(N(N(N(N(Z)))))))+d8 = N d7+d9 :: N(N(N(N(N(N(N(N(Z))))))))+d9 = N d8+d10 :: N(N(N(N(N(N(N(N(N(Z)))))))))+d10 = N d9++class IsSplit k z where+ type Head k z :: *+ type Tail k z :: *+ -- | Split a key so that an 'EnumMapMap' becomes an 'EnumMapMap' of+ -- 'EnumMapMap's.+ --+ -- > newtype ID = ID Int deriving Enum+ -- > emm = empty :: EnumMapMap (Int :& K ID) Bool+ -- > res :: EnumMapMap (K ID) Bool+ -- > res = lookup (K 5) $ splitKey d1 emm+ --+ -- If the level is too high then the compilation will fail with an error+ --+ -- > emm = empty :: EnumMapMap (Int :& Int :& K Int) Bool -- 3 levels+ -- > res1 = splitKey d4 emm -- ERROR! Instance not found...+ -- > res2 = splitKey d3 emm -- ERROR! Instance not found...+ -- > res3 = splitKey d2 emm -- Good+ --+ splitKey :: z -> EnumMapMap k v+ -> EnumMapMap (Head k z) (EnumMapMap (Tail k z) v)++instance (IsSplit t n, Enum k) => IsSplit (k :& t) (N n) where+ type Head (k :& t) (N n) = k :& (Head t n)+ type Tail (k :& t) (N n) = Tail t n+ splitKey (N n) (KCC emm) = KCC $ mapWithKey_ (\_ -> splitKey n) emm++type family Plus k1 k2 :: *+type instance Plus (k1 :& t) k2 = k1 :& (Plus t k2)++class IsEmm k where+ -- | A map of keys to values. The keys are 'Enum' types but are stored as 'Int's+ -- so any keys with the same 'Int' value are treated as the same. The aim is to+ -- provide typesafe indexing.+ data EnumMapMap k :: * -> *++ -- | No subtrees should be empty. Returns 'True' if one is.+ emptySubTrees :: EnumMapMap k v -> Bool+ emptySubTrees_ :: EnumMapMap k v -> Bool++ removeEmpties :: EnumMapMap k v -> EnumMapMap k v++ -- | Join a key so that an 'EnumMapMap' of+ -- 'EnumMapMap's becomes an 'EnumMapMap'.+ --+ -- > newtype ID = ID Int deriving Enum+ -- > emm :: EnumMapMap (K Int) (EnumMapMap (K ID) Bool)+ -- > res :: EnumMapMap (Int :& K ID) Bool+ -- > res = joinKey emm+ --+ -- 'joinKey' is the opposite of 'splitKey'.+ --+ -- > emm = empty :: EnumMapMap (Int :& Int :& K ID) Bool)+ -- > emm == joinKey $ splitKey d2 emm+ --+ joinKey :: (IsEmm (Plus k k2)) =>+ EnumMapMap k (EnumMapMap k2 v)+ -> EnumMapMap (Plus k k2) v+ joinKey = removeEmpties . unsafeJoinKey++ -- | Join a key so that an 'EnumMapMap' of+ -- 'EnumMapMap's becomes an 'EnumMapMap'. The unsafe version does not check+ -- for empty subtrees, so it is faster.+ --+ -- > newtype ID = ID Int deriving Enum+ -- > emm :: EnumMapMap (K Int) (EnumMapMap (K ID) Bool)+ -- > res :: EnumMapMap (Int :& K ID) Bool+ -- > res = unsafeJoinKey emm+ --+ unsafeJoinKey :: EnumMapMap k (EnumMapMap k2 v)+ -> EnumMapMap (Plus k k2) v++ -- | The empty 'EnumMapMap'.+ empty :: EnumMapMap k v+ -- | Is the 'EnumMapMap' empty?+ --+ -- Submaps can never be empty, so the following should always hold true:+ --+ -- > emm :: EnumMapMap (Int :& Int :& K ID) Bool)+ -- > null $ splitKey x emm == False+ null :: EnumMapMap k v -> Bool+ -- | Number of elements in the 'EnumMapMap'.+ size :: EnumMapMap k v -> Int+ -- | Is the key present in the 'EnumMapMap'?+ member :: k -> EnumMapMap k v -> Bool+ -- | An 'EnumMapMap' with one element+ --+ -- > singleton (5 :& K 3) "a" == fromList [(5 :& K 3, "a")]+ singleton :: k -> v -> EnumMapMap k v+ -- | Lookup up the value at a key in the 'EnumMapMap'.+ --+ -- > emm = fromList [(3 :& K 1, "a")]+ -- > lookup (3 :& K 1) emm == Just "a"+ -- > lookup (2 :& K 1) emm == Nothing+ --+ lookup :: k -> EnumMapMap k v -> Maybe v+ -- | Insert a new Key\/Value pair into the 'EnumMapMap'.+ insert :: k -> v -> EnumMapMap k v -> EnumMapMap k v+ -- | Insert with a combining function.+ insertWith :: (v -> v -> v)+ -> k -> v -> EnumMapMap k v -> EnumMapMap k v+ insertWith f = insertWithKey (\_ -> f)+ -- | Insert with a combining function.+ insertWithKey :: (k -> v -> v -> v)+ -> k -> v -> EnumMapMap k v -> EnumMapMap k v+ -- | Remove a key and it's value from the 'EnumMapMap'. If the key is not+ -- present the original 'EnumMapMap' is returned.+ delete :: k -> EnumMapMap k v -> EnumMapMap k v+ -- | The expression (@'alter' f k emm@) alters the value at @k@, or absence thereof.+ -- 'alter' can be used to insert, delete, or update a value in an 'EnumMapMap'.+ 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 a function over all key\/value pairs in the 'EnumMapMap'.+ mapWithKey :: (k -> v -> t) -> EnumMapMap k v -> EnumMapMap k t+ -- | Fold the keys and values in the map 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.+ toList :: EnumMapMap k v -> [(k, v)]+ toList = foldrWithKey (\k x xs -> (k, x):xs) []+ -- | Create a 'EnumMapMap' from a list of key\/value pairs.+ fromList :: [(k, v)] -> EnumMapMap k v+ fromList = foldlStrict (\t (k, x) -> insert k x t) empty+ -- | The (left-biased) union of two 'EnumMapMap's.+ -- It prefers the first 'EnumMapMap' when duplicate keys are encountered.+ union :: EnumMapMap k v -> EnumMapMap k v -> EnumMapMap k v+ -- | The union of a list of maps.+ unions :: [EnumMapMap k v] -> EnumMapMap k v+ unions = foldlStrict union empty+ -- | The union with a combining function.+ unionWith :: (v -> v -> v)+ -> EnumMapMap k v -> EnumMapMap k v -> EnumMapMap k v+ unionWith f = unionWithKey (\_ -> f)+ -- | The union with a combining function.+ unionWithKey :: (k -> v -> v -> v)+ -> EnumMapMap k v -> EnumMapMap k v -> EnumMapMap k v+ -- | Difference between two 'EnumMapMap's (based on keys).+ difference :: EnumMapMap k v1 -> EnumMapMap k v2 -> EnumMapMap k v1+ -- | Difference with a combining function.+ differenceWith :: (v1 -> v2 -> Maybe v1)+ -> EnumMapMap k v1+ -> EnumMapMap k v2+ -> EnumMapMap k v1+ differenceWith f = differenceWithKey (\_ -> f)+ -- | Difference with a combining function.+ differenceWithKey :: (k -> v1 -> v2 -> Maybe v1)+ -> EnumMapMap k v1+ -> EnumMapMap k v2+ -> EnumMapMap k v1+ -- | The (left-biased) intersection of two 'EnumMapMap' (based on keys).+ intersection :: EnumMapMap k v1+ -> EnumMapMap k v2+ -> EnumMapMap k v1+ -- | The intersection with a combining function.+ intersectionWith :: (v1 -> v2 -> v3)+ -> EnumMapMap k v1+ -> EnumMapMap k v2+ -> EnumMapMap k v3+ intersectionWith f = intersectionWithKey (\_ -> f)+ -- | The intersection with a combining function.+ intersectionWithKey :: (k -> v1 -> v2 -> v3)+ -> EnumMapMap k v1+ -> EnumMapMap k v2+ -> EnumMapMap k v3++ equal :: Eq v => EnumMapMap k v -> EnumMapMap k v -> Bool+ nequal :: Eq v => EnumMapMap k v -> EnumMapMap k v -> Bool+++instance (Enum k, IsEmm t) => IsEmm (k :& t) where+ data EnumMapMap (k :& t) v = KCC (EMM k (EnumMapMap t v))++ emptySubTrees e@(KCC emm) =+ case emm of+ Nil -> False+ _ -> emptySubTrees_ e+ emptySubTrees_ (KCC emm) = go emm+ where+ go t = case t of+ Bin _ _ l r -> go l || go r+ Tip _ v -> emptySubTrees_ v+ Nil -> True++ removeEmpties (KCC emm) = KCC $ go emm+ where+ go t = case t of+ Bin p m l r -> bin p m (go l) (go r)+ Tip k v -> tip k (removeEmpties v)+ Nil -> Nil++ unsafeJoinKey (KCC emm) = KCC $ mapWithKey_ (\_ -> unsafeJoinKey) emm++ empty = KCC Nil++ null (KCC t) =+ case t of+ Nil -> True+ _ -> False++ size (KCC t) = go t+ where+ go (Bin _ _ l r) = go l + go r+ go (Tip _ y) = size y+ go Nil = 0++ member !(key' :& nxt) (KCC emm) = go emm+ where+ go t = case t of+ Bin _ m l r -> case zero key m of+ True -> go l+ False -> go r+ Tip kx x -> case key == kx of+ True -> member nxt x+ False -> False+ Nil -> False+ key = fromEnum key'++ singleton (key :& nxt) = KCC . Tip (fromEnum key) . singleton nxt++ lookup (key :& nxt) (KCC emm) = go emm+ where+ go (Bin _ m l r)+ | zero (fromEnum key) m = go l+ | otherwise = go r+ go (Tip kx x)+ = case kx == (fromEnum key) of+ True -> lookup nxt x+ False -> Nothing+ go Nil = Nothing++ insert (key :& nxt) val (KCC emm)+ = KCC $ insertWith_ (insert nxt val) key (singleton nxt val) emm++ insertWithKey f k@(key :& nxt) val (KCC emm) =+ KCC $ insertWith_ go key (singleton nxt val) emm+ where+ go = insertWithKey (\_ -> f k) nxt val++ delete !(key :& nxt) (KCC emm) =+ KCC $ alter_ (delete nxt) (fromEnum key) emm++ alter f !(key :& nxt) (KCC emm) =+ KCC $ alter_ (alter f nxt) (fromEnum key) emm++ mapWithKey f (KCC emm) = KCC $ mapWithKey_ go emm+ where+ go k = mapWithKey (\nxt -> f $ k :& nxt)++ foldrWithKey f init (KCC emm) = foldrWithKey_ go init emm+ where+ go k val z = foldrWithKey (\nxt -> f $ k :& nxt) z val++ union (KCC emm1) (KCC emm2) = KCC $ mergeWithKey' binD go id id emm1 emm2+ where+ go = \(Tip k1 x1) (Tip _ x2) -> tip k1 $ union x1 x2+ unionWithKey f (KCC emm1) (KCC emm2) =+ KCC $ mergeWithKey' binD go id id emm1 emm2+ where+ go = \(Tip k1 x1) (Tip _ x2) ->+ Tip k1 $ unionWithKey (g k1) x1 x2+ g k1 nxt = f $ (toEnum k1) :& nxt++ difference (KCC emm1) (KCC emm2) =+ KCC $ mergeWithKey' binD go id (const Nil) emm1 emm2+ where+ go = \(Tip k1 x1) (Tip _ x2) ->+ tip k1 (difference x1 x2)+ differenceWithKey f (KCC emm1) (KCC emm2) =+ KCC $ mergeWithKey' binD go id (const Nil) emm1 emm2+ where+ go = \(Tip k1 x1) (Tip _ x2) ->+ tip k1 $ differenceWithKey (\nxt ->+ f $ (toEnum k1) :& nxt) x1 x2++ intersection (KCC emm1) (KCC emm2) =+ KCC $ mergeWithKey' binD go (const Nil) (const Nil) emm1 emm2+ where+ go = \(Tip k1 x1) (Tip _ x2) ->+ tip k1 $ intersection x1 x2+ intersectionWithKey f (KCC emm1) (KCC emm2) =+ KCC $ mergeWithKey' binD go (const Nil) (const Nil) emm1 emm2+ where+ go = \(Tip k1 x1) (Tip _ x2) ->+ tip k1 $ intersectionWithKey (\nxt ->+ f $ (toEnum k1) :& nxt) x1 x2++ equal (KCC emm1) (KCC emm2) = emm1 == emm2+ nequal (KCC emm1) (KCC emm2) = emm1 /= emm2++{--------------------------------------------------------------------+ Helpers+--------------------------------------------------------------------}++insertWith_ :: Enum k => (v -> v) -> k -> v -> EMM k v -> EMM k v+insertWith_ f !key' val emm = key `seq` go emm+ where+ go t =+ case t of+ Bin p m l r+ | nomatch key p m -> join key (Tip key val) p t+ | zero key m -> Bin p m (go l) r+ | otherwise -> Bin p m l (go r)+ Tip ky y+ | key == ky -> Tip key (f y)+ | otherwise -> join key (Tip key val) ky t+ Nil -> Tip key val+ key = fromEnum key'+{-# INLINE insertWith_ #-}++-- | 'alter_' is used to walk down the tree to find the 'EnumMapMap' to actually+-- change. If the new 'EnumMapMap' is null then it's removed from the containing+-- 'EMM'.+alter_ :: (IsEmm b) =>+ (EnumMapMap b v -> EnumMapMap b v)+ -> Key+ -> EMM a (EnumMapMap b v)+ -> EMM a (EnumMapMap b v)+alter_ f k = go+ where+ go t =+ case t of+ Bin p m l r | nomatch k p m -> joinD k (tip k $ f empty) p t+ | zero k m -> binD p m (go l) r+ | otherwise -> binD p m l (go r)+ Tip ky y | k == ky -> tip k $ f y+ | otherwise -> joinD k (tip k $ f empty) ky t+ Nil -> tip k $ f empty+{-# INLINE alter_ #-}++mapWithKey_ :: Enum k => (k -> v -> t) -> EMM k v -> EMM k t+mapWithKey_ f = go+ where+ go (Bin p m l r) = Bin p m (go l) (go r)+ go (Tip k x) = Tip k (f (toEnum k) x)+ go Nil = Nil+{-# INLINE mapWithKey_ #-}++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+ | otherwise -> go (go z r) l+ _ -> go z emm+ where+ go z' Nil = z'+ go z' (Tip kx tx) = f (toEnum kx) tx z'+ go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldrWithKey_ #-}++-- | See 'IntMap' documentation for an explanation of 'mergeWithKey''.+mergeWithKey' :: (Enum a) =>+ (Prefix -> Mask -> EMM a v3 -> EMM a v3 -> EMM a v3)+ -> (EMM a v1 -> EMM a v2 -> EMM a v3)+ -> (EMM a v1 -> EMM a v3)+ -> (EMM a v2 -> EMM a v3)+ -> EMM a v1 -> EMM a v2 -> EMM a v3+mergeWithKey' bin' f g1 g2 = go+ where+ go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = merge1+ | shorter m2 m1 = merge2+ | p1 == p2 = bin' p1 m1 (go l1 l2) (go r1 r2)+ | otherwise = maybe_join p1 (g1 t1) p2 (g2 t2)+ where+ merge1 | nomatch p2 p1 m1 = maybe_join p1 (g1 t1) p2 (g2 t2)+ | zero p2 m1 = bin' p1 m1 (go l1 t2) (g1 r1)+ | otherwise = bin' p1 m1 (g1 l1) (go r1 t2)+ merge2 | nomatch p1 p2 m2 = maybe_join p1 (g1 t1) p2 (g2 t2)+ | zero p1 m2 = bin' p2 m2 (go t1 l2) (g2 r2)+ | otherwise = bin' p2 m2 (g2 l2) (go t1 r2)++ go t1'@(Bin _ _ _ _) t2'@(Tip k2' _) = merge t2' k2' t1'+ where merge t2 k2 t1@(Bin p1 m1 l1 r1)+ | nomatch k2 p1 m1 = maybe_join p1 (g1 t1) k2 (g2 t2)+ | zero k2 m1 = bin' p1 m1 (merge t2 k2 l1) (g1 r1)+ | otherwise = bin' p1 m1 (g1 l1) (merge t2 k2 r1)+ merge t2 k2 t1@(Tip k1 _)+ | k1 == k2 = f t1 t2+ | otherwise = maybe_join k1 (g1 t1) k2 (g2 t2)+ merge t2 _ Nil = g2 t2++ go t1@(Bin _ _ _ _) Nil = g1 t1++ go t1'@(Tip k1' _) t2' = merge t1' k1' t2'+ where merge t1 k1 t2@(Bin p2 m2 l2 r2)+ | nomatch k1 p2 m2 = maybe_join k1 (g1 t1) p2 (g2 t2)+ | zero k1 m2 = bin' p2 m2 (merge t1 k1 l2) (g2 r2)+ | otherwise = bin' p2 m2 (g2 l2) (merge t1 k1 r2)+ merge t1 k1 t2@(Tip k2 _)+ | k1 == k2 = f t1 t2+ | otherwise = maybe_join k1 (g1 t1) k2 (g2 t2)+ merge t1 _ Nil = g1 t1++ go Nil t2 = g2 t2++ maybe_join _ Nil _ t2 = t2+ maybe_join _ t1 _ Nil = t1+ maybe_join p1 t1 p2 t2 = join p1 t1 p2 t2+ {-# INLINE maybe_join #-}+{-# INLINE mergeWithKey' #-}+++{---------------------------------------------------------------------+ Instances+---------------------------------------------------------------------}++-- Eq++instance (Eq v, IsEmm k) => Eq (EnumMapMap k v) where+ t1 == t2 = equal t1 t2+ t1 /= t2 = nequal t1 t2++instance Eq v => Eq (EMM k v) where+ t1 == t2 = equalE t1 t2+ t1 /= t2 = nequalE t1 t2++equalE :: Eq v => EMM k v -> EMM k v -> Bool+equalE (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+ = (m1 == m2) && (p1 == p2) && (equalE l1 l2) && (equalE r1 r2)+equalE (Tip kx x) (Tip ky y)+ = (kx == ky) && (x==y)+equalE Nil Nil = True+equalE _ _ = False++nequalE :: Eq v => EMM k v -> EMM k v -> Bool+nequalE (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+ = (m1 /= m2) || (p1 /= p2) || (nequalE l1 l2) || (nequalE r1 r2)+nequalE (Tip kx x) (Tip ky y)+ = (kx /= ky) || (x/=y)+nequalE Nil Nil = False+nequalE _ _ = True++instance (IsEmm k) => Functor (EnumMapMap k)+ where+ fmap = map++instance (IsEmm k) => Monoid (EnumMapMap k v) where+ mempty = empty+ mappend = union+ mconcat = unions++instance (Show v, Show (EnumMapMap t v)) => Show (EnumMapMap (k :& t) v) where+ show (KCC emm) = show emm++instance (NFData v, NFData (EnumMapMap t v)) => NFData (EnumMapMap (k :& t) v)+ where+ rnf (KCC emm) = go emm+ where+ go Nil = ()+ go (Tip _ v) = rnf v+ go (Bin _ _ l r) = go l `seq` go r++{--------------------------------------------------------------------+ Nat conversion+--------------------------------------------------------------------}++natFromInt :: Int -> Nat+natFromInt = fromIntegral+{-# INLINE natFromInt #-}++intFromNat :: Nat -> Int+intFromNat = fromIntegral+{-# INLINE intFromNat #-}++shiftRL :: Nat -> Int -> Nat+shiftRL (W# x) (I# i)+ = W# (shiftRL# x i)++{--------------------------------------------------------------------+ Join+--------------------------------------------------------------------}+join :: Prefix -> EMM a v -> Prefix -> EMM a v -> EMM a v+join p1 t1 p2 t2+ | zero p1 m = Bin p m t1 t2+ | otherwise = Bin p m t2 t1+ where+ m = branchMask p1 p2+ p = mask p1 m+{-# INLINE join #-}++joinD :: (IsEmm b) =>+ Prefix -> EMM a (EnumMapMap b v)+ -> Prefix -> EMM a (EnumMapMap b v)+ -> EMM a (EnumMapMap b v)+joinD p1 t1 p2 t2+ | zero p1 m = binD p m t1 t2+ | otherwise = binD p m t2 t1+ where+ m = branchMask p1 p2+ p = mask p1 m+{-# INLINE joinD #-}++{--------------------------------------------------------------------+ @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}+bin :: Prefix -> Mask -> EMM k v -> EMM k v -> EMM k v+bin _ _ l Nil = l+bin _ _ Nil r = r+bin p m l r = Bin p m l r+{-# INLINE bin #-}++{--------------------------------------------------------------------+ @binD@ assures that we never have empty trees in the next level+--------------------------------------------------------------------}+binD :: (IsEmm b) =>+ Prefix -> Mask+ -> EMM a (EnumMapMap b v)+ -> EMM a (EnumMapMap b v)+ -> EMM a (EnumMapMap b v)+binD _ _ l Nil = l+binD _ _ Nil r = r+binD p m l r@(Tip _ y)+ | null y = l+ | otherwise = Bin p m l r+binD p m l@(Tip _ y) r+ | null y = r+ | otherwise = Bin p m l r+binD p m l r = Bin p m l r+{-# INLINE binD #-}++tip :: (IsEmm b) => Key -> EnumMapMap b v -> EMM a (EnumMapMap b v)+tip k val+ | null val = Nil+ | otherwise = Tip k val+{-# INLINE tip #-}++{--------------------------------------------------------------------+ Endian independent bit twiddling+--------------------------------------------------------------------}+zero :: Key -> Mask -> Bool+zero i m+ = (natFromInt i) .&. (natFromInt m) == 0+{-# INLINE zero #-}++nomatch,match :: Key -> Prefix -> Mask -> Bool+nomatch i p m+ = (mask i m) /= p+{-# INLINE nomatch #-}++match i p m+ = (mask i m) == p+{-# INLINE match #-}++mask :: Key -> Mask -> Prefix+mask i m+ = maskW (natFromInt i) (natFromInt m)+{-# INLINE mask #-}++{--------------------------------------------------------------------+ Big endian operations+--------------------------------------------------------------------}+maskW :: Nat -> Nat -> Prefix+maskW i m+ = intFromNat (i .&. (complement (m-1) `xor` m))+{-# INLINE maskW #-}++shorter :: Mask -> Mask -> Bool+shorter m1 m2+ = (natFromInt m1) > (natFromInt m2)+{-# INLINE shorter #-}++branchMask :: Prefix -> Prefix -> Mask+branchMask p1 p2+ = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))+{-# INLINE branchMask #-}++{----------------------------------------------------------------------+ [highestBitMask] returns a word where only the highest bit is set.+ It is found by first setting all bits in lower positions than the+ highest bit and than taking an exclusive or with the original value.+ Allthough the function may look expensive, GHC compiles this into+ excellent C code that subsequently compiled into highly efficient+ machine code. The algorithm is derived from Jorg Arndt's FXT library.+----------------------------------------------------------------------}+highestBitMask :: Nat -> Nat+highestBitMask x0+ = case (x0 .|. shiftRL x0 1) of+ x1 -> case (x1 .|. shiftRL x1 2) of+ x2 -> case (x2 .|. shiftRL x2 4) of+ 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))+{-# INLINE highestBitMask #-}++{--------------------------------------------------------------------+ Utilities+--------------------------------------------------------------------}++foldlStrict :: (a -> b -> a) -> a -> [b] -> a+foldlStrict f = go+ where+ go z [] = z+ go z (x:xs) = let z' = f z x in z' `seq` go z' xs+{-# INLINE foldlStrict #-}+
+ Data/EnumMapMap/Lazy.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE CPP, MagicHash, TypeFamilies, TypeOperators, BangPatterns,+ FlexibleInstances, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.EnumMapMap.Lazy+-- Copyright : (c) Daan Leijen 2002+-- (c) Andriy Palamarchuk 2008+-- (c) Matthew West 2012+-- License : BSD-style+-- Maintainer :+-- Stability : experimental+-- Portability : Uses GHC extensions+--+-----------------------------------------------------------------------------++module Data.EnumMapMap.Lazy (++ emptySubTrees,++ -- * Key types+ (:&)(..), K(..),+ d1, d2, d3, d4, d5, d6, d7, d8, d9, d10,+ -- * Map Type+ EnumMapMap,+ -- * Query+ size,+ null,+ member,+ lookup,+ -- * Construction+ empty,+ singleton,+ -- * Insertion+ insert,+ insertWith,+ insertWithKey,+ -- * Delete\/Update+ delete,+ alter,+ -- * Combine+ -- ** Union+ union,+ unionWith,+ unionWithKey,+ unions,+ -- ** Difference+ difference,+ differenceWith,+ differenceWithKey,+ -- ** Intersection+ intersection,+ intersectionWith,+ intersectionWithKey,+ -- * Map+ map,+ mapWithKey,+ -- * Folds+ foldrWithKey,+ -- * Lists+ toList,+ fromList,+ -- * Split/Join Keys+ splitKey,+ joinKey,+ unsafeJoinKey+) where++import Prelude hiding (lookup,map,filter,foldr,foldl,null,init)++import Control.DeepSeq (NFData(rnf))++import Data.EnumMapMap.Base++instance (Enum k) => IsEmm (K k) where+ data EnumMapMap (K k) v = KEC (EMM k v)++ emptySubTrees e@(KEC emm) =+ case emm of+ Nil -> False+ _ -> emptySubTrees_ e+ emptySubTrees_ (KEC emm) = go emm+ where+ go t = case t of+ Bin _ _ l r -> go l || go r+ Tip _ _ -> False+ Nil -> True++ removeEmpties = id++ unsafeJoinKey (KEC emm) = KCC emm++ empty = KEC Nil++ null (KEC t) = case t of+ Nil -> True+ _ -> False++ size (KEC t) = go t+ where+ go (Bin _ _ l r) = go l + go r+ go (Tip _ _) = 1+ go Nil = 0++ member !(K key') (KEC emm) = go emm+ where+ go t = case t of+ Bin _ m l r -> case zero key m of+ True -> go l+ False -> go r+ Tip kx _ -> key == kx+ Nil -> False+ key = fromEnum key'++ singleton !(K key) = KEC . Tip (fromEnum key)++ lookup !(K key') (KEC emm) = go emm+ where+ go (Bin _ m l r)+ | zero key m = go l+ | otherwise = go r+ go (Tip kx x)+ = case kx == key of+ True -> Just x+ False -> Nothing+ go Nil = Nothing+ key = fromEnum key'++ insert !(K key') val (KEC emm) = KEC $ go emm+ where+ go t = case t of+ Bin p m l r+ | nomatch key p m -> join key (Tip key val) p t+ | zero key m -> Bin p m (go l) r+ | otherwise -> Bin p m l (go r)+ Tip ky _+ | key == ky -> Tip key val+ | otherwise -> join key (Tip key val) ky t+ Nil -> Tip key val+ key = fromEnum key'++ insertWithKey f k@(K key') val (KEC emm) = KEC $ go emm+ where go t = case t of+ Bin p m l r+ | nomatch key p m -> join key (Tip key val) p t+ | zero key m -> Bin p m (go l) r+ | otherwise -> Bin p m l (go r)+ Tip ky y+ | key == ky -> Tip key (f k val y)+ | otherwise -> join key (Tip key val) ky t+ Nil -> Tip key val+ key = fromEnum key'++ delete !(K key') (KEC emm) = KEC $ go emm+ 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+ | otherwise -> bin p m l (go r)+ Tip ky _ | key == ky -> Nil+ | otherwise -> t+ Nil -> Nil+ key = fromEnum key'++ alter f !(K key') (KEC emm) = KEC $ go emm+ where+ go t = case t of+ Bin p m l r+ |nomatch key p m -> case f Nothing of+ Nothing -> t+ Just x -> join key (Tip key x) p t+ | zero key m -> bin p m (go l) r+ | otherwise -> bin p m l (go r)+ Tip ky y+ | key == ky -> case f (Just y) of+ Just x -> Tip ky x+ Nothing -> Nil+ | otherwise -> case f Nothing of+ Just x -> join key (Tip key x) ky t+ Nothing -> Tip ky y+ Nil -> case f Nothing of+ Just x -> Tip key x+ Nothing -> Nil+ where+ key = fromEnum key'++ mapWithKey f (KEC emm) = KEC $ mapWithKey_ (\k -> f $ K k) emm+ foldrWithKey f init (KEC emm) = foldrWithKey_ (\k -> f $ K k) init emm++ union (KEC emm1) (KEC emm2) = KEC $ mergeWithKey' Bin const id id emm1 emm2+ unionWithKey f (KEC emm1) (KEC emm2) =+ KEC $ mergeWithKey' Bin go id id emm1 emm2+ where+ go = \(Tip k1 x1) (Tip _ x2) ->+ Tip k1 $ f (K $ toEnum k1) x1 x2++ difference (KEC emm1) (KEC emm2) =+ KEC $ mergeWithKey' bin (\_ _ -> Nil) id (const Nil) emm1 emm2+ differenceWithKey f (KEC emm1) (KEC emm2) =+ KEC $ mergeWithKey' bin combine id (const Nil) emm1 emm2+ where+ combine = \(Tip k1 x1) (Tip _ x2)+ -> case f (K $ toEnum k1) x1 x2 of+ Nothing -> Nil+ Just x -> Tip k1 x++ intersection (KEC emm1) (KEC emm2) =+ KEC $ mergeWithKey' bin const (const Nil) (const Nil) emm1 emm2+ intersectionWithKey f (KEC emm1) (KEC emm2) =+ KEC $ mergeWithKey' bin go (const Nil) (const Nil) emm1 emm2+ where+ go = \(Tip k1 x1) (Tip _ x2) ->+ Tip k1 $ f (K $ toEnum k1) x1 x2++ equal (KEC emm1) (KEC emm2) = emm1 == emm2+ nequal (KEC emm1) (KEC emm2) = emm1 /= emm2++{---------------------------------------------------------------------+ Instances+---------------------------------------------------------------------}++instance (Show v) => Show (EnumMapMap (K k) v) where+ show (KEC emm) = show emm++instance NFData v => NFData (EnumMapMap (K k) v) where+ rnf (KEC emm) = go emm+ where+ go Nil = ()+ go (Tip _ v) = rnf v+ go (Bin _ _ l r) = go l `seq` go r++{---------------------------------------------------------------------+ Split/Join Keys+---------------------------------------------------------------------}++type instance Plus (K k1) k2 = k1 :& k2++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
+ Data/EnumMapMap/Strict.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE MagicHash, MultiParamTypeClasses, TypeFamilies, TypeOperators,+ BangPatterns, FlexibleInstances, FlexibleContexts, CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.EnumMapMap.Strict+-- Copyright : (c) Daan Leijen 2002+-- (c) Andriy Palamarchuk 2008+-- (c) Matthew West 2012+-- License : BSD-style+-- Maintainer :+-- Stability : experimental+-- Portability : Uses GHC extensions+--+-----------------------------------------------------------------------------++module Data.EnumMapMap.Strict (++ emptySubTrees,++ -- * Key types+ (:&)(..), K(..),+ d1, d2, d3, d4, d5, d6, d7, d8, d9, d10,+ -- * Map Type+ EnumMapMap,+ -- * Query+ size,+ null,+ member,+ lookup,+ -- * Construction+ empty,+ singleton,+ -- * Insertion+ insert,+ insertWith,+ insertWithKey,+ -- * Delete\/Update+ delete,+ alter,+ -- * Combine+ -- ** Union+ union,+ unionWith,+ unionWithKey,+ unions,+ -- ** Difference+ difference,+ differenceWith,+ differenceWithKey,+ -- ** Intersection+ intersection,+ intersectionWith,+ intersectionWithKey,+ -- * Traversal+ -- ** Map+ map,+ mapWithKey,+ -- * Folds+ foldrWithKey,+ -- * Lists+ toList,+ fromList,+ -- * Split/Join Keys+ splitKey,+ joinKey,+ unsafeJoinKey+) where++import Prelude hiding (lookup,map,filter,foldr,foldl,null, init)++import Control.DeepSeq (NFData(rnf))++import Data.EnumMapMap.Base++instance (Enum k) => IsEmm (K k) where+ data EnumMapMap (K k) v = KEC (EMM k v)++ emptySubTrees e@(KEC emm) =+ case emm of+ Nil -> False+ _ -> emptySubTrees_ e+ emptySubTrees_ (KEC emm) = go emm+ where+ go t = case t of+ Bin _ _ l r -> go l || go r+ Tip _ _ -> False+ Nil -> True++ removeEmpties = id++ unsafeJoinKey (KEC emm) = KCC emm++ empty = KEC Nil++ null (KEC t) = case t of+ Nil -> True+ _ -> False++ size (KEC t) = go t+ where+ go (Bin _ _ l r) = go l + go r+ go (Tip _ _) = 1+ go Nil = 0++ member !(K key') (KEC emm) = go emm+ where+ go t = case t of+ Bin _ m l r -> case zero key m of+ True -> go l+ False -> go r+ Tip kx _ -> key == kx+ Nil -> False+ key = fromEnum key'++ singleton !(K key) !val = KEC $ Tip (fromEnum key) val++ lookup !(K key') (KEC emm) = go emm+ where+ go (Bin _ m l r)+ | zero key m = go l+ | otherwise = go r+ go (Tip kx x)+ = case kx == key of+ True -> Just x+ False -> Nothing+ go Nil = Nothing+ key = fromEnum key'++ insert !(K key') !val (KEC emm) = KEC $ go emm+ where+ go t = case t of+ Bin p m l r+ | nomatch key p m -> join key (Tip key val) p t+ | zero key m -> Bin p m (go l) r+ | otherwise -> Bin p m l (go r)+ Tip ky _+ | key == ky -> Tip key val+ | otherwise -> join key (Tip key val) ky t+ Nil -> Tip key val+ key = fromEnum key'++ insertWithKey f k@(K key') !val (KEC emm) = KEC $ go emm+ where go t = case t of+ Bin p m l r+ | nomatch key p m -> join key (Tip key val) p t+ | zero key m -> Bin p m (go l) r+ | otherwise -> Bin p m l (go r)+ Tip ky y+ | key == ky -> Tip key $! (f k val y)+ | otherwise -> join key (Tip key val) ky t+ Nil -> Tip key val+ key = fromEnum key'++ delete !(K key') (KEC emm) = KEC $ go emm+ 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+ | otherwise -> bin p m l (go r)+ Tip ky _ | key == ky -> Nil+ | otherwise -> t+ Nil -> Nil+ key = fromEnum key'++ alter f !(K key') (KEC emm) = KEC $ go emm+ where+ go t = case t of+ Bin p m l r+ | nomatch key p m -> case f Nothing of+ Nothing -> t+ Just !x -> join key (Tip key x) p t+ | zero key m -> bin p m (go l) r+ | otherwise -> bin p m l (go r)+ Tip ky y+ | key == ky -> case f (Just y) of+ Just !x -> Tip ky x+ Nothing -> Nil+ | otherwise -> case f Nothing of+ Just !x -> join key (Tip key x) ky t+ Nothing -> Tip ky y+ Nil -> case f Nothing of+ Just !x -> Tip key x+ Nothing -> Nil+ where+ key = fromEnum key'++ mapWithKey f (KEC emm) = KEC $ mapWithKey_ (\k -> id $! f $! K k) emm+ foldrWithKey f init (KEC emm) = foldrWithKey_ (\k -> f $! K k) init emm++ union (KEC emm1) (KEC emm2) = KEC $ mergeWithKey' Bin const id id emm1 emm2+ unionWithKey f (KEC emm1) (KEC emm2) =+ KEC $ mergeWithKey' Bin go id id emm1 emm2+ where+ go = \(Tip k1 x1) (Tip _ x2) ->+ Tip k1 $! f (K $ toEnum k1) x1 x2++ difference (KEC emm1) (KEC emm2) =+ KEC $ mergeWithKey' bin (\_ _ -> Nil) id (const Nil) emm1 emm2+ differenceWithKey f (KEC emm1) (KEC emm2) =+ KEC $ mergeWithKey' bin combine id (const Nil) emm1 emm2+ where+ combine = \(Tip k1 x1) (Tip _ x2)+ -> case f (K $ toEnum k1) x1 x2 of+ Nothing -> Nil+ Just x -> x `seq` Tip k1 x++ intersection (KEC emm1) (KEC emm2) =+ KEC $ mergeWithKey' bin const (const Nil) (const Nil) emm1 emm2+ intersectionWithKey f (KEC emm1) (KEC emm2) =+ KEC $ mergeWithKey' bin go (const Nil) (const Nil) emm1 emm2+ where+ go = \(Tip k1 x1) (Tip _ x2) ->+ Tip k1 $! f (K $ toEnum k1) x1 x2++ equal (KEC emm1) (KEC emm2) = emm1 == emm2+ nequal (KEC emm1) (KEC emm2) = emm1 /= emm2++{---------------------------------------------------------------------+ Instances+---------------------------------------------------------------------}++instance (Show v) => Show (EnumMapMap (K k) v) where+ show (KEC emm) = show emm++instance NFData v => NFData (EnumMapMap (K k) v) where+ rnf (KEC emm) = go emm+ where+ go Nil = ()+ go (Tip _ v) = rnf v+ go (Bin _ _ l r) = go l `seq` go r++{---------------------------------------------------------------------+ Split/Join Keys+---------------------------------------------------------------------}++type instance Plus (K k1) k2 = k1 :& k2++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
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) Daan Leijen 2002+ (c) Andriy Palamarchuk 2008+ (c) Matthew West 2012+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of the authors nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ enummapmap.cabal view
@@ -0,0 +1,83 @@+name: enummapmap+version: 0.0.2+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 containers 5.0.+license: BSD3+license-file: LICENSE+author: Matthew West and authors of containers v5.0+maintainer: Matthew West+category: Data+build-type: Simple++cabal-version: >=1.10++source-repository head+ type: git+ location: http://github.com/bovinespirit/enummapmap.git++Library+ exposed-modules: Data.EnumMapMap.Lazy, Data.EnumMapMap.Strict+ other-modules: Data.EnumMapMap.Base+ build-depends: base >= 4.0 && < 5,+ deepseq >= 1.2 && < 1.4+ ghc-options: -Wall -O2+ default-language: Haskell2010++Test-Suite test-enummapmap-lazy+ type: exitcode-stdio-1.0+ main-is: UnitEnumMapMap.hs+ hs-source-dirs: test+ ghc-options: -Wall -O2+ default-language: Haskell2010+ build-depends: base >= 4.0 && < 5,+ HUnit,+ QuickCheck >= 2,+ hspec >= 0.9,+ deepseq >= 1.2 && < 1.4,+ enummapmap+ cpp-options: -DTESTING -DLAZY++Test-Suite test-enummapmap-intmap-lazy+ type: exitcode-stdio-1.0+ main-is: EnumMapMapVsIntMap.hs+ hs-source-dirs: test+ ghc-options: -Wall -O2+ default-language: Haskell2010+ build-depends: base >= 4.0 && < 5,+ HUnit,+ QuickCheck >= 2,+ hspec >= 0.9,+ deepseq >= 1.2 && < 1.4,+ containers >= 0.4.2,+ enummapmap+ cpp-options: -DTESTING -DLAZY++Test-Suite test-enummapmap-strict+ type: exitcode-stdio-1.0+ main-is: UnitEnumMapMap.hs+ hs-source-dirs: test+ ghc-options: -Wall -O2+ default-language: Haskell2010+ build-depends: base >= 4.0 && < 5,+ HUnit,+ QuickCheck >= 2,+ hspec >= 0.9,+ deepseq >= 1.2 && < 1.4,+ enummapmap+ cpp-options: -DTESTING -DSTRICT++Test-Suite test-enummapmap-intmap-strict+ type: exitcode-stdio-1.0+ main-is: EnumMapMapVsIntMap.hs+ hs-source-dirs: test+ ghc-options: -Wall -O2+ default-language: Haskell2010+ build-depends: base >= 4.0 && < 5,+ HUnit,+ QuickCheck >= 2,+ hspec >= 0.9,+ deepseq >= 1.2 && < 1.4,+ containers >= 0.4.2,+ enummapmap+ cpp-options: -DTESTING -DSTRICT
+ test/EnumMapMapVsIntMap.hs view
@@ -0,0 +1,411 @@+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | This uses QuickCheck to try to check that an 'EnumMapMap'+-- behaves in the same way as an 'IntMap'. It checks up to 4 levels of+-- 'EnumMapMap' one by one for each function. It does not check that empty+-- EnumMapMaps are removed.++import Test.Hspec.Monadic+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck ()++#ifdef LAZY+import qualified Data.IntMap as IM++import Data.EnumMapMap.Lazy(EnumMapMap, (:&)(..), K(..))+import qualified Data.EnumMapMap.Lazy as EMM+#else+import qualified Data.IntMap as IM++import Data.EnumMapMap.Strict(EnumMapMap, (:&)(..), K(..))+import qualified Data.EnumMapMap.Strict as EMM+#endif++type TestMap = EnumMapMap (K Int) Int+type TestMap2 = EnumMapMap (Int :& K Int) Int+type TestMap3 = EnumMapMap (Int :& Int :& K Int) Int+type TestMap4 = EnumMapMap (Int :& Int :& Int :& K Int) Int++list2l1 :: [(Int, Int)] -> [(K Int, Int)]+list2l1 = map (\(a, b) -> (K a, b))++list2l2 :: Int -> [(Int, Int)] -> [(Int :& K Int, Int)]+list2l2 k1 = map (\(a, b) -> (a :& K k1, b))++list2l3 :: Int -> Int -> [(Int, Int)] -> [(Int :& Int :& K Int, Int)]+list2l3 k1 k2 = map (\(a, b) -> (a :& k1 :& K k2, b))++list2l4 :: Int -> Int -> Int -> [(Int, Int)] -> [(Int :& Int :& Int :& K Int, Int)]+list2l4 k1 k2 k3 = map (\(a, b) -> (a :& k1 :& k2 :& K k3, b))++-- | Run functions on an 'IntMap' and an 'EnumMapMap' created from list and check+-- that the results are equal+runProp :: Eq t =>+ (IM.IntMap Int -> t)+ -> (TestMap -> t)+ -> [(Int, Int)]+ -> Bool+runProp f g list =+ (f $ IM.fromList list) == (g $ EMM.fromList $ list2l1 list)++runPropDuo :: Eq t =>+ (IM.IntMap Int -> IM.IntMap Int -> t)+ -> (TestMap -> TestMap -> t)+ -> [(Int, Int)]+ -> [(Int, Int)]+ -> Bool+runPropDuo f g list1 list2 =+ (f (IM.fromList list1) $ IM.fromList list2)+ == (g (EMM.fromList $ list2l1 list1) $ EMM.fromList $ list2l1 list2)++runProp2 :: Eq t =>+ (IM.IntMap Int -> t)+ -> (TestMap2 -> t)+ -> Int+ -> [(Int, Int)]+ -> Bool+runProp2 f g k1 list =+ (f $ IM.fromList list) == (g $ EMM.fromList $ list2l2 k1 list)++runPropDuo2 :: Eq t =>+ (IM.IntMap Int -> IM.IntMap Int -> t)+ -> (TestMap2 -> TestMap2 -> t)+ -> Int+ -> [(Int, Int)]+ -> [(Int, Int)]+ -> Bool+runPropDuo2 f g k1 list1 list2 =+ (f (IM.fromList list1) $ IM.fromList list2)+ == (g (EMM.fromList $ list2l2 k1 list1) $+ EMM.fromList $ list2l2 k1 list2)++runProp3 :: Eq t =>+ (IM.IntMap Int -> t)+ -> (TestMap3 -> t)+ -> Int+ -> Int+ -> [(Int, Int)]+ -> Bool+runProp3 f g k1 k2 list =+ (f $ IM.fromList list) == (g $ EMM.fromList $ list2l3 k1 k2 list)++runPropDuo3 :: Eq t =>+ (IM.IntMap Int -> IM.IntMap Int -> t)+ -> (TestMap3 -> TestMap3 -> t)+ -> Int+ -> Int+ -> [(Int, Int)]+ -> [(Int, Int)]+ -> Bool+runPropDuo3 f g k1 k2 list1 list2 =+ (f (IM.fromList list1) $ IM.fromList list2)+ == (g (EMM.fromList $ list2l3 k1 k2 list1) $+ EMM.fromList $ list2l3 k1 k2 list2)++runProp4 :: Eq t =>+ (IM.IntMap Int -> t)+ -> (TestMap4 -> t)+ -> Int+ -> Int+ -> Int+ -> [(Int, Int)]+ -> Bool+runProp4 f g k1 k2 k3 list =+ (f $ IM.fromList list) == (g $ EMM.fromList $ list2l4 k1 k2 k3 list)++runPropDuo4 :: Eq t =>+ (IM.IntMap Int -> IM.IntMap Int -> t)+ -> (TestMap4 -> TestMap4 -> t)+ -> Int+ -> Int+ -> Int+ -> [(Int, Int)]+ -> [(Int, Int)]+ -> Bool+runPropDuo4 f g k1 k2 k3 list1 list2 =+ (f (IM.fromList list1) $ IM.fromList list2)+ == (g (EMM.fromList $ list2l4 k1 k2 k3 list1) $+ EMM.fromList $ list2l4 k1 k2 k3 list2)++-- | Run functions on an 'IntMap' and an 'EnumMapMap' created from 'list' and check+-- that the resulting 'IntMap' and 'EnumMapMap' are equal+runPropL :: (IM.IntMap Int -> IM.IntMap Int)+ -> (TestMap -> TestMap)+ -> [(Int, Int)]+ -> Bool+runPropL f g =+ runProp (list2l1 . IM.toList . f) (EMM.toList . g)++runPropDuoL :: (IM.IntMap Int -> IM.IntMap Int -> IM.IntMap Int)+ -> (TestMap -> TestMap -> TestMap)+ -> [(Int, Int)]+ -> [(Int, Int)]+ -> Bool+runPropDuoL f g =+ runPropDuo (\a b -> list2l1 $ IM.toList $ f a b)+ (\a b -> EMM.toList $ g a b)++runPropL2 :: (IM.IntMap Int -> IM.IntMap Int)+ -> (TestMap2 -> TestMap2)+ -> Int+ -> [(Int, Int)]+ -> Bool+runPropL2 f g k1 =+ runProp2 (list2l2 k1 . IM.toList . f) (EMM.toList . g) k1++runPropDuoL2 :: (IM.IntMap Int -> IM.IntMap Int -> IM.IntMap Int)+ -> (TestMap2 -> TestMap2 -> TestMap2)+ -> Int+ -> [(Int, Int)]+ -> [(Int, Int)]+ -> Bool+runPropDuoL2 f g k1 =+ runPropDuo2 (\a b -> list2l2 k1 $ IM.toList $ f a b)+ (\a b -> EMM.toList $ g a b) k1++runPropL3 :: (IM.IntMap Int -> IM.IntMap Int)+ -> (TestMap3 -> TestMap3)+ -> Int+ -> Int+ -> [(Int, Int)]+ -> Bool+runPropL3 f g k1 k2 =+ runProp3 (list2l3 k1 k2 . IM.toList . f) (EMM.toList . g) k1 k2++runPropDuoL3 :: (IM.IntMap Int -> IM.IntMap Int -> IM.IntMap Int)+ -> (TestMap3 -> TestMap3 -> TestMap3)+ -> Int+ -> Int+ -> [(Int, Int)]+ -> [(Int, Int)]+ -> Bool+runPropDuoL3 f g k1 k2 =+ runPropDuo3 (\a b -> list2l3 k1 k2 $ IM.toList $ f a b)+ (\a b -> EMM.toList $ g a b) k1 k2++runPropL4 :: (IM.IntMap Int -> IM.IntMap Int)+ -> (TestMap4 -> TestMap4)+ -> Int+ -> Int+ -> Int+ -> [(Int, Int)]+ -> Bool+runPropL4 f g k1 k2 k3 =+ runProp4 (list2l4 k1 k2 k3 . IM.toList . f) (EMM.toList . g) k1 k2 k3++runPropDuoL4 :: (IM.IntMap Int -> IM.IntMap Int -> IM.IntMap Int)+ -> (TestMap4 -> TestMap4 -> TestMap4)+ -> Int+ -> Int+ -> Int+ -> [(Int, Int)]+ -> [(Int, Int)]+ -> Bool+runPropDuoL4 f g k1 k2 k3 =+ runPropDuo4 (\a b -> list2l4 k1 k2 k3 $ IM.toList $ f a b)+ (\a b -> EMM.toList $ g a b) k1 k2 k3++main :: IO ()+main = hspecX $ do+ describe "toList fromList" $ do+ prop "Level 1" $+ runPropL id id+ prop "Level 2" $+ runPropL2 id id+ prop "Level 3" $+ runPropL3 id id+ prop "Level 4" $+ runPropL4 id id++ describe "lookup" $ do+ prop "Level 1" $ \i ->+ runProp (IM.lookup i) (EMM.lookup $ K i)+ prop "Level 2" $ \i k1 ->+ runProp2 (IM.lookup i) (EMM.lookup $ i :& K k1) k1+ prop "Level 3" $ \i k1 k2 ->+ runProp3 (IM.lookup i) (EMM.lookup $ i :& k1 :& K k2) k1 k2+ prop "Level 4" $ \i k1 k2 k3 ->+ runProp4 (IM.lookup i) (EMM.lookup $ i :& k1 :& k2 :& K k3) k1 k2 k3++ describe "member" $ do+ prop "Level 1" $ \i ->+ runProp (IM.member i) (EMM.member $ K i)+ prop "Level 2" $ \i k1 ->+ runProp2 (IM.member i) (EMM.member $ i :& K k1) k1+ prop "Level 3" $ \i k1 k2 ->+ runProp3 (IM.member i) (EMM.member $ i :& k1 :& K k2) k1 k2+ prop "Level 4" $ \i k1 k2 k3 ->+ runProp4 (IM.member i) (EMM.member $ i :& k1 :& k2 :& K k3) k1 k2 k3++ describe "insert" $ do+ prop "Level 1" $ \i j ->+ runPropL (IM.insert i j) (EMM.insert (K i) j)+ prop "Level 2" $ \i j k1 ->+ runPropL2 (IM.insert i j) (EMM.insert (i :& K k1) j) k1+ prop "Level 3" $ \i j k1 k2 ->+ runPropL3 (IM.insert i j) (EMM.insert (i :& k1 :& K k2) j) k1 k2+ prop "Level 4" $ \i j k1 k2 k3 ->+ runPropL4 (IM.insert i j)+ (EMM.insert (i :& k1 :& k2 :& K k3) j) k1 k2 k3++ describe "insertWith" $ do+ prop "Level 1" $ \i j ->+ runPropL (IM.insertWith (+) i j) $+ (EMM.insertWith (+) (K i) j)+ prop "Level 2" $ \i j k1 ->+ runPropL2 (IM.insertWith (+) i j)+ (EMM.insertWith (+) (i :& K k1) j) k1+ prop "Level 3" $ \i j k1 k2 ->+ runPropL3 (IM.insertWith (+) i j)+ (EMM.insertWith (+) (i :& k1:& K k2) j) k1 k2+ prop "Level 4" $ \i j k1 k2 k3 ->+ runPropL4 (IM.insertWith (+) i j)+ (EMM.insertWith (+) (i :& k1 :& k2 :& K k3) j) k1 k2 k3++ describe "insertWithKey" $ do+ let f a b c = a + b + c+ prop "Level 1" $ \i j ->+ runPropL (IM.insertWithKey f i j) $+ (EMM.insertWithKey+ (\(K k) -> f k)+ (K i) j)+ prop "Level 2" $ \i j k1 ->+ runPropL2 (IM.insertWithKey f i j)+ (EMM.insertWithKey+ (\(k :& K _) -> f k)+ (i :& K k1) j) k1+ prop "Level 3" $ \i j k1 k2 ->+ runPropL3 (IM.insertWithKey f i j)+ (EMM.insertWithKey+ (\(k :& _ :& K _) -> f k)+ (i :& k1 :& K k2) j) k1 k2+ prop "Level 4" $ \i j k1 k2 k3 ->+ runPropL4 (IM.insertWithKey f i j)+ (EMM.insertWithKey+ (\(k :& _ :& _ :& K _) -> f k)+ (i :& k1 :& k2 :& K k3) j) k1 k2 k3++ describe "delete" $ do+ prop "Level 1" $ \i ->+ runPropL (IM.delete i) (EMM.delete (K i))+ prop "Level 2" $ \i k1 ->+ runPropL2 (IM.delete i) (EMM.delete (i :& K k1)) k1+ prop "Level 3" $ \i k1 k2 ->+ runPropL3 (IM.delete i) (EMM.delete (i :& k1 :& K k2)) k1 k2+ prop "Level 4" $ \i k1 k2 k3 ->+ runPropL4 (IM.delete i)+ (EMM.delete (i :& k1 :& k2 :& K k3)) k1 k2 k3++ describe "alter" $ do+ let f b n v = case v of+ Just v' -> case b of+ True -> Just v'+ False -> Nothing+ Nothing -> case b of+ True -> Just n+ False -> Nothing+ prop "Level 1" $ \i b n ->+ runPropL (IM.alter (f b n) i) $+ EMM.alter (f b n) (K i)+ prop "Level 2" $ \i b n k1 ->+ runPropL2 (IM.alter (f b n) i)+ (EMM.alter (f b n) (i :& K k1)) k1+ prop "Level 3" $ \i b n k1 k2 ->+ runPropL3 (IM.alter (f b n) i)+ (EMM.alter (f b n) (i :& k1 :& K k2)) k1 k2++ describe "foldrWithKey" $ do+ let f a b c = [a + b] ++ c+ prop "Level 1" $+ runProp (IM.foldrWithKey f []) (EMM.foldrWithKey+ (\(K k) -> f k) [])+ prop "Level 2" $+ runProp2 (IM.foldrWithKey f []) (EMM.foldrWithKey+ (\(k :& K _) -> f k) [])+ prop "Level 3" $+ runProp3 (IM.foldrWithKey f []) (EMM.foldrWithKey+ (\(k :& _ :& K _) -> f k) [])+ prop "Level 3" $+ runProp4 (IM.foldrWithKey f []) (EMM.foldrWithKey+ (\(k :& _ :& _ :& K _) -> f k) [])++ describe "map" $ do+ let f a = a + 1+ prop "Level 1" $+ runPropL (IM.map f) (EMM.map f)+ prop "Level 2" $+ runPropL2 (IM.map f) (EMM.map f)+ prop "Level 3" $+ runPropL3 (IM.map f) (EMM.map f)+ prop "Level 4" $+ runPropL4 (IM.map f) (EMM.map f)++ describe "mapWithKey" $ do+ let f k a = k + a+ prop "Level 1" $+ runPropL (IM.mapWithKey f) (EMM.mapWithKey+ (\(K k) -> f k))+ prop "Level 2" $+ runPropL2 (IM.mapWithKey f) (EMM.mapWithKey+ (\(k :& K _) -> f k))+ prop "Level 3" $+ runPropL3 (IM.mapWithKey f) (EMM.mapWithKey+ (\(k :& _ :& K _) -> f k))+ prop "Level 4" $+ runPropL4 (IM.mapWithKey f) (EMM.mapWithKey+ (\(k :& _ :& _ :& K _) -> f k))++ describe "union" $ do+ prop "Level 1" $+ runPropDuoL IM.union EMM.union+ prop "Level 2" $+ runPropDuoL2 IM.union EMM.union+ prop "Level 3" $+ runPropDuoL3 IM.union EMM.union+ prop "Level 4" $+ runPropDuoL4 IM.union EMM.union++ describe "unionWith" $ do+ prop "Level 1" $+ runPropDuoL (IM.unionWith (+)) (EMM.unionWith (+))+ prop "Level 2" $+ runPropDuoL2 (IM.unionWith (+)) (EMM.unionWith (+))+ prop "Level 3" $+ runPropDuoL3 (IM.unionWith (+)) (EMM.unionWith (+))+ prop "Level 4" $+ runPropDuoL4 (IM.unionWith (+)) (EMM.unionWith (+))++ describe "unionWithKey" $ do+ let f a b c = (a + b) * c+ prop "Level 1" $+ runPropDuoL (IM.unionWithKey f) (EMM.unionWithKey+ (\(K k) -> f k))+ prop "Level 2" $+ runPropDuoL2 (IM.unionWithKey f) (EMM.unionWithKey+ (\(k :& K _) -> f k))+ prop "Level 3" $+ runPropDuoL3 (IM.unionWithKey f) (EMM.unionWithKey+ (\(k :& _ :& K _) -> f k))+ prop "Level 4" $+ runPropDuoL4 (IM.unionWithKey f) (EMM.unionWithKey+ (\(k :& _ :& _ :& K _) -> f k))++ describe "intersectionWithKey" $ do+ let f a b c = (a + b) * c+ prop "Level 1" $+ runPropDuoL (IM.intersectionWithKey f)+ (EMM.intersectionWithKey+ (\(K k) a b -> f k a b))+ prop "Level 2" $+ runPropDuoL2 (IM.intersectionWithKey f)+ (EMM.intersectionWithKey+ (\(k :& K _) a b -> f k a b))+ prop "Level 3" $+ runPropDuoL3 (IM.intersectionWithKey f)+ (EMM.intersectionWithKey+ (\(k :& _ :& K _) a b -> f k a b))+ prop "Level 4" $+ runPropDuoL4 (IM.intersectionWithKey f)+ (EMM.intersectionWithKey+ (\(k :& _ :& _ :& K _) a b -> f k a b))
+ test/UnitEnumMapMap.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++import Control.Monad (liftM, liftM2)+import Test.Hspec.HUnit ()+import Test.Hspec.Monadic+import Test.Hspec.QuickCheck (prop)+import Test.HUnit+import Test.QuickCheck (Arbitrary, arbitrary, shrink)++#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++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 a) => Arbitrary (K a) where+ arbitrary = liftM K arbitrary++newtype ID1 = ID1 Int+ deriving (Show, Enum, Arbitrary)+newtype ID2 = ID2 Int+ deriving (Show, Enum, Arbitrary)+newtype ID3 = ID3 Int+ deriving (Show, Enum, Arbitrary)++type TestKey3 = ID3 :& ID2 :& K ID1+type TestEmm3 = EnumMapMap TestKey3 Int++tens :: [Int]+tens = [1, 10, 100, 1000, 10000, 100000, 1000000]++odds :: [Int]+odds = [1, 3..1000]++fewOdds :: [Int]+fewOdds = [1, 3..6]++evens :: [Int]+evens = [2, 4..1000]++alls :: [Int]+alls = [1, 2..1000]++l1tens :: EnumMapMap (K Int) Int+l1tens = EMM.fromList $ map (\(k, v) -> (K k, v)) $ zip [1..7] tens+l2tens :: EnumMapMap (Int :& K Int) Int+l2tens = EMM.fromList $ zip (do+ k1 <- [1, 2]+ k2 <- [1..7]+ return $ k1 :& K k2) $ cycle tens++l1odds :: EnumMapMap (K Int) Int+l1odds = EMM.fromList $ map (\(k, v) -> (K k, v)) $ zip odds odds+l2odds :: EnumMapMap (Int :& K Int) Int+l2odds = EMM.fromList $ zip (do+ k1 <- fewOdds+ k2 <- fewOdds+ return $ k1 :& K k2) $ cycle odds+l1evens :: EnumMapMap (K Int) Int+l1evens = EMM.fromList $ map (\(k, v) -> (K k, v)) $ zip evens evens++l1alls :: EnumMapMap (K Int) Int+l1alls = EMM.fromList $ zip (map K alls) alls++checkSubs :: (TestEmm3 -> TestEmm3 -> TestEmm3)+ -> [(TestKey3, Int)]+ -> [(TestKey3, Int)]+ -> Bool+checkSubs f l1 l2 =+ False == (EMM.emptySubTrees $ f emm1 emm2)+ where+ emm1 = EMM.fromList l1+ emm2 = EMM.fromList l2++main :: IO ()+main =+ hspecX $ do+ describe "empty" $ do+ it "creates an empty EnumMapMap" $+ (EMM.null $ (EMM.empty :: EnumMapMap (Int :& Int :& K Int) Bool))+ it "has a size of 0" $+ 0 @=? (EMM.size $ (EMM.empty :: EnumMapMap (Int :& K Int) Bool))++ describe "fromList" $ do+ it "is the inverse of toList on 1 level" $+ (EMM.fromList $ EMM.toList l1odds) @?= l1odds+ it "is the inverse of toList on 2 levels" $+ (EMM.fromList $ EMM.toList l2odds) @?= l2odds++ describe "insert" $ do+ describe "Level 1" $ do+ it "creates a value in an empty EMM" $+ EMM.insert (K 1) 1 EMM.empty @?=+ (EMM.fromList [(K 1, 1)]+ :: EnumMapMap (K Int) Int)+ it "adds another value to an EMM" $+ let+ emm :: EnumMapMap (K Int) Int+ emm = EMM.fromList [(K 2, 2)] in+ EMM.insert (K 1) 1 emm @?=+ EMM.fromList [(K 1, 1), (K 2, 2)]+ it "overwrites a value with the same key in an EMM" $+ let emm :: EnumMapMap (K Int) Int+ emm = EMM.fromList [(K 1, 1), (K 2, 2)] in+ EMM.insert (K 1) 3 emm @?=+ EMM.fromList [(K 1, 3), (K 2, 2)]++ describe "Level 2" $ do+ it "creates a value in an empty EMM" $+ EMM.insert (1 :& K 1) 1 EMM.empty @?=+ (EMM.fromList [(1 :& K 1, 1)]+ :: EnumMapMap (Int :& K Int) Int)+ it "adds another value to an EMM on level 1" $+ let+ emm :: EnumMapMap (Int :& K Int) Int+ emm = EMM.fromList [(1 :& K 2, 2)]+ in+ EMM.insert (1 :& K 1) 1 emm @?=+ EMM.fromList [(1 :& K 1, 1), (1 :& K 2, 2)]+ it "adds another value to an EMM on level 2" $+ let+ emm :: EnumMapMap (Int :& K Int) Int+ emm = EMM.fromList [(1 :& K 1, 1)]+ in+ EMM.insert (2 :& K 2) 2 emm @?=+ EMM.fromList [(1 :& K 1, 1), (2 :& K 2, 2)]++ describe "insertWithKey" $ do+ let undef = undefined -- fail if this is called+ describe "Level 1" $ do+ it "creates a value in an empty EMM" $+ EMM.insertWithKey undef (K 1) 1 EMM.empty @?=+ (EMM.fromList [(K 1, 1)]+ :: EnumMapMap (K Int) Int)+ it "adds another value to an EMM" $+ let+ emm :: EnumMapMap (K Int) Int+ emm = EMM.fromList [(K 2, 2)] in+ EMM.insertWithKey undef (K 1) 1 emm @?=+ EMM.fromList [(K 1, 1), (K 2, 2)]+ it "applies the function when overwriting" $+ let emm :: EnumMapMap (K Int) Int+ emm = EMM.fromList [(K 1, 1), (K 2, 4)]+ f (K key1) o n = key1 * (o + n)+ in+ EMM.insertWithKey f (K 2) 3 emm @?=+ EMM.fromList [(K 1, 1), (K 2, 14)]++ describe "Level 2" $ do+ it "creates a value in an empty EMM" $+ EMM.insertWithKey undef (1 :& K 1) 1 EMM.empty @?=+ (EMM.fromList [(1 :& K 1, 1)]+ :: EnumMapMap (Int :& K Int) Int)+ it "adds another value to an EMM on level 1" $+ let+ emm :: EnumMapMap (Int :& K Int) Int+ emm = EMM.fromList [(1 :& K 2, 2)]+ in+ EMM.insertWithKey undef (1 :& K 1) 1 emm @?=+ EMM.fromList [(1 :& K 1, 1), (1 :& K 2, 2)]+ it "adds another value to an EMM on level 2" $+ let+ emm :: EnumMapMap (Int :& K Int) Int+ emm = EMM.fromList [(1 :& K 1, 1)]+ in+ EMM.insertWithKey undef (2 :& K 2) 2 emm @?=+ EMM.fromList [(1 :& K 1, 1), (2 :& K 2, 2)]+ it "applies the function when overwriting" $+ let emm :: EnumMapMap (Int :& K Int) Int+ emm = EMM.fromList [(2 :& K 3, 1), (2 :& K 4, 5)]+ f (k1 :& K k2) o n = (k1 + k2) * (o + n)+ in+ EMM.insertWithKey f (2 :& K 4) 3 emm @?=+ EMM.fromList [(2 :& K 3, 1), (2 :& K 4, 48)]++ describe "delete" $ do+ prop "leaves no empty subtrees" $ \k l ->+ not $ EMM.emptySubTrees $ EMM.delete k $ (EMM.fromList l :: TestEmm3)++ describe "alter" $ do+ let f b1 b2 n v = case v of+ Nothing -> if b1 then Just n else Nothing+ Just v' -> case b1 of+ True -> Just $ if b2 then v' else n+ False -> Nothing+ prop "leaves no empty subtrees" $ \k l b1 b2 n ->+ not $ EMM.emptySubTrees $ EMM.alter (f b1 b2 n) k $+ (EMM.fromList l :: TestEmm3)++ describe "foldrWithKey" $ do+ describe "Level 1" $ do+ it "folds across all values in an EnumMapMap" $+ EMM.foldrWithKey (\_ -> (+)) 0 l1tens @?= 1111111+ it "folds across all keys in an EnumMapMap" $+ EMM.foldrWithKey (\(K k1) _ -> (+) k1) 0 l1tens @?= 28+ describe "Level 2" $ do+ it "folds across all values in an EnumMapMap" $+ EMM.foldrWithKey (\_ -> (+)) 0 l2tens @?= 2222222+ it "folds across all keys in an EnumMapMap" $+ EMM.foldrWithKey+ (\(k1 :& K k2) _ -> (+) (k1 * k2)) 0 l2tens @?= 84++ 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+ prop "Leaves no empty subtrees" $ checkSubs EMM.difference++ 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+ prop "Leaves no empty subtrees" $ checkSubs EMM.intersection++ 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+ let go21 :: [(Int :& K Int, Int)] -> Bool+ go21 l = emm == (EMM.joinKey $ EMM.splitKey EMM.d1 emm)+ where emm = EMM.fromList l+ prop "Level 2, depth = 1" go21++ let go31 :: [(Int :& Int :& K Int, Int)] -> Bool+ go31 l = emm == (EMM.joinKey $ EMM.splitKey EMM.d1 emm)+ where emm = EMM.fromList l+ prop "Level 3, depth = 1" go31++ let go32 :: [(Int :& Int :& K Int, Int)] -> Bool+ go32 l = emm == (EMM.joinKey $ EMM.splitKey EMM.d2 emm)+ where emm = EMM.fromList l+ prop "Level 3, depth = 2" go32+