enummapmap 0.1.0 → 0.2.0

raw patch · 9 files changed

+1120/−691 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/EnumMapMap/Base.hs +152/−102
• Data/EnumMapMap/Lazy.hs +115/−54
• Data/EnumMapMap/Strict.hs +115/−54
• Data/EnumMapSet.hs +21/−416
• Data/EnumMapSet/Base.hs +565/−0
• enummapmap.cabal +2/−2
• test/EnumMapMapVsIntMap.hs +20/−0
• test/EnumMapSetVsIntSet.hs +19/−19
• test/UnitEnumMapMap.hs +111/−44

@@ -1,6 +1,6 @@ {-# LANGUAGE MagicHash, TypeFamilies, MultiParamTypeClasses,     BangPatterns, FlexibleInstances, TypeOperators,-    FlexibleContexts #-}+    FlexibleContexts, GeneralizedNewtypeDeriving #-}  ----------------------------------------------------------------------------- -- |@@ -9,29 +9,31 @@ --                (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+-- 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(..),+            (:&)(..), N(..), Z(..),             d1, d2, d3, d4, d5, d6, d7, d8, d9, d10,             -- * Split/Join Keys             IsSplit(..),             Plus,+            SubKey(..),             -- * Internal             -- ** IsEMM             EMM(..),-            IsEmm(..),+            IsKey(..),             EnumMapMap(..),+            -- ** SKey+            HasSKey(..),             -- ** EMM internals             mergeWithKey',             mapWithKey_,@@ -45,6 +47,8 @@             intFromNat,             shiftRL,             shiftLL,+            branchMask,+            mask,             bin,             tip,             shorter,@@ -79,22 +83,16 @@ type Mask   = Int  infixr 3 :&--- | Multiple keys are joined by the (':&') constructor and terminated with 'K'.+-- | Multiple keys are joined by the (':&') constructor. -- -- > 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+data N n = N !n  -- | Split after 1 key. --@@ -106,23 +104,23 @@ -- -- > emm :: EnumMapMap (T1 :& T2 :& K T3) v -- > splitKey d1 emm :: EnumMapMap (K T1) (EnumMapMap (T2 :& K T3) v)-d2 ::  N(Z)+d2 ::  N Z d2  =  N d1-d3 ::  N(N(Z))+d3 ::  N(N Z) d3  =  N d2-d4 ::  N(N(N(Z)))+d4 ::  N(N(N Z)) d4  =  N d3-d5 ::  N(N(N(N(Z))))+d5 ::  N(N(N(N Z))) d5  =  N d4-d6 ::  N(N(N(N(N(Z)))))+d6 ::  N(N(N(N(N Z)))) d6  =  N d5-d7 ::  N(N(N(N(N(N(Z))))))+d7 ::  N(N(N(N(N(N Z))))) d7  =  N d6-d8 ::  N(N(N(N(N(N(N(Z)))))))+d8 ::  N(N(N(N(N(N(N Z)))))) d8  =  N d7-d9 ::  N(N(N(N(N(N(N(N(Z))))))))+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(N(N(N(N(N(N(N(N Z)))))))) d10 =  N d9  class IsSplit k z where@@ -147,14 +145,101 @@              -> 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 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)+type instance Plus (k1 :& t) k2 = k1 :& Plus t k2 -class IsEmm k where+class SubKey k1 k2 v where+    -- k1 should be a prefix of k2.  If @k1 ~ k2@ then the 'Result' will be @v@.+    type Result k1 k2 v :: *+    -- | 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")]+    -- > lookup (3 :& K 1) emm == Just "a"+    -- > lookup (2 :& K 1) emm == Nothing+    --+    -- If the given key has less dimensions then the 'EnumMapMap' then a submap+    -- is returned.+    --+    -- > emm2 = fromList [(3 :& 2 :& K 1, "a"), (3 :& 2 :& K 4, "a")]+    -- > lookup (3 :& K 2) emm2 == Just $ fromList [(K 1, "a"), (K 4, "a")]+    --+    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 HasSKey k where+    type Skey k :: *+    -- | Convert a key terminated with 'K' into one terminated with 'S'.+    --+    -- > k = 1 :& 2 :& 'K' 3+    -- > toS k == 1 :& 2 :& 'S' 3+    --+    toS :: k -> Skey k+    -- | Convert a key terminated with 'S' into one terminated with 'K'.+    --+    -- > s = 1 :& 2 :& S 3+    -- > toK s == 1 :& 2 :& K 3+    toK :: Skey k -> k++instance (HasSKey t) => HasSKey (k :& t) where+    type Skey (k :& t) = k :& (Skey t)+    toS (k :& t) = (:&) k $! toS t+    toK (k :& t) = (:&) k $! toK t++class (Eq k) => IsKey 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.@@ -164,10 +249,11 @@     emptySubTrees  :: EnumMapMap k v -> Bool     emptySubTrees_ :: EnumMapMap k v -> Bool +    -- | Remove empty subtrees.     removeEmpties :: EnumMapMap k v -> EnumMapMap k v -    -- | Join a key so that an 'EnumMapMap' of-    -- 'EnumMapMap's becomes an 'EnumMapMap'.+    -- | 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)@@ -179,14 +265,14 @@     -- > emm = empty :: EnumMapMap (Int :& Int :& K ID) Bool)     -- > emm == joinKey $ splitKey d2 emm     ---    joinKey :: (IsEmm (Plus k k2)) =>+    joinKey :: (IsKey (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.+    -- | 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)@@ -209,29 +295,6 @@     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@@ -247,11 +310,21 @@     -- 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 :: 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.-    fromList :: [(k, v)] -> EnumMapMap k v+    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+    -- | List of elements in ascending order of keys+    elems :: EnumMapMap k v -> [v]+    elems = foldr (:) []+    -- | 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+    -- 'Data.EnumMapSet' keys using 'toS', and back again using 'toK'.+    keysSet :: (HasSKey k) => EnumMapMap k v -> EnumMapMap (Skey k) ()     -- | 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@@ -297,8 +370,7 @@     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+instance (Eq k, Enum k, IsKey t, HasSKey t) => IsKey (k :& t) where     data EnumMapMap (k :& t) v = KCC (EMM k (EnumMapMap t v))      emptySubTrees e@(KCC emm) =@@ -346,30 +418,6 @@                    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 @@ -383,6 +431,8 @@         where           go k val z = foldrWithKey (\nxt -> f $ k :& nxt) z val +    keysSet (KCC emm) = KCC $ mapWithKey_ (\_ -> keysSet) emm+     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@@ -391,7 +441,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@@ -403,7 +453,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@@ -415,7 +465,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@@ -443,7 +493,7 @@ -- | '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) =>+alter_ :: (IsKey b) =>           (EnumMapMap b v -> EnumMapMap b v)        -> Key        -> EMM a (EnumMapMap b v)@@ -501,7 +551,7 @@                | 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'+    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)@@ -511,7 +561,7 @@                 | otherwise = maybe_join k1 (g1 t1) k2 (g2 t2)             merge t2 _  Nil = g2 t2 -    go t1@(Bin _ _ _ _) Nil = g1 t1+    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)@@ -538,7 +588,7 @@  -- Eq -instance (Eq v, IsEmm k) => Eq (EnumMapMap k v) where+instance (Eq v, IsKey k) => Eq (EnumMapMap k v) where   t1 == t2  = equal t1 t2   t1 /= t2  = nequal t1 t2 @@ -548,7 +598,7 @@  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)+  = (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@@ -556,17 +606,17 @@  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)+  = (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)+instance (IsKey k) => Functor (EnumMapMap k)     where       fmap = map -instance (IsEmm k) => Monoid (EnumMapMap k v) where+instance (IsKey k) => Monoid (EnumMapMap k v) where     mempty = empty     mappend = union     mconcat = unions@@ -610,7 +660,7 @@     p = mask p1 m {-# INLINE join #-} -joinD :: (IsEmm b) =>+joinD :: (IsKey b) =>          Prefix -> EMM a (EnumMapMap b v)       -> Prefix -> EMM a (EnumMapMap b v)       -> EMM a (EnumMapMap b v)@@ -634,7 +684,7 @@ {--------------------------------------------------------------------   @binD@ assures that we never have empty trees in the next level --------------------------------------------------------------------}-binD :: (IsEmm b) =>+binD :: (IsKey b) =>         Prefix -> Mask      -> EMM a (EnumMapMap b v)      -> EMM a (EnumMapMap b v)@@ -650,7 +700,7 @@ 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 :: (IsKey b) => Key -> EnumMapMap b v -> EMM a (EnumMapMap b v) tip k val     | null val  = Nil     | otherwise = Tip k val@@ -661,16 +711,16 @@ --------------------------------------------------------------------} zero :: Key -> Mask -> Bool zero i m-  = (natFromInt i) .&. (natFromInt m) == 0+  = natFromInt i .&. natFromInt m == 0 {-# INLINE zero #-}  nomatch,match :: Key -> Prefix -> Mask -> Bool nomatch i p m-  = (mask i m) /= p+  = mask i m /= p {-# INLINE nomatch #-}  match i p m-  = (mask i m) == p+  = mask i m == p {-# INLINE match #-}  mask :: Key -> Mask -> Prefix@@ -688,7 +738,7 @@  shorter :: Mask -> Mask -> Bool shorter m1 m2-  = (natFromInt m1) > (natFromInt m2)+  = natFromInt m1 > natFromInt m2 {-# INLINE shorter #-}  branchMask :: Prefix -> Prefix -> Mask

@@ -1,5 +1,5 @@-{-# LANGUAGE CPP, MagicHash, TypeFamilies, TypeOperators, BangPatterns,-             FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE CPP, BangPatterns, FlexibleInstances, GeneralizedNewtypeDeriving,+  MagicHash, MultiParamTypeClasses, TypeFamilies, TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  -----------------------------------------------------------------------------@@ -9,10 +9,24 @@ --                (c) Andriy Palamarchuk 2008 --                (c) Matthew West 2012 -- License     :  BSD-style--- Maintainer  : -- Stability   :  experimental -- Portability :  Uses GHC extensions --+-- Lazy 'EnumMapMap'.  Based upon "Data.IntMap.Lazy", this version uses multi+-- dimensional keys and 'Enum' types instead of 'Int's.  Keys are built using+-- the ':&' operator and terminated with 'K'.  They are stored using 'Int's so 2+-- keys that 'Enum' to the same 'Int' value will overwrite each other.  The+-- intension is that the 'Enum' types will actually be @newtype 'Int'@s.+--+-- > newtype AppleID = AppleID Int+-- > newtype TreeID = TreeID Int+-- > type Orchard = EnumMapMap (TreeID :& K AppleID) Apple+-- > apple = lookup (TreeID 4 :& K AppleID 32) orchard+--+-- The 'K' type is different to that used in "Data.EnumMapMap.Strict" so only lazy+-- operations can be performed on a lazy 'EnumMapMap'.+--+-- The functions are lazy on values, but strict on keys. -----------------------------------------------------------------------------  module Data.EnumMapMap.Lazy (@@ -62,7 +76,12 @@             -- * Lists             toList,             fromList,+            keys,+            elems,+            keysSet,             -- * Split/Join Keys+            toK,+            toS,             splitKey,             joinKey,             unsafeJoinKey@@ -71,10 +90,20 @@ import           Prelude hiding (lookup,map,filter,foldr,foldl,null,init)  import           Control.DeepSeq (NFData(rnf))+import           Data.Bits  import           Data.EnumMapMap.Base+import qualified Data.EnumMapSet.Base as EMS -instance (Enum k) => IsEmm (K k) where+-- | Keys are terminated with the 'K' type+--+-- > singleKey :: K Int+-- > singleKey = K 5+--+newtype K k = K k+           deriving (Show, Eq)++instance (Enum k, Eq k) => IsKey (K k) where     data EnumMapMap (K k) v = KEC (EMM k v)      emptySubTrees e@(KEC emm) =@@ -114,56 +143,6 @@                    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@@ -196,6 +175,18 @@           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+          go (Tip kx _) = EMS.Tip (EMS.prefixOf kx) (EMS.bitmapOf kx)+          go (Bin p m l r)+              | m .&. EMS.suffixBitMask == 0 = EMS.Bin p m (go l) (go r)+              | otherwise = EMS.Tip (p .&. EMS.prefixBitMask)+                            (computeBm (computeBm 0 l) r)+              where+                computeBm !acc (Bin _ _ l' r') = computeBm (computeBm acc l') r'+                computeBm !acc (Tip kx _)      = acc .|. EMS.bitmapOf kx+                computeBm !acc Nil             = acc      union (KEC emm1) (KEC emm2) = KEC $ mergeWithKey' Bin const id id emm1 emm2     unionWithKey f (KEC emm1) (KEC emm2) =@@ -239,6 +230,11 @@           go (Tip _ v)     = rnf v           go (Bin _ _ l r) = go l `seq` go r +instance HasSKey (K k) where+    type Skey (K k) = EMS.S k+    toS (K !k) = EMS.S k+    toK (EMS.S !k) = K k+ {---------------------------------------------------------------------  Split/Join Keys ---------------------------------------------------------------------}@@ -249,3 +245,68 @@     type Head (k :& t) Z = K k     type Tail (k :& t) Z = t     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+    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+    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+    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+    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++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++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++insertWK :: (v -> v -> v) -> Key -> v -> EMM k v -> EMM k v+insertWK f !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 y+                | key == ky       -> Tip key (f val y)+                | otherwise       -> join key (Tip key val) ky emm+            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

@@ -1,5 +1,5 @@-{-# LANGUAGE MagicHash, MultiParamTypeClasses, TypeFamilies, TypeOperators,-  BangPatterns, FlexibleInstances, FlexibleContexts, CPP #-}+{-# LANGUAGE CPP, BangPatterns, FlexibleInstances, GeneralizedNewtypeDeriving,+  MagicHash, MultiParamTypeClasses, TypeFamilies, TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  -----------------------------------------------------------------------------@@ -9,10 +9,24 @@ --                (c) Andriy Palamarchuk 2008 --                (c) Matthew West 2012 -- License     :  BSD-style--- Maintainer  : -- Stability   :  experimental -- Portability :  Uses GHC extensions --+-- Strict 'EnumMapMap'.  Based upon "Data.IntMap.Strict", this version uses multi+-- dimensional keys and 'Enum' types instead of 'Int's.  Keys are built using+-- the ':&' operator and terminated with 'K'.  They are stored using 'Int's so 2+-- keys that 'Enum' to the same 'Int' value will overwrite each other.  The+-- intension is that the 'Enum' types will actually be @newtype 'Int'@s.+--+-- > newtype AppleID = AppleID Int+-- > newtype TreeID = TreeID Int+-- > type Orchard = EnumMapMap (TreeID :& K AppleID) Apple+-- > apple = lookup (TreeID 4 :& K AppleID 32) orchard+--+-- The 'K' type is different to that used in "Data.EnumMapMap.Lazy" so only strict+-- operations can be performed on a strict 'EnumMapMap'.+--+-- The functions are strict on values and keys. -----------------------------------------------------------------------------  module Data.EnumMapMap.Strict (@@ -63,7 +77,12 @@             -- * Lists             toList,             fromList,+            keys,+            elems,+            keysSet,             -- * Split/Join Keys+            toK,+            toS,             splitKey,             joinKey,             unsafeJoinKey@@ -72,10 +91,20 @@ import           Prelude hiding (lookup,map,filter,foldr,foldl,null, init)  import           Control.DeepSeq (NFData(rnf))+import           Data.Bits  import           Data.EnumMapMap.Base+import qualified Data.EnumMapSet.Base as EMS -instance (Enum k) => IsEmm (K k) where+-- | Keys are terminated with the 'K' type+--+-- > singleKey :: K Int+-- > singleKey = K 5+--+newtype K k = K k+           deriving (Show, Eq)++instance (Enum k, Eq k) => IsKey (K k) where     data EnumMapMap (K k) v = KEC (EMM k v)      emptySubTrees e@(KEC emm) =@@ -115,56 +144,6 @@                    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@@ -197,6 +176,18 @@           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+          go (Tip kx _) = EMS.Tip (EMS.prefixOf kx) (EMS.bitmapOf kx)+          go (Bin p m l r)+              | m .&. EMS.suffixBitMask == 0 = EMS.Bin p m (go l) (go r)+              | otherwise = EMS.Tip (p .&. EMS.prefixBitMask)+                            (computeBm (computeBm 0 l) r)+              where+                computeBm !acc (Bin _ _ l' r') = computeBm (computeBm acc l') r'+                computeBm !acc (Tip kx _)      = acc .|. EMS.bitmapOf kx+                computeBm !acc Nil             = acc      union (KEC emm1) (KEC emm2) = KEC $ mergeWithKey' Bin const id id emm1 emm2     unionWithKey f (KEC emm1) (KEC emm2) =@@ -240,6 +231,11 @@           go (Tip _ v)     = rnf v           go (Bin _ _ l r) = go l `seq` go r +instance HasSKey (K k) where+    type Skey (K k) = EMS.S k+    toS (K !k) = EMS.S k+    toK (EMS.S !k) = K k+ {---------------------------------------------------------------------  Split/Join Keys ---------------------------------------------------------------------}@@ -250,3 +246,68 @@     type Head (k :& t) Z = K k     type Tail (k :& t) Z = t     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+    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+    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+    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+    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++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++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++insertWK :: (v -> v -> v) -> Key -> v -> EMM k v -> EMM k v+insertWK f !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 y+                | key == ky       -> Tip key (f val y)+                | otherwise       -> join key (Tip key val) ky emm+            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

@@ -1,28 +1,37 @@-{-# LANGUAGE BangPatterns, CPP, MagicHash, TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TypeFamilies #-}  ----------------------------------------------------------------------------- -- | -- Module      :  Data.EnumMapSet -- Copyright   :  (c) Daan Leijen 2002---                (c) Andriy Palamarchuk 2008+--                (c) Joachim Breitner 2011 --                (c) Matthew West 2012 -- License     :  BSD-style--- Maintainer  : -- Stability   :  experimental -- Portability :  Uses GHC extensions ----- Based on Data.IntSet.+-- Based on "Data.IntSet", this module provides multi-dimensional sets of+-- 'Enums'. Keys are built using ':&' and terminated with 'S'.  They are stored+-- using 'Int's so 2 keys that 'Enum' to the same 'Int' value will overwrite+-- each other.  The intension is that the 'Enum' types will actually be @newtype+-- 'Int'@s. --+--+-- > newtype AppleID = AppleID Int+-- > newtype TreeID = TreeID Int+-- > type Orchard = EnumMapSet (TreeID :& S AppleID)+-- > applePresent = member (TreeID 4 :& K AppleID 32) orchard+-- -----------------------------------------------------------------------------  module Data.EnumMapSet (             EnumMapSet,-            K(..), (:&)(..),+            S(..), (:&)(..),             -- * Query-            null,+            EMS.null,             size,             member,+            EMS.lookup,             -- * Construction             empty,             singleton,@@ -33,417 +42,13 @@             difference,             intersection,             -- * Map-            map,+            EMS.map,             -- * Folds-            foldr,+            EMS.foldr,             -- * Lists             toList,-            fromList+            fromList,+            keys ) where -import           Prelude hiding (lookup,-                                 map,-                                 filter,-                                 foldr, foldl,-                                 null, init,-                                 head, tail)--import           Data.Bits-import qualified Data.List as List-import           GHC.Exts (Word(..), Int(..))-import           GHC.Prim (indexInt8OffAddr#)-#include "MachDeps.h"--import           Data.EnumMapMap.Base ((:&)(..), K(..), EMM(..),-                                       IsEmm,-                                       EnumMapMap,-                                       Prefix, Nat,-                                       intFromNat, bin,-                                       shiftRL, shiftLL,-                                       nomatch, zero,-                                       join, shorter,-                                       foldlStrict)-import qualified Data.EnumMapMap.Base as EMM--type EnumMapSet k = EnumMapMap k ()--type BitMap = Word--instance (Enum k) => IsEmm (K k) where-    data EnumMapMap (K k) v = KSC (EMM k BitMap)--    emptySubTrees e@(KSC emm) =-        case emm of-          Nil -> False-          _   -> EMM.emptySubTrees_ e-    emptySubTrees_ (KSC emm) = go emm-        where-          go t = case t of-                   Bin _ _ l r -> go l || go r-                   Tip _ _     -> False-                   Nil         -> True--    removeEmpties = id--    unsafeJoinKey (KSC _) = undefined--    empty = KSC Nil--    null (KSC ems) = case ems of-                       Nil -> True-                       _   -> False--    size (KSC ems) = go ems-        where-          go (Bin _ _ l r) = go l + go r-          go (Tip _ bm)    = bitcount 0 bm-          go Nil           = 0--    member !(K 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 (K key') _-        = key `seq` KSC $ Tip (prefixOf key) (bitmapOf key)-          where key = fromEnum key'--    insert (K key') _ (KSC ems)-        = key `seq` KSC $ insertBM (prefixOf key) (bitmapOf key) ems-          where key = fromEnum key'--    delete (K key') (KSC ems)-        = key `seq` KSC $ deleteBM (prefixOf key) (bitmapOf key) ems-          where 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-                      _          -> go init ems-          where-            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 (K $ toEnum k) undefined t--    union (KSC ems1) (KSC ems2) = KSC $ go ems1 ems2-        where-          go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-              | shorter m1 m2  = union1-              | shorter m2 m1  = union2-              | p1 == p2       = Bin p1 m1 (go l1 l2) (go r1 r2)-              | otherwise      = join p1 t1 p2 t2-              where-                union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2-                        | zero p2 m1        = Bin p1 m1 (go l1 t2) r1-                        | otherwise         = Bin p1 m1 l1 (go r1 t2)--                union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2-                        | zero p1 m2        = Bin p2 m2 (go t1 l2) r2-                        | otherwise         = Bin p2 m2 l2 (go t1 r2)--          go t@(Bin _ _ _ _) (Tip kx bm) = insertBM kx bm t-          go t@(Bin _ _ _ _) Nil = t-          go (Tip kx bm) t = insertBM kx bm t-          go Nil t = t--    difference (KSC ems1) (KSC ems2) = KSC $ go ems1 ems2-        where-          go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-              | shorter m1 m2  = difference1-              | shorter m2 m1  = difference2-              | p1 == p2       = bin p1 m1 (go l1 l2) (go r1 r2)-              | otherwise      = t1-              where-                difference1 | nomatch p2 p1 m1  = t1-                            | zero p2 m1        = bin p1 m1 (go l1 t2) r1-                            | otherwise         = bin p1 m1 l1 (go r1 t2)--                difference2 | nomatch p1 p2 m2  = t1-                            | zero p1 m2        = go t1 l2-                            | otherwise         = go t1 r2--          go t@(Bin _ _ _ _) (Tip kx bm) = deleteBM kx bm t-          go t@(Bin _ _ _ _) Nil = t--          go t1@(Tip kx bm) t2 = differenceTip t2-              where differenceTip (Bin p2 m2 l2 r2)-                        | nomatch kx p2 m2 = t1-                        | zero kx m2 = differenceTip l2-                        | otherwise = differenceTip r2-                    differenceTip (Tip kx2 bm2)-                        | kx == kx2 = tip kx (bm .&. complement bm2)-                        | otherwise = t1-                    differenceTip Nil = t1--          go Nil _ = Nil--    intersection (KSC ems1) (KSC ems2) = KSC $ go ems1 ems2-        where-          go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-              | shorter m1 m2  = intersection1-              | shorter m2 m1  = intersection2-              | p1 == p2       = bin p1 m1 (go l1 l2) (go r1 r2)-              | otherwise      = Nil-              where-                intersection1 | nomatch p2 p1 m1  = Nil-                              | zero p2 m1        = go l1 t2-                              | otherwise         = go r1 t2--                intersection2 | nomatch p1 p2 m2  = Nil-                              | zero p1 m2        = go t1 l2-                              | otherwise         = go t1 r2--          go t1@(Bin _ _ _ _) (Tip kx2 bm2) = intersectBM t1-              where intersectBM (Bin p1 m1 l1 r1)-                        | nomatch kx2 p1 m1 = Nil-                        | zero kx2 m1       = intersectBM l1-                        | otherwise         = intersectBM r1-                    intersectBM (Tip kx1 bm1)-                        | kx1 == kx2 = tip kx1 (bm1 .&. bm2)-                        | otherwise = Nil-                    intersectBM Nil = Nil--          go (Bin _ _ _ _) Nil = Nil--          go (Tip kx1 bm1) t2 = intersectBM t2-              where intersectBM (Bin p2 m2 l2 r2)-                        | nomatch kx1 p2 m2 = Nil-                        | zero kx1 m2       = intersectBM l2-                        | otherwise         = intersectBM r2-                    intersectBM (Tip kx2 bm2)-                        | kx1 == kx2 = tip kx1 (bm1 .&. bm2)-                        | otherwise = Nil-                    intersectBM Nil = Nil--          go Nil _ = Nil--    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)-          go (Tip kx1 bm1) (Tip kx2 bm2)-              = kx1 == kx2 && bm1 == bm2-          go Nil Nil = True-          go _   _   = False--    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)-          go (Tip kx1 bm1) (Tip kx2 bm2)-              = kx1 /= kx2 || bm1 /= bm2-          go Nil Nil = False-          go _   _   = True--    insertWith = undefined-    insertWithKey = undefined-    lookup = undefined-    alter = undefined-    foldr = undefined-    map = undefined-    mapWithKey = undefined-    unionWith = undefined-    unionWithKey = undefined-    differenceWith = undefined-    differenceWithKey = undefined-    intersectionWith = undefined-    intersectionWithKey = undefined-    fromList = undefined-    toList = undefined--{----------------------------------------------------------------------  Exported API--  The Set API is somewhat different to the Map API so we define the following-  functions to call the IsEMM functions with the type of 'v' as (), hoping that-  GHC will inline away all the empty parameters.----------------------------------------------------------------------}--null :: (IsEmm k) => EnumMapSet k -> Bool-null = EMM.null--size :: (IsEmm k) => EnumMapSet k -> Int-size = EMM.size--member ::(IsEmm k) => k -> EnumMapSet k -> Bool-member = EMM.member--empty :: (IsEmm k) => EnumMapSet k-empty = EMM.empty--singleton :: (IsEmm k) => k -> EnumMapSet k-singleton !key = EMM.singleton key ()--insert :: (IsEmm k) => k -> EnumMapSet k -> EnumMapSet k-insert !key = EMM.insert key ()--delete :: (IsEmm k) => k -> EnumMapSet k -> EnumMapSet k-delete = EMM.delete---- This function has not been optimised in any way.-foldr :: (IsEmm k) => (k -> t -> t) -> t -> EnumMapSet k -> t-foldr f = EMM.foldrWithKey go-    where-      go k _ z = f k z---- | @'map' f s@ is the set obtained by applying @f@ to each element of @s@.------ It's worth noting that the size of the result may be smaller if,--- for some @(x,y)@, @x \/= y && f x == f y@-map :: (IsEmm k1, IsEmm k2) =>-       (k1 -> k2) -> EnumMapSet k1 -> EnumMapSet k2-map f = fromList . List.map f . toList--union :: (IsEmm k) => EnumMapSet k -> EnumMapSet k -> EnumMapSet k-union = EMM.union--difference :: (IsEmm k) => EnumMapSet k -> EnumMapSet k -> EnumMapSet k-difference = EMM.difference--intersection :: (IsEmm k) => EnumMapSet k -> EnumMapSet k -> EnumMapSet k-intersection = EMM.intersection--{----------------------------------------------------------------------  List----------------------------------------------------------------------}--fromList :: IsEmm k => [k] -> EnumMapSet k-fromList xs-    = foldlStrict (\t x -> insert x t) empty xs--toList :: IsEmm k => EnumMapSet k -> [k]-toList = foldr (:) []--{----------------------------------------------------------------------  Instances----------------------------------------------------------------------}--{----------------------------------------------------------------------  Helper functions----------------------------------------------------------------------}--insertBM :: Prefix -> BitMap -> EMM k BitMap -> EMM k BitMap-insertBM !kx !bm t-    = case t of-    Bin p m l r-      | nomatch kx p m -> join kx (Tip kx bm) p t-      | zero kx m      -> Bin p m (insertBM kx bm l) r-      | otherwise      -> Bin p m l (insertBM kx bm r)-    Tip kx' bm'-      | kx' == kx -> Tip kx' (bm .|. bm')-      | otherwise -> join kx (Tip kx bm) kx' t-    Nil -> Tip kx bm--deleteBM :: Prefix -> BitMap -> EMM k BitMap -> EMM k BitMap-deleteBM !kx !bm t-  = case t of-      Bin p m l r-          | nomatch kx p m -> t-          | zero kx m      -> bin p m (deleteBM kx bm l) r-          | otherwise      -> bin p m l (deleteBM kx bm r)-      Tip kx' bm'-          | kx' == kx -> tip kx (bm' .&. complement bm)-          | otherwise -> t-      Nil -> Nil--{---------------------------------------------------------------------  @tip@ assures that we never have empty bitmaps within a tree.---------------------------------------------------------------------}-tip :: Prefix -> BitMap -> EMM k BitMap-tip _ 0 = Nil-tip kx bm = Tip kx bm-{-# INLINE tip #-}--{-----------------------------------------------------------------------  Functions that generate Prefix and BitMap of a Key or a Suffix.--  Commentary and credits can be found with the original code in-  Data/IntSet/Base.hs in 'containers 5.0'.-----------------------------------------------------------------------}--suffixBitMask :: Int-suffixBitMask = bitSize (undefined::Word) - 1-{-# INLINE suffixBitMask #-}--prefixBitMask :: Int-prefixBitMask = complement suffixBitMask-{-# INLINE prefixBitMask #-}--prefixOf :: Int -> Prefix-prefixOf x = x .&. prefixBitMask-{-# INLINE prefixOf #-}--suffixOf :: Int -> Int-suffixOf x = x .&. suffixBitMask-{-# INLINE suffixOf #-}--bitmapOfSuffix :: Int -> BitMap-bitmapOfSuffix s = 1 `shiftLL` s-{-# INLINE bitmapOfSuffix #-}--bitmapOf :: Int -> BitMap-bitmapOf x = bitmapOfSuffix (suffixOf x)-{-# INLINE bitmapOf #-}--bitcount :: Int -> Word -> Int-bitcount a0 x0 = go a0 x0-  where go a 0 = a-        go a x = go (a + 1) (x .&. (x-1))-{-# INLINE bitcount #-}--{-----------------------------------------------------------------------  Folds over a BitMap.--  Commentary and credits can be found with the original code in-  Data/IntSet/Base.hs in 'containers 5.0'.-----------------------------------------------------------------------}--foldrBits :: Int -> (Int -> a -> a) -> a -> Nat -> a--{-# INLINE foldrBits #-}--indexOfTheOnlyBit :: Nat -> Int-{-# INLINE indexOfTheOnlyBit #-}-indexOfTheOnlyBit bitmask =-  I# (lsbArray `indexInt8OffAddr#` unboxInt-                   (intFromNat ((bitmask * magic) `shiftRL` offset)))-  where unboxInt (I# i) = i-#if WORD_SIZE_IN_BITS==32-        magic = 0x077CB531-        offset = 27-        !lsbArray = "\0\1\28\2\29\14\24\3\30\22\20\15\25\17\4\8\31\27\13\23\21\19\16\7\26\12\18\6\11\5\10\9"#-#else-        magic = 0x07EDD5E59A4E28C2-        offset = 58-        !lsbArray = "\63\0\58\1\59\47\53\2\60\39\48\27\54\33\42\3\61\51\37\40\49\18\28\20\55\30\34\11\43\14\22\4\62\57\46\52\38\26\32\41\50\36\17\19\29\10\13\21\56\45\25\31\35\16\9\12\44\24\15\8\23\7\6\5"#-#endif-lowestBitMask :: Nat -> Nat-lowestBitMask x = x .&. negate x-{-# INLINE lowestBitMask #-}--revNat :: Nat -> Nat-#if WORD_SIZE_IN_BITS==32-revNat x1 = case ((x1 `shiftRL` 1) .&. 0x55555555) .|. ((x1 .&. 0x55555555) `shiftLL` 1) of-              x2 -> case ((x2 `shiftRL` 2) .&. 0x33333333) .|. ((x2 .&. 0x33333333) `shiftLL` 2) of-                 x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F) `shiftLL` 4) of-                   x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF) .|. ((x4 .&. 0x00FF00FF) `shiftLL` 8) of-                     x5 -> ( x5 `shiftRL` 16             ) .|. ( x5               `shiftLL` 16);-#else-revNat x1 = case ((x1 `shiftRL` 1) .&. 0x5555555555555555) .|. ((x1 .&. 0x5555555555555555) `shiftLL` 1) of-              x2 -> case ((x2 `shiftRL` 2) .&. 0x3333333333333333) .|. ((x2 .&. 0x3333333333333333) `shiftLL` 2) of-                 x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F0F0F0F0F) `shiftLL` 4) of-                   x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF00FF00FF) .|. ((x4 .&. 0x00FF00FF00FF00FF) `shiftLL` 8) of-                     x5 -> case ((x5 `shiftRL` 16) .&. 0x0000FFFF0000FFFF) .|. ((x5 .&. 0x0000FFFF0000FFFF) `shiftLL` 16) of-                       x6 -> ( x6 `shiftRL` 32             ) .|. ( x6               `shiftLL` 32);-#endif-foldrBits prefix f z bitmap = go (revNat bitmap) z-  where go bm acc | bm == 0 = acc-                  | otherwise = case lowestBitMask bm of-                                  bitmask -> bitmask `seq` case indexOfTheOnlyBit bitmask of-                                    bi -> bi `seq` go (bm `xor` bitmask) ((f $! (prefix+(WORD_SIZE_IN_BITS-1)-bi)) acc)+import Data.EnumMapSet.Base as EMS

@@ -0,0 +1,565 @@+{-# LANGUAGE BangPatterns, CPP, FlexibleContexts, FlexibleInstances,+ GeneralizedNewtypeDeriving, MagicHash, MultiParamTypeClasses, TypeFamilies,+ TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.EnumMapSet+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Joachim Breitner 2011+--                (c) Matthew West 2012+-- License     :  BSD-style+-- Stability   :  experimental+-- Portability :  Uses GHC extensions+--+-- Based on Data.IntSet.Base+--+-----------------------------------------------------------------------------++module Data.EnumMapSet.Base (+            EnumMapSet,+            S(..), (:&)(..),+            -- * Query+            null,+            size,+            member,+            lookup,+            -- * Construction+            empty,+            singleton,+            insert,+            insertSub,+            delete,+            -- * Combine+            union,+            difference,+            intersection,+            -- * Map+            map,+            -- * Folds+            foldr,+            -- * Lists+            toList,+            fromList,+            keys,+            -- * Internals+            EMS(..),+            EnumMapMap(KSC),+            suffixBitMask,+            prefixBitMask,+            bitmapOf,+            prefixOf+) where++import           Prelude hiding (lookup,+                                 map,+                                 filter,+                                 foldr, foldl,+                                 null, init,+                                 head, tail)++import           Data.Bits+import qualified Data.List as List+import           GHC.Exts (Word(..), Int(..))+import           GHC.Prim (indexInt8OffAddr#)+#include "MachDeps.h"++import           Data.EnumMapMap.Base ((:&)(..),+                                       IsKey,+                                       EnumMapMap,+                                       Prefix, Nat, Mask,+                                       branchMask, mask,+                                       intFromNat,+                                       shiftRL, shiftLL,+                                       nomatch, zero,+                                       shorter,+                                       foldlStrict)+import qualified Data.EnumMapMap.Base as EMM++type EnumMapSet k = EnumMapMap k ()++type BitMap = Word++-- | Keys are terminated with the 'S' type.+--+-- > singleKey :: S Int+-- > singleKey = S 5+--+newtype S k = S k+           deriving (Show, Eq)++-- 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+                 !(EMS k) !(EMS k)+           | Tip {-# UNPACK #-} !Int {-# UNPACK #-} !BitMap+           | Nil+             deriving (Show)++instance (Enum k, Eq k) => IsKey (S k) where+    data EnumMapMap (S k) v = KSC (EMS k)++    emptySubTrees e@(KSC emm) =+        case emm of+          Nil -> False+          _   -> EMM.emptySubTrees_ e+    emptySubTrees_ (KSC emm) = go emm+        where+          go t = case t of+                   Bin _ _ l r -> go l || go r+                   Tip _ _     -> False+                   Nil         -> True++    removeEmpties = id++    unsafeJoinKey (KSC _) = undefined++    empty = KSC Nil++    null (KSC ems) = case ems of+                       Nil -> True+                       _   -> False++    size (KSC ems) = go ems+        where+          go (Bin _ _ l r) = go l + go r+          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+                      _          -> go init ems+          where+            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++    union (KSC ems1) (KSC ems2) = KSC $ go ems1 ems2+        where+          go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+              | shorter m1 m2  = union1+              | shorter m2 m1  = union2+              | p1 == p2       = Bin p1 m1 (go l1 l2) (go r1 r2)+              | otherwise      = join p1 t1 p2 t2+              where+                union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2+                        | zero p2 m1        = Bin p1 m1 (go l1 t2) r1+                        | otherwise         = Bin p1 m1 l1 (go r1 t2)++                union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2+                        | zero p1 m2        = Bin p2 m2 (go t1 l2) r2+                        | otherwise         = Bin p2 m2 l2 (go t1 r2)++          go t@(Bin _ _ _ _) (Tip kx bm) = insertBM kx bm t+          go t@(Bin _ _ _ _) Nil = t+          go (Tip kx bm) t = insertBM kx bm t+          go Nil t = t++    difference (KSC ems1) (KSC ems2) = KSC $ go ems1 ems2+        where+          go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+              | shorter m1 m2  = difference1+              | shorter m2 m1  = difference2+              | p1 == p2       = bin p1 m1 (go l1 l2) (go r1 r2)+              | otherwise      = t1+              where+                difference1 | nomatch p2 p1 m1  = t1+                            | zero p2 m1        = bin p1 m1 (go l1 t2) r1+                            | otherwise         = bin p1 m1 l1 (go r1 t2)++                difference2 | nomatch p1 p2 m2  = t1+                            | zero p1 m2        = go t1 l2+                            | otherwise         = go t1 r2++          go t@(Bin _ _ _ _) (Tip kx bm) = deleteBM kx bm t+          go t@(Bin _ _ _ _) Nil = t++          go t1@(Tip kx bm) t2 = differenceTip t2+              where differenceTip (Bin p2 m2 l2 r2)+                        | nomatch kx p2 m2 = t1+                        | zero kx m2 = differenceTip l2+                        | otherwise = differenceTip r2+                    differenceTip (Tip kx2 bm2)+                        | kx == kx2 = tip kx (bm .&. complement bm2)+                        | otherwise = t1+                    differenceTip Nil = t1++          go Nil _ = Nil++    intersection (KSC ems1) (KSC ems2) = KSC $ go ems1 ems2+        where+          go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+              | shorter m1 m2  = intersection1+              | shorter m2 m1  = intersection2+              | p1 == p2       = bin p1 m1 (go l1 l2) (go r1 r2)+              | otherwise      = Nil+              where+                intersection1 | nomatch p2 p1 m1  = Nil+                              | zero p2 m1        = go l1 t2+                              | otherwise         = go r1 t2++                intersection2 | nomatch p1 p2 m2  = Nil+                              | zero p1 m2        = go t1 l2+                              | otherwise         = go t1 r2++          go t1@(Bin _ _ _ _) (Tip kx2 bm2) = intersectBM t1+              where intersectBM (Bin p1 m1 l1 r1)+                        | nomatch kx2 p1 m1 = Nil+                        | zero kx2 m1       = intersectBM l1+                        | otherwise         = intersectBM r1+                    intersectBM (Tip kx1 bm1)+                        | kx1 == kx2 = tip kx1 (bm1 .&. bm2)+                        | otherwise = Nil+                    intersectBM Nil = Nil++          go (Bin _ _ _ _) Nil = Nil++          go (Tip kx1 bm1) t2 = intersectBM t2+              where intersectBM (Bin p2 m2 l2 r2)+                        | nomatch kx1 p2 m2 = Nil+                        | zero kx1 m2       = intersectBM l2+                        | otherwise         = intersectBM r2+                    intersectBM (Tip kx2 bm2)+                        | kx1 == kx2 = tip kx1 (bm1 .&. bm2)+                        | otherwise = Nil+                    intersectBM Nil = Nil++          go Nil _ = Nil++    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)+          go (Tip kx1 bm1) (Tip kx2 bm2)+              = kx1 == kx2 && bm1 == bm2+          go Nil Nil = True+          go _   _   = False++    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)+          go (Tip kx1 bm1) (Tip kx2 bm2)+              = kx1 /= kx2 || bm1 /= bm2+          go Nil Nil = False+          go _   _   = True++    alter = undefined+    foldr = undefined+    map = undefined+    mapWithKey = undefined+    unionWith = undefined+    unionWithKey = undefined+    differenceWith = undefined+    differenceWithKey = undefined+    intersectionWith = undefined+    intersectionWithKey = undefined+    fromList = undefined+    toList = undefined+    elems = undefined+    keysSet = undefined++{---------------------------------------------------------------------+  Exported API++  The Set API is somewhat different to the Map API so we define the following+  functions to call the IsEMM functions with the type of 'v' as (), hoping that+  GHC will inline away all the empty parameters.+---------------------------------------------------------------------}++null :: (IsKey k) => EnumMapSet k -> Bool+null = EMM.null++size :: (IsKey k) => EnumMapSet k -> Int+size = EMM.size++member ::(IsKey k) => k -> EnumMapSet k -> Bool+member = EMM.member++-- | Lookup a subtree in an 'EnumMapSet'.+--+-- > ems = fromList [1 :& 2 :& K 3, 1 :& 2 :& K 4]+-- > lookup (1 :& K 2) ems == fromList [K 3, K 4]+-- > lookup (1 :& 2 :& K 3) -- ERROR: Use 'member' to check for a key.+--+lookup :: (EMM.SubKey k1 k2 (), IsKey k1, IsKey k2) =>+          k1 -> EnumMapSet k2 -> Maybe (EMM.Result k1 k2 ())+lookup = EMM.lookup++empty :: (IsKey k) => EnumMapSet k+empty = EMM.empty++singleton :: (IsKey k, EMM.SubKey k k (), EMM.Result k k () ~ ()) =>+             k -> EnumMapSet k+singleton !key = EMM.singleton key ()++insert :: (IsKey k, EMM.SubKey k k (), EMM.Result k k () ~ ()) =>+          k -> EnumMapSet k -> EnumMapSet k+insert !key = EMM.insert key ()++insertSub :: (IsKey k1, IsKey k2, EMM.SubKey k1 k2 ()) =>+             k1 -> EMM.Result k1 k2 () -> EnumMapSet k2 -> EnumMapSet k2+insertSub !key = EMM.insert key++delete :: (EMM.SubKey k1 k2 (), IsKey k1, IsKey k2) =>+          k1 -> EnumMapSet k2 -> EnumMapSet k2+delete = EMM.delete++-- This function has not been optimised in any way.+foldr :: (IsKey k) => (k -> t -> t) -> t -> EnumMapSet k -> t+foldr f = EMM.foldrWithKey go+    where+      go k _ z = f k z++-- | @'map' f s@ is the set obtained by applying @f@ to each element of @s@.+--+-- It's worth noting that the size of the result may be smaller if,+-- for some @(x,y)@, @x \/= y && f x == f y@+map :: (IsKey k1, IsKey k2, EMM.SubKey k2 k2 (), EMM.Result k2 k2 () ~ ()) =>+       (k1 -> k2) -> EnumMapSet k1 -> EnumMapSet k2+map f = fromList . List.map f . toList++union :: (IsKey k) => EnumMapSet k -> EnumMapSet k -> EnumMapSet k+union = EMM.union++difference :: (IsKey k) => EnumMapSet k -> EnumMapSet k -> EnumMapSet k+difference = EMM.difference++intersection :: (IsKey k) => EnumMapSet k -> EnumMapSet k -> EnumMapSet k+intersection = EMM.intersection++{---------------------------------------------------------------------+  Lists+---------------------------------------------------------------------}++fromList :: (IsKey k, EMM.SubKey k k (), EMM.Result k k () ~ ()) =>+            [k] -> EnumMapSet k+fromList xs+    = foldlStrict (\t x -> insert x t) empty xs++toList :: IsKey k => EnumMapSet k -> [k]+toList = foldr (:) []++keys :: IsKey k => EnumMapSet k -> [k]+keys = toList++{---------------------------------------------------------------------+  Instances+---------------------------------------------------------------------}++instance EMM.HasSKey (S k) where+    type Skey (S k) = S k+    toS (S _) = undefined+    toK (S _) = undefined++instance (Enum k1, k1 ~ k2) => EMM.SubKey (S k1) (k2 :& t2) () where+    type Result (S k1) (k2 :& t2) () = EnumMapSet t2++    singleton !(S key) = EMM.KCC . EMM.Tip (fromEnum key)++    lookup (S key') (EMM.KCC emm) = key `seq` go emm+        where+          go (EMM.Bin _ m l r)+             | zero key m = go l+             | otherwise = go r+          go (EMM.Tip kx x)+             = case kx == key of+                 True -> Just x+                 False -> Nothing+          go EMM.Nil = Nothing+          key = fromEnum key'++    insert (S key') val (EMM.KCC emm) = key `seq` EMM.KCC $ go emm+        where+          go t =+              case t of+                EMM.Bin p m l r+                    | nomatch key p m -> EMM.join key (EMM.Tip key val) p t+                    | zero key m      -> EMM.Bin p m (go l) r+                    | otherwise       -> EMM.Bin p m l (go r)+                EMM.Tip ky _+                    | key == ky       -> EMM.Tip key val+                    | otherwise       -> EMM.join key (EMM.Tip key val) ky t+                EMM.Nil               -> EMM.Tip key val+          key = fromEnum key'++    delete (S key') (EMM.KCC emm) = key `seq` EMM.KCC $ go emm+        where+          go t = case t of+                   EMM.Bin p m l r | nomatch key p m -> t+                                   | zero key m      -> EMM.bin p m (go l) r+                                   | otherwise       -> EMM.bin p m l (go r)+                   EMM.Tip ky _    | key == ky       -> EMM.Nil+                                   | otherwise       -> t+                   EMM.Nil                           -> EMM.Nil+          key = fromEnum key'++    insertWith = undefined+    insertWithKey = undefined++instance (Enum k) => EMM.SubKey (S k) (S k) () where+    type Result (S k) (S k) () = ()+    singleton !(S key') _ = KSC $! Tip (prefixOf key) (bitmapOf key)+          where key = fromEnum key'+    lookup = undefined+    insert (S key') _ (KSC ems) =+        key `seq` KSC $ insertBM (prefixOf key) (bitmapOf key) ems+            where key = fromEnum key'+    delete !(S key') (KSC ems) =+        key `seq` KSC $ deleteBM (prefixOf key) (bitmapOf key) ems+          where key = fromEnum key'++    insertWith = undefined+    insertWithKey = undefined++{---------------------------------------------------------------------+  Helper functions+---------------------------------------------------------------------}++insertBM :: Prefix -> BitMap -> EMS k -> EMS k+insertBM !kx !bm t =+    case t of+      Bin p m l r+          | nomatch kx p m -> join kx (Tip kx bm) p t+          | zero kx m      -> Bin p m (insertBM kx bm l) r+          | otherwise      -> Bin p m l (insertBM kx bm r)+      Tip kx' bm'+          | kx' == kx -> Tip kx' (bm .|. bm')+          | otherwise -> join kx (Tip kx bm) kx' t+      Nil -> Tip kx bm++deleteBM :: Prefix -> BitMap -> EMS k -> EMS k+deleteBM !kx !bm t+  = case t of+      Bin p m l r+          | nomatch kx p m -> t+          | zero kx m      -> bin p m (deleteBM kx bm l) r+          | otherwise      -> bin p m l (deleteBM kx bm r)+      Tip kx' bm'+          | kx' == kx -> tip kx (bm' .&. complement bm)+          | otherwise -> t+      Nil -> Nil++join :: Prefix -> EMS k -> Prefix -> EMS k -> EMS k+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 #-}++bin :: Prefix -> Mask -> EMS k -> EMS k -> EMS k+bin _ _ l Nil = l+bin _ _ Nil r = r+bin p m l r   = Bin p m l r+{-# INLINE bin #-}++{--------------------------------------------------------------------+  @tip@ assures that we never have empty bitmaps within a tree.+--------------------------------------------------------------------}+tip :: Prefix -> BitMap -> EMS k+tip _ 0 = Nil+tip kx bm = Tip kx bm+{-# INLINE tip #-}++{----------------------------------------------------------------------+  Functions that generate Prefix and BitMap of a Key or a Suffix.++  Commentary and credits can be found with the original code in+  Data/IntSet/Base.hs in 'containers 5.0'.+----------------------------------------------------------------------}++suffixBitMask :: Int+suffixBitMask = bitSize (undefined::Word) - 1+{-# INLINE suffixBitMask #-}++prefixBitMask :: Int+prefixBitMask = complement suffixBitMask+{-# INLINE prefixBitMask #-}++prefixOf :: Int -> Prefix+prefixOf x = x .&. prefixBitMask+{-# INLINE prefixOf #-}++suffixOf :: Int -> Int+suffixOf x = x .&. suffixBitMask+{-# INLINE suffixOf #-}++bitmapOfSuffix :: Int -> BitMap+bitmapOfSuffix s = 1 `shiftLL` s+{-# INLINE bitmapOfSuffix #-}++bitmapOf :: Int -> BitMap+bitmapOf x = bitmapOfSuffix (suffixOf x)+{-# INLINE bitmapOf #-}++bitcount :: Int -> Word -> Int+bitcount a0 x0 = go a0 x0+  where go a 0 = a+        go a x = go (a + 1) (x .&. (x-1))+{-# INLINE bitcount #-}++{----------------------------------------------------------------------+  Folds over a BitMap.++  Commentary and credits can be found with the original code in+  Data/IntSet/Base.hs in 'containers 5.0'.+----------------------------------------------------------------------}++foldrBits :: Int -> (Int -> a -> a) -> a -> Nat -> a++{-# INLINE foldrBits #-}++indexOfTheOnlyBit :: Nat -> Int+{-# INLINE indexOfTheOnlyBit #-}+indexOfTheOnlyBit bitmask =+  I# (lsbArray `indexInt8OffAddr#` unboxInt+                   (intFromNat ((bitmask * magic) `shiftRL` offset)))+  where unboxInt (I# i) = i+#if WORD_SIZE_IN_BITS==32+        magic = 0x077CB531+        offset = 27+        !lsbArray = "\0\1\28\2\29\14\24\3\30\22\20\15\25\17\4\8\31\27\13\23\21\19\16\7\26\12\18\6\11\5\10\9"#+#else+        magic = 0x07EDD5E59A4E28C2+        offset = 58+        !lsbArray = "\63\0\58\1\59\47\53\2\60\39\48\27\54\33\42\3\61\51\37\40\49\18\28\20\55\30\34\11\43\14\22\4\62\57\46\52\38\26\32\41\50\36\17\19\29\10\13\21\56\45\25\31\35\16\9\12\44\24\15\8\23\7\6\5"#+#endif+lowestBitMask :: Nat -> Nat+lowestBitMask x = x .&. negate x+{-# INLINE lowestBitMask #-}++revNat :: Nat -> Nat+#if WORD_SIZE_IN_BITS==32+revNat x1 = case ((x1 `shiftRL` 1) .&. 0x55555555) .|. ((x1 .&. 0x55555555) `shiftLL` 1) of+              x2 -> case ((x2 `shiftRL` 2) .&. 0x33333333) .|. ((x2 .&. 0x33333333) `shiftLL` 2) of+                 x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F) `shiftLL` 4) of+                   x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF) .|. ((x4 .&. 0x00FF00FF) `shiftLL` 8) of+                     x5 -> ( x5 `shiftRL` 16             ) .|. ( x5               `shiftLL` 16);+#else+revNat x1 = case ((x1 `shiftRL` 1) .&. 0x5555555555555555) .|. ((x1 .&. 0x5555555555555555) `shiftLL` 1) of+              x2 -> case ((x2 `shiftRL` 2) .&. 0x3333333333333333) .|. ((x2 .&. 0x3333333333333333) `shiftLL` 2) of+                 x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F0F0F0F0F) `shiftLL` 4) of+                   x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF00FF00FF) .|. ((x4 .&. 0x00FF00FF00FF00FF) `shiftLL` 8) of+                     x5 -> case ((x5 `shiftRL` 16) .&. 0x0000FFFF0000FFFF) .|. ((x5 .&. 0x0000FFFF0000FFFF) `shiftLL` 16) of+                       x6 -> ( x6 `shiftRL` 32             ) .|. ( x6               `shiftLL` 32);+#endif+foldrBits prefix f z bitmap = go (revNat bitmap) z+  where go bm acc | bm == 0 = acc+                  | otherwise = case lowestBitMask bm of+                                  bitmask -> bitmask `seq` case indexOfTheOnlyBit bitmask of+                                    bi -> bi `seq` go (bm `xor` bitmask) ((f $! (prefix+(WORD_SIZE_IN_BITS-1)-bi)) acc)

@@ -1,5 +1,5 @@ name:               enummapmap-version:            0.1.0+version:            0.2.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@@ -20,7 +20,7 @@ Library    exposed-modules: Data.EnumMapMap.Lazy, Data.EnumMapMap.Strict,                     Data.EnumMapSet-   other-modules:   Data.EnumMapMap.Base+   other-modules:   Data.EnumMapMap.Base, Data.EnumMapSet.Base    build-depends:   base >= 4.0 && < 5,                     deepseq >= 1.2 && < 1.4,                     ghc-prim

@@ -417,3 +417,23 @@              runPropDuoL4 (IM.intersectionWithKey f)                              (EMM.intersectionWithKey                                      (\(k :& _ :& _ :& K _) a b -> f k a b))++    describe "keys" $ do+        prop "Level 1" $+             runProp (IM.keys) (map (\(K k) -> k) . EMM.keys)+        prop "Level 2" $+             runProp2 (IM.keys) (map (\(k :& _) -> k) . EMM.keys)+        prop "Level 3" $+             runProp3 (IM.keys) (map (\(k :& _) -> k) . EMM.keys)+        prop "Level 4" $+             runProp4 (IM.keys) (map (\(k :& _) -> k) . EMM.keys)++    describe "elems" $ do+        prop "Level 1" $+             runProp (IM.elems) (EMM.elems)+        prop "Level 2" $+             runProp2 (IM.elems) (EMM.elems)+        prop "Level 3" $+             runProp3 (IM.elems) (EMM.elems)+        prop "Level 4" $+             runProp4 (IM.elems) (EMM.elems)

@@ -10,21 +10,21 @@  import qualified Data.IntSet as IS -import           Data.EnumMapSet(EnumMapSet, (:&)(..), K(..))+import           Data.EnumMapSet(EnumMapSet, (:&)(..), S(..)) import qualified Data.EnumMapSet as EMS -type TestSet1 = EnumMapSet (K Int)-type TestSet2 = EnumMapSet (Int :& K Int)-type TestSet3 = EnumMapSet (Int :& Int :& K Int)+type TestSet1 = EnumMapSet (S Int)+type TestSet2 = EnumMapSet (Int :& S Int)+type TestSet3 = EnumMapSet (Int :& Int :& S Int) -list2l1 :: [Int] -> [K Int]-list2l1 = map (\k -> K k)+list2l1 :: [Int] -> [S Int]+list2l1 = map S -list2l2 :: Int -> [Int] -> [Int :& K Int]-list2l2 k1 = map (\k -> k :& K k1)+list2l2 :: Int -> [Int] -> [Int :& S Int]+list2l2 k1 = map (\k -> k :& S k1) -list2l3 :: Int -> Int -> [Int] -> [Int :& Int :& K Int]-list2l3 k1 k2 = map (\k -> k :& k1 :& K k2)+list2l3 :: Int -> Int -> [Int] -> [Int :& Int :& S Int]+list2l3 k1 k2 = map (\k -> k :& k1 :& S k2)  runProp :: Eq t =>            (IS.IntSet -> t)@@ -152,29 +152,29 @@      describe "insert" $ do       prop "Level 1" $ \k ->-          runPropL (IS.insert k) (EMS.insert $ K k)+          runPropL (IS.insert k) (EMS.insert $ S k)       prop "Level 2" $ \k k1 ->-          runPropL2 (IS.insert k) (EMS.insert $ k :& K k1) k1+          runPropL2 (IS.insert k) (EMS.insert $ k :& S k1) k1       prop "Level 3" $ \k k1 k2 ->-          runPropL3 (IS.insert k) (EMS.insert $ k :& k1 :& K k2) k1 k2+          runPropL3 (IS.insert k) (EMS.insert $ k :& k1 :& S k2) k1 k2      describe "delete" $ do       prop "Level 1" $ \k ->-          runPropL (IS.delete k) (EMS.delete $ K k)+          runPropL (IS.delete k) (EMS.delete $ S k)       prop "Level 2" $ \k k1 ->-          runPropL2 (IS.delete k) (EMS.delete $ k :& K k1) k1+          runPropL2 (IS.delete k) (EMS.delete $ k :& S k1) k1       prop "Level 3" $ \k k1 k2 ->-          runPropL3 (IS.delete k) (EMS.delete $ k :& k1 :& K k2) k1 k2+          runPropL3 (IS.delete k) (EMS.delete $ k :& k1 :& S k2) k1 k2      describe "map" $ do       let f a = a + 1       prop "Level 1" $-           runPropL (IS.map f) (EMS.map (\(K k) -> K $ f k))+           runPropL (IS.map f) (EMS.map (\(S k) -> S $ f k))       prop "Level 2" $-           runPropL2 (IS.map f) (EMS.map (\(k :& K k1) -> f k :& K k1))+           runPropL2 (IS.map f) (EMS.map (\(k :& S k1) -> f k :& S k1))       prop "Level 3" $            runPropL3 (IS.map f)-                         (EMS.map (\(k :& k2 :& K k1) -> f k :& k2 :& K k1))+                         (EMS.map (\(k :& k2 :& S k1) -> f k :& k2 :& S k1))      describe "union" $ do       prop "Level 1" $

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, TypeOperators #-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  import           Control.Monad (liftM, liftM2)@@ -7,6 +7,7 @@ import           Test.Hspec.QuickCheck (prop) import           Test.HUnit import           Test.QuickCheck (Arbitrary, arbitrary, shrink)+import qualified Data.EnumMapSet as EMS  #ifdef LAZY import           Data.EnumMapMap.Lazy(EnumMapMap, (:&)(..), K(..))@@ -25,15 +26,26 @@     arbitrary = liftM K arbitrary  newtype ID1 = ID1 Int-    deriving (Show, Enum, Arbitrary)+    deriving (Show, Enum, Arbitrary, Eq, Num) newtype ID2 = ID2 Int-    deriving (Show, Enum, Arbitrary)+    deriving (Show, Enum, Arbitrary, Eq, Num) newtype ID3 = ID3 Int-    deriving (Show, Enum, Arbitrary)+    deriving (Show, Enum, Arbitrary, Eq, Num) +type TestKey1 = K ID1+type TestEmm1 = EnumMapMap TestKey1 Int+type TestKey2 = ID2 :& K ID1+type TestEmm2 = EnumMapMap TestKey2 Int type TestKey3 = ID3 :& ID2 :& K ID1 type TestEmm3 = EnumMapMap TestKey3 Int +type I = K Int++-- Functions that are part of 'SubKey' class can't cope with @K 1@ because GHC+-- doesn't know it's also an 'Int'.+k :: Int -> K Int+k = K+ tens :: [Int] tens = [1, 10, 100, 1000, 10000, 100000, 1000000] @@ -49,23 +61,23 @@ 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+l1tens :: EnumMapMap I Int+l1tens = EMM.fromList $ map (\(key, v) -> (K key, v)) $ zip [1..7] tens+l2tens :: EnumMapMap (Int :& I) 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+l1odds = EMM.fromList $ map (\(key, v) -> (K key, 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+l1evens = EMM.fromList $ map (\(key, v) -> (K key, v)) $ zip evens evens  l1alls :: EnumMapMap (K Int) Int l1alls = EMM.fromList $ zip (map K alls) alls@@ -95,27 +107,56 @@       it "is the inverse of toList on 2 levels" $            (EMM.fromList $ EMM.toList l2odds) @?= l2odds +    describe "lookup" $ do+      let emm3 :: TestEmm3+          emm3 = EMM.fromList [(ID3 1 :& ID2 2 :& (K $ ID1 3), 4)]+          key3 = ID3 1 :& ID2 2 :& (K $ ID1 3)+      describe "looks up a subtree" $ do+         let emm2 :: EnumMapMap (Int :& K Int) Int+             emm2 = EMM.fromList [(1 :& k 2, 5)]+             key1 :: K ID3+             key1 = K $ ID3 1+             key2 :: ID3 :& K ID2+             key2 = ID3 1 :& (K $ ID2 2)+         it "First level of level 2" $+            (EMM.lookup (K 1) emm2) @?= (Just $ EMM.fromList [(K 2, 5)])+         it "1 level of level 3" $+            (EMM.lookup key1 emm3) @?= (Just $+                                     EMM.fromList [(ID2 2 :& (K $ ID1 3), 4)])+         it "2 levels of level 3" $+            (EMM.lookup key2 emm3) @?= (Just $ EMM.fromList [(K $ ID1 3, 4)])+      it "looks up a value" $+         (EMM.lookup key3 emm3) @?= Just 4++    describe "singleton" $ do+      let emm2 :: EnumMapMap (ID1 :& K ID2) String+          emm2 = EMM.fromList [(ID1 1 :& (K $ ID2 2), "a")]+      it "creates an EnumMapMap with one value" $+         (EMM.singleton (ID1 1 :& (K $ ID2 2)) "a") @?= emm2+      it "creates an EnumMapMap with a sub EnumMapMap" $+         (EMM.singleton (K $ ID1 1) $ EMM.singleton (K $ ID2 2) "a") @?= emm2+     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)+           EMM.insert (k 1) 1 EMM.empty @?=+           (EMM.fromList [(k 1, 1)]+                           :: EnumMapMap I 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)]+               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.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.insert ((1 :: Int) :& 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" $@@ -123,67 +164,84 @@                  emm :: EnumMapMap (Int :& K Int) Int                  emm = EMM.fromList [(1 :& K 2, 2)]              in-               EMM.insert (1 :& K 1) 1 emm @?=+               EMM.insert ((1 :: Int) :& 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.insert ((2 :: Int) :& k 2) 2 emm @?=                EMM.fromList [(1 :& K 1, 1), (2 :& K 2, 2)] +        describe "Subtrees" $ do+          let emm2 :: TestEmm2+              emm2 = EMM.fromList [(ID2 2 :& (K $ ID1 3), 4)]+              emm1 :: TestEmm1+              emm1 = EMM.fromList [(K $ ID1 4, 12)]+          it "inserts a L1 into an empty L3 EMM" $+             EMM.insert (ID3 2 :& (K $ ID2 3)) emm1 EMM.empty @?=+                EMM.fromList [(ID3 2 :& ID2 3 :& (K $ ID1 4), 12)]+          it "inserts a L2 into an empty L3 EMM" $+             EMM.insert (K $ ID3 1) emm2 EMM.empty @?=+                EMM.fromList [(ID3 1 :& ID2 2 :& (K $ ID1 3), 4)]+     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)]+           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)]+           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)]+               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)]+             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)+           EMM.insertWithKey undef (ID2 1 :& k 1) 1 EMM.empty @?=+                  (EMM.fromList [(ID2 1 :& k 1, 1)]+                           :: EnumMapMap (ID2 :& 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)]+               emm :: EnumMapMap (ID2 :& K Int) Int+               emm = EMM.fromList [(ID2 1 :& k 2, 2)]            in-             EMM.insertWithKey undef (1 :& K 1) 1 emm @?=-                EMM.fromList [(1 :& K 1, 1), (1 :& K 2, 2)]+             EMM.insertWithKey undef (ID2 1 :& k 1) 1 emm @?=+                EMM.fromList [(ID2 1 :& K 1, 1), (ID2 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)]+               emm :: EnumMapMap (ID2 :& K Int) Int+               emm = EMM.fromList [(ID2 1 :& k 1, 1)]            in-             EMM.insertWithKey undef (2 :& K 2) 2 emm @?=-                EMM.fromList [(1 :& K 1, 1), (2 :& K 2, 2)]+             EMM.insertWithKey undef (ID2 2 :& k 2) 2 emm @?=+                EMM.fromList [(ID2 1 :& K 1, 1), (ID2 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)]+               emm = EMM.fromList [((2 :: Int) :& K 3, 1), ((2 :: Int) :& 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)]+             EMM.insertWithKey f (2 :& k 4) 3 emm @?=+                EMM.fromList [((2 :: Int) :& K 3, 1), ((2 :: Int) :& K 4, 48)]      describe "delete" $ do-      prop "leaves no empty subtrees" $ \k l ->-          not $ EMM.emptySubTrees $ EMM.delete k $ (EMM.fromList l :: TestEmm3)+      describe "leaves no empty subtrees" $ do+        prop "Full key" $ \(key :: ID3 :& ID2 :& K ID1) l ->+          not $ EMM.emptySubTrees $ EMM.delete key $ (EMM.fromList l :: TestEmm3)+        prop "2 dimensional key" $ \(key :: ID3 :& K ID2) l ->+          not $ EMM.emptySubTrees $ EMM.delete key $ (EMM.fromList l :: TestEmm3)+        prop "1 dimensional key" $ \(key :: K ID3) l ->+          not $ EMM.emptySubTrees $ EMM.delete key $ (EMM.fromList l :: TestEmm3)      describe "alter" $ do       let f b1 b2 n v = case v of@@ -191,8 +249,8 @@                           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 $+      prop "leaves no empty subtrees" $ \key l b1 b2 n ->+          not $ EMM.emptySubTrees $ EMM.alter (f b1 b2 n) key $                   (EMM.fromList l :: TestEmm3)      describe "foldrWithKey" $ do@@ -246,4 +304,13 @@             go32 l = emm == (EMM.joinKey $ EMM.splitKey EMM.d2 emm)                 where emm = EMM.fromList l         prop "Level 3, depth = 2" go32++      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)+                  where+                    emm = EMM.fromList list+          prop "Level 1" gol1+