diff --git a/Data/EnumMapMap/Base.hs b/Data/EnumMapMap/Base.hs
--- a/Data/EnumMapMap/Base.hs
+++ b/Data/EnumMapMap/Base.hs
@@ -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
diff --git a/Data/EnumMapMap/Lazy.hs b/Data/EnumMapMap/Lazy.hs
--- a/Data/EnumMapMap/Lazy.hs
+++ b/Data/EnumMapMap/Lazy.hs
@@ -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
diff --git a/Data/EnumMapMap/Strict.hs b/Data/EnumMapMap/Strict.hs
--- a/Data/EnumMapMap/Strict.hs
+++ b/Data/EnumMapMap/Strict.hs
@@ -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
diff --git a/Data/EnumMapSet.hs b/Data/EnumMapSet.hs
--- a/Data/EnumMapSet.hs
+++ b/Data/EnumMapSet.hs
@@ -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
diff --git a/Data/EnumMapSet/Base.hs b/Data/EnumMapSet/Base.hs
new file mode 100644
--- /dev/null
+++ b/Data/EnumMapSet/Base.hs
@@ -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)
diff --git a/enummapmap.cabal b/enummapmap.cabal
--- a/enummapmap.cabal
+++ b/enummapmap.cabal
@@ -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
diff --git a/test/EnumMapMapVsIntMap.hs b/test/EnumMapMapVsIntMap.hs
--- a/test/EnumMapMapVsIntMap.hs
+++ b/test/EnumMapMapVsIntMap.hs
@@ -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)
diff --git a/test/EnumMapSetVsIntSet.hs b/test/EnumMapSetVsIntSet.hs
--- a/test/EnumMapSetVsIntSet.hs
+++ b/test/EnumMapSetVsIntSet.hs
@@ -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" $
diff --git a/test/UnitEnumMapMap.hs b/test/UnitEnumMapMap.hs
--- a/test/UnitEnumMapMap.hs
+++ b/test/UnitEnumMapMap.hs
@@ -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
+