enummapmap 0.2.0 → 0.4.0

raw patch · 8 files changed

+446/−118 lines, 8 filesdep +criteriondep +mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: criterion, mtl

API changes (from Hackage documentation)

Files

• Data/EnumMapMap/Base.hs +102/−52
• Data/EnumMapMap/Lazy.hs +63/−11
• Data/EnumMapMap/Strict.hs +95/−43
• Data/EnumMapSet/Base.hs +22/−11
• bench/IntMapVsEnumMapMap.hs +87/−0
• enummapmap.cabal +14/−1
• test/EnumMapMapVsIntMap.hs +43/−0
• test/UnitEnumMapMap.hs +20/−0

@@ -34,6 +34,7 @@             EnumMapMap(..),             -- ** SKey             HasSKey(..),+            SubKeyS(..),             -- ** EMM internals             mergeWithKey',             mapWithKey_,@@ -45,6 +46,7 @@             Nat,             Key,             intFromNat,+            natFromInt,             shiftRL,             shiftLL,             branchMask,@@ -153,13 +155,24 @@ type instance Plus (k1 :& t) k2 = k1 :& Plus t k2  class SubKey k1 k2 v where-    -- k1 should be a prefix of k2.  If @k1 ~ k2@ then the 'Result' will be @v@.+    -- | k1 should be a prefix of k2.  If @k1 ~ k2@ then the 'Result' will be+    -- @v@.+    --+    -- > Result (K ID1) (ID1 :& K ID2) v        ~ EnumMapMap (K ID2) v+    -- > Result (ID1 :& K ID2) (ID1 :& K ID2) v ~ v+    -- > Result (ID1 :& K ID2) (K ID1) v        -- ERROR+    -- > Result (ID2 :& K ID1) (ID1 :& K ID2)   -- ERROR     type Result k1 k2 v :: *++    -- | Is the key present in the 'EnumMapMap'?+    member :: k1 -> EnumMapMap k2 v -> Bool+     -- | An 'EnumMapMap' with one element     --     -- > singleton (5 :& K 3) "a" == fromList [(5 :& K 3, "a")]     -- > singleton (K 5) $ singleton (K 2) "a" == fromList [(5 :& K 3, "a")]     singleton :: k1 -> Result k1 k2 v -> EnumMapMap k2 v+     -- | Lookup up the value at a key in the 'EnumMapMap'.     --     -- > emm = fromList [(3 :& K 1, "a")]@@ -174,51 +187,38 @@     --     lookup :: (IsKey k1, IsKey k2) =>               k1 -> EnumMapMap k2 v -> Maybe (Result k1 k2 v)+     -- | Insert a new key\/value pair into the 'EnumMapMap'.  Can also insert submaps.     insert :: (IsKey k1, IsKey k2) =>                k1 -> Result k1 k2 v -> EnumMapMap k2 v -> EnumMapMap k2 v+     -- | Insert with a combining function.  Can also insert submaps.     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)+     -- | Insert with a combining function.  Can also insert submaps.     insertWithKey :: (IsKey k1, IsKey k2) =>                      (k1 -> Result k1 k2 v -> Result k1 k2 v -> Result k1 k2 v)                   -> k1 -> Result k1 k2 v -> EnumMapMap k2 v -> EnumMapMap k2 v+     -- | Remove a key and it's value from the 'EnumMapMap'.  If the key is not     -- present the original 'EnumMapMap' is returned.     delete :: (IsKey k1, IsKey k2) =>               k1 -> EnumMapMap k2 v -> EnumMapMap k2 v -instance (Enum k, IsKey t1, IsKey t2, SubKey t1 t2 v) =>-    SubKey (k :& t1) (k :& t2) v where-    type Result (k :& t1) (k :& t2) v = Result t1 t2 v--    singleton (key :& nxt) = KCC . Tip (fromEnum key) . singleton nxt--    lookup !(key' :& nxt) (KCC emm) = key `seq` 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 -> lookup nxt x-                 False -> Nothing-          go Nil = Nothing-          key = fromEnum key'--    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+class SubKeyS k s where+    -- | The intersection of an 'EnumMapMap' and an 'EnumMapSet'.  If a key is+    -- present in the EnumMapSet then it will be present in the resulting+    -- 'EnumMapMap'.  Works with 'EnumMapSet's that are submaps of the+    -- 'EnumMapMap'.+    intersectSet :: (IsKey k, IsKey s) =>+                   EnumMapMap k v -> EnumMapMap s () -> EnumMapMap k v+    -- | The difference between an 'EnumMapMap' and an 'EnumMapSet'.  If a key+    -- is present in the 'EnumMapSet' it will not be present in the result.+    differenceSet :: (IsKey k, IsKey s) =>+                   EnumMapMap k v -> EnumMapMap s () -> EnumMapMap k v  class HasSKey k where     type Skey k :: *@@ -293,8 +293,6 @@     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     -- | 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@@ -322,9 +320,12 @@     -- | List of keys     keys :: EnumMapMap k v -> [k]     keys = foldrWithKey (\k _ ks -> k:ks) []-    -- | The 'Data.EnumMapSet' of the keys.  'EnumMapMap' keys can be converted into+    -- | The 'Data.EnumMapSet' of the keys. 'EnumMapMap' keys can be converted into     -- 'Data.EnumMapSet' keys using 'toS', and back again using 'toK'.     keysSet :: (HasSKey k) => EnumMapMap k v -> EnumMapMap (Skey k) ()+    -- | Build an 'EnumMapMap' from an 'EnumMapSet' and a function which for each+    -- key computes it's value+    fromSet :: HasSKey k => (k -> v) -> EnumMapMap (Skey k) () -> EnumMapMap k v     -- | 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@@ -370,6 +371,60 @@     equal ::  Eq v => EnumMapMap k v -> EnumMapMap k v -> Bool     nequal :: Eq v => EnumMapMap k v -> EnumMapMap k v -> Bool +instance (Enum k, IsKey t1, IsKey t2, SubKey t1 t2 v) =>+    SubKey (k :& t1) (k :& t2) v where+    type Result (k :& t1) (k :& t2) v = Result t1 t2 v++    member !(key' :& nxt) (KCC emm) = key `seq` 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) = key `seq` 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 -> lookup nxt x+                 False -> Nothing+          go Nil = Nothing+          key = fromEnum key'++    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++instance (Enum k, IsKey t1, IsKey t2, SubKeyS t1 t2) =>+    SubKeyS (k :& t1) (k :& t2) where+        intersectSet (KCC emm) (KCC ems) =+            KCC $ mergeWithKey' binD go (const Nil) (const Nil) emm ems+                where+                  go = \(Tip k1 x1) (Tip _ x2) ->+                       tip k1 $ intersectSet x1 x2+        differenceSet (KCC emm) (KCC ems) =+            KCC $  mergeWithKey' binD go id (const Nil) emm ems+                where+                  go = \(Tip k1 x1) (Tip _ x2) ->+                       tip k1 $ differenceSet x1 x2+ instance (Eq k, Enum k, IsKey t, HasSKey t) => IsKey (k :& t) where     data EnumMapMap (k :& t) v = KCC (EMM k (EnumMapMap t v)) @@ -406,33 +461,25 @@           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'-     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)+          go k = mapWithKey (\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+          go k val z = foldrWithKey (\nxt -> f $! k :& nxt) z val      keysSet (KCC emm) = KCC $ mapWithKey_ (\_ -> keysSet) emm +    fromSet f (KCC ems) = KCC $ mapWithKey_ go ems+        where+          go k = fromSet (\nxt -> f $! k :& nxt)+     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@@ -441,7 +488,7 @@             where               go = \(Tip k1 x1) (Tip _ x2) ->                    Tip k1 $ unionWithKey (g k1) x1 x2-              g k1 nxt = f $ toEnum k1 :& nxt+              g k1 nxt = f $! toEnum k1 :& nxt      difference (KCC emm1) (KCC emm2) =         KCC $ mergeWithKey' binD go id (const Nil) emm1 emm2@@ -453,7 +500,7 @@             where               go = \(Tip k1 x1) (Tip _ x2) ->                    tip k1 $ differenceWithKey (\nxt ->-                                              f $ toEnum k1 :& nxt) x1 x2+                                              f $! toEnum k1 :& nxt) x1 x2      intersection (KCC emm1) (KCC emm2) =         KCC $ mergeWithKey' binD go (const Nil) (const Nil) emm1 emm2@@ -465,7 +512,7 @@             where               go = \(Tip k1 x1) (Tip _ x2) ->                    tip k1 $ intersectionWithKey (\nxt ->-                                                f $ toEnum k1 :& nxt) x1 x2+                                                f $! toEnum k1 :& nxt) x1 x2      equal (KCC emm1) (KCC emm2) = emm1 == emm2     nequal (KCC emm1) (KCC emm2) = emm1 /= emm2@@ -530,8 +577,7 @@ {-# INLINE foldrWithKey_ #-}  -- | See 'IntMap' documentation for an explanation of 'mergeWithKey''.-mergeWithKey' :: (Enum a) =>-                 (Prefix -> Mask -> EMM a v3 -> EMM a v3 -> EMM a v3)+mergeWithKey' :: (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)@@ -557,7 +603,7 @@                 | 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+                | k1 == k2  = f t1 t2                 | otherwise = maybe_join k1 (g1 t1) k2 (g2 t2)             merge t2 _  Nil = g2 t2 @@ -631,6 +677,10 @@             go Nil           = ()             go (Tip _ v)     = rnf v             go (Bin _ _ l r) = go l `seq` go r++instance (NFData k, NFData t) => NFData (k :& t)+    where+      rnf (k :& t) = rnf k `seq` rnf t  {--------------------------------------------------------------------   Nat conversion

@@ -63,22 +63,25 @@             difference,             differenceWith,             differenceWithKey,+            differenceSet,             -- ** Intersection             intersection,             intersectionWith,             intersectionWithKey,+            intersectSet,             -- * Map             map,             mapWithKey,             -- * Folds             foldr,             foldrWithKey,-            -- * Lists+            -- * Lists and sets             toList,             fromList,             keys,             elems,             keysSet,+            fromSet,             -- * Split/Join Keys             toK,             toS,@@ -133,16 +136,6 @@           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'-     alter f !(K key') (KEC emm) = KEC $ go emm         where           go t = case t of@@ -175,6 +168,7 @@           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+     keysSet (KEC emm) = EMS.KSC $ go emm         where           go Nil        = EMS.Nil@@ -188,6 +182,7 @@                 computeBm !acc (Tip kx _)      = acc .|. EMS.bitmapOf kx                 computeBm !acc Nil             = acc +    fromSet f (EMS.KSC emm) = KEC $ fromSet_ (f . K . toEnum) 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@@ -230,6 +225,10 @@           go (Tip _ v)     = rnf v           go (Bin _ _ l r) = go l `seq` go r +instance (NFData k) => NFData (K k)+    where+      rnf (K k) = rnf k+ instance HasSKey (K k) where     type Skey (K k) = EMS.S k     toS (K !k) = EMS.S k@@ -248,6 +247,7 @@  instance (Enum k1, k1 ~ k2) => SubKey (K k1) (k2 :& t2) v where     type Result (K k1) (k2 :& t2) v = EnumMapMap t2 v+    member (K key) (KCC emm) = member_ (fromEnum key) emm     singleton !(K key) = KCC . Tip (fromEnum key)     lookup !(K key') (KCC emm) = lookup_ (fromEnum key') emm     insert !(K key') val (KCC emm) = KCC $ insert_ (fromEnum key') val emm@@ -257,6 +257,7 @@  instance (Enum k) => SubKey (K k) (K k) v where     type Result (K k) (K k) v = v+    member (K key) (KEC emm) = member_ (fromEnum key) emm     singleton !(K key) = KEC . Tip (fromEnum key)     lookup (K key') (KEC emm) = lookup_ (fromEnum key') emm     insert !(K key') val (KEC emm) = KEC $ insert_ (fromEnum key') val emm@@ -264,6 +265,24 @@         KEC $ insertWK (f k) (fromEnum key') val emm     delete !(K key') (KEC emm) = KEC $ delete_ (fromEnum key') emm +instance (Enum k1, k1 ~ k2) => SubKeyS (k1 :& t) (EMS.S k2) where+    intersectSet (KCC emm) (EMS.KSC ems) = KCC $ intersectSet_ emm ems+    differenceSet (KCC emm) (EMS.KSC ems) = KCC $ differenceSet_ emm ems++instance (Enum k) => SubKeyS (K k) (EMS.S k) where+    intersectSet (KEC emm) (EMS.KSC ems) = KEC $ intersectSet_ emm ems+    differenceSet (KEC emm) (EMS.KSC ems) = KEC $ differenceSet_ emm ems++member_ :: Key -> EMM k v -> Bool+member_ key 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+ lookup_ :: Key -> EMM k v -> Maybe v lookup_ !key emm =     case emm of@@ -310,3 +329,36 @@       Tip ky _    | key == ky       -> Nil                   | otherwise       -> emm       Nil                           -> Nil++fromSet_ :: (Key -> v) -> EMS.EMS k -> EMM k v+fromSet_ f = go+    where+      go EMS.Nil           = Nil+      go (EMS.Bin p m l r) = Bin p m (go l) (go r)+      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+                   bits2 | bmask .&. ((1 `shiftLL` bits2) -1) == 0 ->+                             buildTree g (prefix + bits2)+                                           (bmask `shiftRL` bits2) bits2+                         | (bmask `shiftRL` bits2) .&.+                           ((1 `shiftLL` bits2) - 1) == 0 ->+                               buildTree g prefix bmask bits2+                         | otherwise ->+                             Bin prefix bits2+                                     (buildTree g prefix bmask bits2)+                                     (buildTree g (prefix + bits2)+                                      (bmask `shiftRL` bits2)+                                      bits2)++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++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

@@ -63,10 +63,12 @@             difference,             differenceWith,             differenceWithKey,+            differenceSet,             -- ** Intersection             intersection,             intersectionWith,             intersectionWithKey,+            intersectSet,             -- * Traversal             -- ** Map             map,@@ -74,12 +76,13 @@             -- * Folds             foldr,             foldrWithKey,-            -- * Lists+            -- * Lists and Sets             toList,             fromList,             keys,             elems,             keysSet,+            fromSet,             -- * Split/Join Keys             toK,             toS,@@ -134,16 +137,6 @@           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'-     alter f !(K key') (KEC emm) = KEC $ go emm         where           go t = case t of@@ -188,7 +181,7 @@                 computeBm !acc (Bin _ _ l' r') = computeBm (computeBm acc l') r'                 computeBm !acc (Tip kx _)      = acc .|. EMS.bitmapOf kx                 computeBm !acc Nil             = acc-+    fromSet f (EMS.KSC emm) = KEC $ fromSet_ (f . K . toEnum) 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@@ -197,7 +190,9 @@                    Tip k1 $! f (K $ toEnum k1) x1 x2      difference (KEC emm1) (KEC emm2) =-        KEC $ mergeWithKey' bin (\_ _ -> Nil) id (const Nil) emm1 emm2+        KEC $ go emm1 emm2+            where go = mergeWithKey' bin (\_ _ -> Nil) id (const Nil)+    {-# INLINE difference #-}     differenceWithKey f (KEC emm1) (KEC emm2) =         KEC $ mergeWithKey' bin combine id (const Nil) emm1 emm2             where@@ -231,6 +226,10 @@           go (Tip _ v)     = rnf v           go (Bin _ _ l r) = go l `seq` go r +instance (NFData k) => NFData (K k)+    where+      rnf (K k) = rnf k+ instance HasSKey (K k) where     type Skey (K k) = EMS.S k     toS (K !k) = EMS.S k@@ -249,15 +248,16 @@  instance (Enum k1, k1 ~ k2) => SubKey (K k1) (k2 :& t2) v where     type Result (K k1) (k2 :& t2) v = EnumMapMap t2 v-    singleton !(K key) = KCC . Tip (fromEnum key)+    member (K key) (KCC emm) = member_ (fromEnum key) emm+    singleton (K key) = KCC . Tip (fromEnum key)     lookup (K key') (KCC emm) = lookup_ (fromEnum key') emm-    insert !(K key') val (KCC emm) = KCC $ insert_ (fromEnum key') val emm+    insert (K key') val (KCC emm) = KCC $ insert_ (fromEnum key') val emm     insertWithKey f !k@(K key') val (KCC emm) =         KCC $ insertWK (f k) (fromEnum key') val emm     delete !(K key') (KCC emm) = KCC $ delete_ (fromEnum key') emm- instance (Enum k) => SubKey (K k) (K k) v where     type Result (K k) (K k) v = v+    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@@ -265,28 +265,45 @@         KEC $ insertWK (f k) (fromEnum key') val emm     delete !(K key') (KEC emm) = KEC $ delete_ (fromEnum key') emm +instance (Enum k1, k1 ~ k2) => SubKeyS (k1 :& t) (EMS.S k2) where+    intersectSet (KCC emm) (EMS.KSC ems) = KCC $ intersectSet_ emm ems+    differenceSet (KCC emm) (EMS.KSC ems) = KCC $ differenceSet_ emm ems++instance (Enum k) => SubKeyS (K k) (EMS.S k) where+    intersectSet (KEC emm) (EMS.KSC ems) = KEC $ intersectSet_ emm ems+    differenceSet (KEC emm) (EMS.KSC ems) = KEC $ differenceSet_ emm ems++member_ :: Key -> EMM k v -> Bool+member_ key 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+ lookup_ :: Key -> EMM k v -> Maybe v-lookup_ !key emm =-    case emm of-      Bin _ m l r-          | zero key m -> lookup_ key l-          | otherwise  -> lookup_ key r-      Tip kx x         -> if kx == key then Just x else Nothing-      Nil              -> Nothing+lookup_ !key emm = go emm+    where+      go t = case t of+               Bin _ m l r+                   | zero key m -> go l+                   | otherwise  -> go r+               Tip kx x         -> if kx == key then Just x else Nothing+               Nil              -> Nothing  insert_ :: Key -> v -> EMM k v -> EMM k v-insert_ !key val = go-    where-      go emm =-          case emm of-            Bin p m l r-                | nomatch key p m -> join key (Tip key val) p emm-                | 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 emm-            Nil                   -> Tip key val+insert_ !key !val emm =+    case emm of+      Bin p m l r+          | nomatch key p m -> join key (Tip key val) p emm+          | zero key m      -> Bin p m (insert_ key val l) r+          | otherwise       -> Bin p m l (insert_ key val r)+      Tip ky _+          | key == ky       -> Tip key val+          | otherwise       -> join key (Tip key val) ky emm+      Nil                   -> Tip key val  insertWK :: (v -> v -> v) -> Key -> v -> EMM k v -> EMM k v insertWK f !key val = go@@ -303,11 +320,46 @@             Nil                   -> Tip key val  delete_ :: Key -> EMM k v -> EMM k v-delete_ !key emm =-    case emm of-      Bin p m l r | nomatch key p m -> emm-                  | zero key m      -> bin p m (delete_ key l) r-                  | otherwise       -> bin p m l (delete_ key r)-      Tip ky _    | key == ky       -> Nil-                  | otherwise       -> emm-      Nil                           -> Nil+delete_ !key emm = 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++fromSet_ :: (Key -> v) -> EMS.EMS k -> EMM k v+fromSet_ f = go+    where+      go EMS.Nil           = Nil+      go (EMS.Bin p m l r) = Bin p m (go l) (go r)+      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+                   bits2 | bmask .&. ((1 `shiftLL` bits2) -1) == 0 ->+                             buildTree g (prefix + bits2)+                                           (bmask `shiftRL` bits2) bits2+                         | (bmask `shiftRL` bits2) .&.+                           ((1 `shiftLL` bits2) - 1) == 0 ->+                               buildTree g prefix bmask bits2+                         | otherwise ->+                             Bin prefix bits2+                                     (buildTree g prefix bmask bits2)+                                     (buildTree g (prefix + bits2)+                                      (bmask `shiftRL` bits2)+                                      bits2)++{-# INLINE fromSet_ #-}++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++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

@@ -127,16 +127,6 @@           go (Tip _ bm)    = bitcount 0 bm           go Nil           = 0 -    member !(S key') (KSC ems) = key `seq` go ems-        where-          go (Bin p m l r)-              | nomatch key p m = False-              | zero key m      = go l-              | otherwise       = go r-          go (Tip y bm) = prefixOf key == y && bitmapOf key .&. bm /= 0-          go Nil = False-          key = fromEnum key'-     foldrWithKey f init (KSC ems)         = case ems of Bin _ m l r | m < 0 -> go (go init l) r                                   | otherwise -> go (go init r) l@@ -271,6 +261,7 @@     toList = undefined     elems = undefined     keysSet = undefined+    fromSet = undefined  {---------------------------------------------------------------------   Exported API@@ -286,7 +277,8 @@ size :: (IsKey k) => EnumMapSet k -> Int size = EMM.size -member ::(IsKey k) => k -> EnumMapSet k -> Bool+member ::(EMM.SubKey k1 k2 (), IsKey k1, IsKey k2) =>+         k1 -> EnumMapSet k2 -> Bool member = EMM.member  -- | Lookup a subtree in an 'EnumMapSet'.@@ -368,6 +360,16 @@ instance (Enum k1, k1 ~ k2) => EMM.SubKey (S k1) (k2 :& t2) () where     type Result (S k1) (k2 :& t2) () = EnumMapSet t2 +    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.Tip kx _    -> key == kx+               EMM.Nil         -> False+          key = fromEnum key'+     singleton !(S key) = EMM.KCC . EMM.Tip (fromEnum key)      lookup (S key') (EMM.KCC emm) = key `seq` go emm@@ -412,6 +414,15 @@  instance (Enum k) => EMM.SubKey (S k) (S k) () where     type Result (S k) (S k) () = ()+    member !(S key') (KSC ems) = key `seq` go ems+        where+          go (Bin p m l r)+              | nomatch key p m = False+              | zero key m      = go l+              | otherwise       = go r+          go (Tip y bm) = prefixOf key == y && bitmapOf key .&. bm /= 0+          go Nil = False+          key = fromEnum key'     singleton !(S key') _ = KSC $! Tip (prefixOf key) (bitmapOf key)           where key = fromEnum key'     lookup = undefined

@@ -0,0 +1,87 @@+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, TypeOperators #-}++--  | This compares the speed of 'Data.IntMap' functions with the speed of+--  'Data.EnumMapMap.Strict' functions.++import           Control.DeepSeq+import           Control.Exception (evaluate)+import           Control.Monad.Trans (liftIO)+import           Criterion.Config+import           Criterion.Main+import           Data.List (foldl')+import           Data.Maybe (fromMaybe)++import           Data.IntMap (IntMap)+import qualified Data.IntMap as IM+import           Data.EnumMapMap.Strict(EnumMapMap, (:&)(..), K(..))+import qualified Data.EnumMapMap.Strict as EMM++newtype ID = ID Int+    deriving (Eq, Enum, Show, Num)++main :: IO()+main = do+    let im :: IntMap Int+        im = IM.fromAscList elemsIm+        imAr :: [IntMap Int]+        imAr = map IM.fromAscList elemsArIm+        emm :: EnumMapMap (K ID) Int+        emm = EMM.fromList elemsEmm+        emmAr :: [EnumMapMap (K ID) Int]+        emmAr = map EMM.fromList elemsArEmm+    defaultMainWith+        defaultConfig+        (liftIO . evaluate $ rnf $ im :& emm :& imAr :& emmAr)+        [ bench "lookup IM" $ whnf (lookupIm keysIm) im+        , bench "lookup EMM" $ whnf (lookupEmm keysEmm) emm+        , bench "insert IM" $ whnf (insIm elemsIm) IM.empty+        , bench "insert EMM" $ whnf (insEmm elemsEmm) EMM.empty+        , bench "delete IM" $ whnf (delIm keysIm) im+        , bench "delete EMM" $ whnf (delEmm keysEmm) emm+        , bench "union IM" $ nf (dual IM.union im) imAr+        , bench "union EMM" $ nf (dual EMM.union emm) emmAr+        , bench "difference IM" $ nf (dual IM.difference im) imAr+        , bench "difference EMM" $ nf (dual EMM.difference emm) emmAr+        , bench "intersection IM" $ nf (dual IM.intersection im) imAr+        , bench "intersection EMM" $ nf (dual EMM.intersection emm) emmAr+        ]+    where+      elemsIm = zip keysIm values+      elemsEmm = zip keysEmm values+      elemsArIm = map (\ks -> zip ks values) keysArIm+      elemsArEmm = map (\ks -> zip ks values) keysArEmm+      keysIm :: [Int]+      keysIm = [1..2^12]+      keysArIm :: [[Int]]+      keysArIm = do+         i <- [1..2^5]+         return $ do+                   j <- [1..(2^8)]+                   return $ j * i+      keysEmm :: [K ID]+      keysEmm = map (K . ID) keysIm+      keysArEmm :: [[K ID]]+      keysArEmm = map (map (K . ID)) keysArIm+      values :: [Int]+      values = [1..2^12]++lookupIm :: [Int] -> IntMap Int -> Int+lookupIm xs im = foldl' (\n k -> fromMaybe n (IM.lookup k im)) 0 xs++lookupEmm :: [K ID] -> EnumMapMap (K ID) Int -> Int+lookupEmm xs emm = foldl' (\n k -> fromMaybe n (EMM.lookup k emm)) 0 xs++insIm :: [(Int, Int)] -> IntMap Int -> IntMap Int+insIm xs m = foldl' (\m (k, v) -> v `seq` IM.insert k v m) m xs++insEmm :: [(K ID, Int)] -> EnumMapMap (K ID) Int -> EnumMapMap (K ID) Int+insEmm xs m = foldl' (\m (k, v) -> EMM.insert k v m) m xs++delIm :: [Int] -> IntMap Int -> IntMap Int+delIm xs m = foldl' (\m k -> IM.delete k m) m xs++delEmm :: [K ID] -> EnumMapMap (K ID) Int -> EnumMapMap (K ID) Int+delEmm xs m = foldl' (\m k -> EMM.delete k m) m xs++dual :: (a -> a -> a) -> a -> [a] -> [a]+dual f i = map $! f i

@@ -1,5 +1,5 @@ name:               enummapmap-version:            0.2.0+version:            0.4.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@@ -99,3 +99,16 @@                       containers >= 0.4.2,                       enummapmap     cpp-options:      -DTESTING++benchmark enummapmap-vs-intmap-bench+    type:             exitcode-stdio-1.0+    hs-source-dirs:   bench+    main-is:          IntMapVsEnumMapMap.hs+    build-depends:    base >= 4.0 && < 5,+                      criterion,+                      deepseq >= 1.2 && < 1.4,+                      containers >= 0.4.2,+                      mtl,+                      enummapmap+    default-language: Haskell2010+    ghc-options:      -O2

@@ -10,6 +10,9 @@ import           Test.Hspec.QuickCheck (prop) import           Test.QuickCheck () +import qualified Data.IntSet as IS+import           Data.EnumMapSet (S(..))+import qualified Data.EnumMapSet as EMS #ifdef LAZY import qualified Data.IntMap as IM @@ -26,6 +29,10 @@ type TestMap2 = EnumMapMap (Int :& K Int)               Int type TestMap3 = EnumMapMap (Int :& Int :& K Int)        Int type TestMap4 = EnumMapMap (Int :& Int :& Int :& K Int) Int+-- type TestSet  = EnumMapSet (S Int)+-- type TestSet2 = EnumMapSet (Int :& S Int)+-- type TestSet3 = EnumMapSet (Int :& Int :& S Int)+-- type TestSet4 = EnumMapSet (Int :& Int :& Int :& S Int)  list2l1 :: [(Int, Int)] -> [(K Int, Int)] list2l1 = map (\(a, b) -> (K a, b))@@ -39,6 +46,18 @@ 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)) +set2l1 :: [Int] -> [S Int]+set2l1 = map S++set2l2 :: Int -> [Int] -> [Int :& S Int]+set2l2 s1 = map (\s -> s :& S s1)++set2l3 :: Int -> Int -> [Int] -> [Int :& Int :& S Int]+set2l3 s1 s2 = map (\s -> s :& s1 :& S s2)++set2l4 :: Int -> Int -> Int -> [Int] -> [Int :& Int :& Int :& S Int]+set2l4 s1 s2 s3 = map (\s -> s :& s1 :& s2 :& S s3)+ -- | Run functions on an 'IntMap' and an 'EnumMapMap' created from list and check -- that the results are equal runProp :: Eq t =>@@ -206,6 +225,16 @@     runPropDuo4 (\a b -> list2l4 k1 k2 k3 $ IM.toList $ f a b)                     (\a b -> EMM.toList $ g a b) k1 k2 k3 +-- 'fromSet' is not in containers 4.*+-- runSetProp :: Eq t =>+--               (IS.IntSet -> IM.IntMap Int)+--            -> (TestSet -> TestMap)+--            -> [Int]+--            -> Bool+-- runSetProp f g list =+--     (set2l1 $ IM.toList $ f $ IS.fromList list)+--     == (EMM.toList $ g $ EMS.fromList $ set2l1 list)+ main :: IO () main = hspec $ do     describe "toList fromList" $ do@@ -437,3 +466,17 @@              runProp3 (IM.elems) (EMM.elems)         prop "Level 4" $              runProp4 (IM.elems) (EMM.elems)++    describe "keysSet" $ do+        prop "Level 1" $+             runProp (set2l1 . IS.toList . IM.keysSet)+                         (EMS.toList . EMM.keysSet)+        prop "Level 2" $ \ s1 ->+             runProp2 (set2l2 s1 . IS.toList . IM.keysSet)+                         (EMS.toList . EMM.keysSet) s1+        prop "Level 3" $ \ s1 s2 ->+             runProp3 (set2l3 s1 s2 . IS.toList . IM.keysSet)+                         (EMS.toList . EMM.keysSet) s1 s2+        prop "Level 4" $ \ s1 s2 s3 ->+             runProp4 (set2l4 s1 s2 s3 . IS.toList . IM.keysSet)+                         (EMS.toList . EMM.keysSet) s1 s2 s3

@@ -46,6 +46,9 @@ k :: Int -> K Int k = K +s :: Int -> EMS.S Int+s = EMS.S+ tens :: [Int] tens = [1, 10, 100, 1000, 10000, 100000, 1000000] @@ -71,6 +74,8 @@  l1odds :: EnumMapMap (K Int) Int l1odds = EMM.fromList $ map (\(key, v) -> (K key, v)) $ zip odds odds+l1fewOdds :: EnumMapMap (K Int) Int+l1fewOdds = EMM.fromList $ map (\(key, v) -> (K key, v)) $ zip fewOdds fewOdds l2odds :: EnumMapMap (Int :& K Int) Int l2odds = EMM.fromList $ zip (do                               k1 <- fewOdds@@ -313,4 +318,19 @@                     emm = EMM.fromList list           prop "Level 1" gol1 +      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)]+        it "leaves correct subtree" $+           (EMM.intersectSet l2odds $ EMS.fromList [s 1])+           @?= EMM.fromList [(1 :& k 1, 1), (1 :& k 3, 3), (1 :& k 5, 5)]+        -- TODO: check for empty subtrees +      describe "differenceSet" $ do+        it "works correctly" $+           (EMM.differenceSet l1fewOdds $ EMS.fromList [s 3, s 4, s 5])+           @?= EMM.fromList [(k 1, 1)]+        it "leaves correct subtree" $+           (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)]