diff --git a/benchmark-gauge/Main.hs b/benchmark-gauge/Main.hs
--- a/benchmark-gauge/Main.hs
+++ b/benchmark-gauge/Main.hs
@@ -29,6 +29,13 @@
       , bench "primitive-lifted-lifted" $ whnf (DMLL.foldlWithKey' reduction 0) bigLiftedMap
       , bench "containers-map" $ whnf (M.foldlWithKey' reduction 0) bigContainersMap
       ]
+    , bgroup "fromList"
+      [ bgroup "primitive-unboxed-unboxed" 
+        [ bench "20" $ whnf DMUU.fromList randomKeyValue20
+        , bench "200" $ whnf DMUU.fromList randomKeyValue200
+        , bench "2000" $ whnf DMUU.fromList randomKeyValue2000
+        ]
+      ]
     ]
   , bgroup "Set"
     [ bgroup "lookup" 
@@ -124,6 +131,22 @@
 
 ascArray2000 :: [Word]
 ascArray2000 = take 2000 (enumFrom 0)
+
+randomKeyValue20 :: [(Word,Word)]
+randomKeyValue20 = take 20 $ zip
+  (randoms (mkStdGen 75843))
+  (randoms (mkStdGen 4632465))
+
+randomKeyValue200 :: [(Word,Word)]
+randomKeyValue200 = take 200 $ zip
+  (randoms (mkStdGen 75843))
+  (randoms (mkStdGen 4632465))
+
+randomKeyValue2000 :: [(Word,Word)]
+randomKeyValue2000 = take 2000 $ zip
+  (randoms (mkStdGen 75843))
+  (randoms (mkStdGen 4632465))
+
 
 randomArray20 :: [Word]
 randomArray20 = take 20 (randoms (mkStdGen 75843))
diff --git a/primitive-containers.cabal b/primitive-containers.cabal
--- a/primitive-containers.cabal
+++ b/primitive-containers.cabal
@@ -1,6 +1,10 @@
+cabal-version: 2.0
 name: primitive-containers
-version: 0.2.0
-description: Please see the README on Github at <https://github.com/andrewthad/primitive-containers>
+version: 0.3.0
+synopsis: containers backed by arrays
+description:
+  Containers backed by flat arrays. Updates require rebuilding the
+  entire structure, but lookups are cache coherent.
 homepage: https://github.com/andrewthad/primitive-containers
 bug-reports: https://github.com/andrewthad/primitive-containers/issues
 author: Andrew Martin
@@ -9,7 +13,6 @@
 license: BSD3
 license-file: LICENSE
 build-type: Simple
-cabal-version: >= 2.0
 
 extra-source-files:
     ChangeLog.md
@@ -26,10 +29,19 @@
       base >=4.9 && <5
     , primitive >= 0.6.4
     , primitive-sort >= 0.1 && < 0.2
-    , contiguous >= 0.2 && < 0.3
+    , contiguous >= 0.3 && < 0.4
+    , hashable >= 1.2.5
+    , deepseq >= 1.4
+      -- move these five out when we kick out dependent maps 
+    , quantification >= 0.5.0 && < 0.6
+    , aeson >= 1.0 && < 1.5
+    , unordered-containers >= 0.2.8.0
+    , vector >= 0.11 && < 0.13
+    , text >= 1.2 && < 1.3
   exposed-modules:
-    Data.Diet.Map.Lifted.Lifted
-    Data.Diet.Map.Unboxed.Lifted
+    Data.Continuous.Set.Lifted
+    Data.Diet.Map.Strict.Lifted.Lifted
+    Data.Diet.Map.Strict.Unboxed.Lifted
     Data.Diet.Set
     Data.Diet.Set.Lifted
     Data.Diet.Set.Unboxed
@@ -38,19 +50,33 @@
     Data.Map.Unboxed.Lifted
     Data.Map.Unboxed.Unboxed
     Data.Map.Unboxed.Unlifted
+    Data.Map.Unlifted.Unboxed
+    Data.Map.Unlifted.Lifted
     Data.Set.Lifted
     Data.Set.Unboxed
     Data.Set.Unlifted
-    Data.Map.Subset.Lifted
+    Data.Map.Subset.Strict.Lifted
+    Data.Map.Subset.Strict.Unlifted
+    Data.Map.Subset.Lazy.Lifted
+    Data.Map.Subset.Lazy.Unlifted
+    Data.Dependent.Map.Class
+    Data.Dependent.Map.Internal
+    Data.Dependent.Map.Lifted.Lifted
+    Data.Dependent.Map.Unlifted.Lifted
+    Data.Dependent.Map.Unboxed.Lifted
   other-modules:
     Data.Concatenation
-    Data.Diet.Map.Internal
+    Data.Diet.Map.Strict.Internal
     Data.Diet.Set.Internal
+    Data.Continuous.Set.Internal
     Data.Diet.Unbounded.Set.Internal
     Data.Map.Internal
-    Data.Map.Subset.Internal
+    Data.Map.Subset.Strict.Internal
+    Data.Map.Subset.Lazy.Internal
     Data.Set.Internal
     Data.Set.Lifted.Internal
+    Data.Set.Unboxed.Internal
+    Data.Set.Unlifted.Internal
   ghc-options: -O2 -Wall
   default-language: Haskell2010
 
@@ -60,13 +86,18 @@
   main-is: Main.hs
   build-depends:
       base
+    , HUnit
     , QuickCheck
-    , containers
+    , aeson
+    , containers >= 0.5.10
     , primitive
     , primitive-containers
+    , quantification >= 0.4
     , quickcheck-classes >= 0.4.12
     , tasty
+    , tasty-hunit
     , tasty-quickcheck
+    , text
   ghc-options: -Wall -O2
   default-language: Haskell2010
 
diff --git a/src/Data/Continuous/Set/Internal.hs b/src/Data/Continuous/Set/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Continuous/Set/Internal.hs
@@ -0,0 +1,461 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedTuples #-}
+module Data.Continuous.Set.Internal
+  ( Set(..)
+  , Inclusivity(..)
+  , empty
+  , universe
+  , null
+  , universal
+  , singleton
+  , append
+  , member
+  , equals
+  , showsPrec
+  ) where
+
+import Prelude hiding (lookup,showsPrec,concat,map,foldr,negate,null)
+
+import Control.Monad.ST (ST,runST)
+import Data.Bool (bool)
+import Data.Word (Word8)
+import Data.Primitive.Contiguous (Contiguous,Element,Mutable)
+import Data.Primitive (PrimArray,MutablePrimArray)
+import Data.Bits (unsafeShiftL,unsafeShiftR,(.|.),(.&.))
+import qualified Data.Foldable as F
+import qualified Prelude as P
+import qualified Data.Primitive.Contiguous as I
+import qualified Data.Concatenation as C
+
+-- Although the data constructor for this type is exported,
+-- it isn't needed by anything in the continuous Set modules. It is needed
+-- by the continuous Map modules to implement conversion functions.
+--
+-- All ranges in the set must be in order. Also, the set containing
+-- everything must be represented with SetAll.
+data Set arr a = Set
+  -- (Maybe (Inclusivity,a)) -- negative infinity upper bound
+  !(arr a) -- pairs of keys, last two keys are neg-inf upper and pos-inf lower, in that order
+  !(PrimArray Word8) -- pairs of inclusive/exclusive, last element is edge information
+  -- (Maybe (Inclusivity,a)) -- positive infinite lower bound
+
+-- note: do not reorder these data constructors. Functions in
+-- this module rely on the generated Ord instance.
+data Inclusivity = Exclusive | Inclusive
+  deriving (Eq,Ord,Show,Read)
+
+data Edge
+  = EdgeInclusive
+  | EdgeExclusive
+  | EdgeAbsent
+  | EdgeUniversal
+
+equals :: (Contiguous arr, Element arr a, Eq a) => Set arr a -> Set arr a -> Bool
+equals (Set keys1 incs1) (Set keys2 incs2) =
+  I.equals keys1 keys2 && incs1 == incs2
+
+empty :: Contiguous arr => Set arr a
+empty = Set I.empty $ runST $ do
+  marr <- I.new 1
+  I.write marr 0 (edgePairToWord8 EdgeAbsent EdgeAbsent)
+  I.unsafeFreeze marr
+
+universe :: Contiguous arr => Set arr a
+universe = Set I.empty $ runST $ do
+  marr <- I.new 1
+  I.write marr 0 (edgePairToWord8 EdgeUniversal EdgeUniversal)
+  I.unsafeFreeze marr
+
+-- If the keys are null, then we know that there is only one
+-- element in the inclusivity array.
+null :: Contiguous arr => Set arr a -> Bool
+null (Set keys incs) = I.null keys
+  && I.index incs 0 == edgePairToWord8 EdgeAbsent EdgeAbsent
+
+universal :: Contiguous arr => Set arr a -> Bool
+universal (Set keys incs) = I.null keys
+  && I.index incs 0 == edgePairToWord8 EdgeUniversal EdgeUniversal
+
+singleton :: (Contiguous arr, Element arr a, Ord a)
+  => Maybe (Inclusivity,a) -- ^ lower bound, @Nothing@ means @-∞@
+  -> Maybe (Inclusivity,a) -- ^ upper bound, @Nothing@ means @+∞@
+  -> Set arr a
+singleton Nothing Nothing = universe
+singleton Nothing (Just (incHi,hi)) = runST $ do
+  keys <- I.replicateM 1 hi >>= I.unsafeFreeze
+  incs <- I.replicateM 1 (edgePairToWord8 (inclusivityToEdge incHi) EdgeAbsent) >>= I.unsafeFreeze
+  return (Set keys incs)
+singleton (Just (incLo,lo)) Nothing = runST $ do
+  keys <- I.replicateM 1 lo >>= I.unsafeFreeze
+  incs <- I.replicateM 1 (edgePairToWord8 EdgeAbsent (inclusivityToEdge incLo)) >>= I.unsafeFreeze
+  return (Set keys incs)
+singleton (Just (incLo,lo)) (Just (incHi,hi)) = case compare lo hi of
+  GT -> empty
+  EQ -> if incLo == Inclusive && incHi == Inclusive
+    then runST $ do
+      keys <- I.replicateM 2 lo >>= I.unsafeFreeze
+      incsMut <- I.new 2
+      I.write incsMut 0 (inclusivityPairToWord8 Inclusive Inclusive)
+      I.write incsMut 1 (edgePairToWord8 EdgeAbsent EdgeAbsent)
+      incs <- I.unsafeFreeze incsMut
+      return (Set keys incs)
+    else empty
+  LT -> unsafeSingleton incLo lo incHi hi
+
+-- the caller must ensure that lo is less than hi
+unsafeSingleton :: (Contiguous arr, Element arr a) => Inclusivity -> a -> Inclusivity -> a -> Set arr a
+unsafeSingleton incLo lo incHi hi = runST $ do
+  keysMut <- I.replicateM 2 lo
+  I.write keysMut 1 hi
+  keys <- I.unsafeFreeze keysMut
+  incsMut <- I.new 2
+  I.write incsMut 0 (inclusivityPairToWord8 incLo incHi)
+  I.write incsMut 1 (edgePairToWord8 EdgeAbsent EdgeAbsent)
+  incs <- I.unsafeFreeze incsMut
+  return (Set keys incs)
+
+except :: (Contiguous arr, Element arr a) => a -> Set arr a
+except x = Set keys incs where
+  keys = runST $ I.replicateM 2 x >>= I.unsafeFreeze
+  incs = runST $ do
+    m <- I.new 1
+    I.write m 0 (edgePairToWord8 EdgeExclusive EdgeExclusive)
+    I.unsafeFreeze m
+
+infinities :: (Contiguous arr, Element arr a, Ord a)
+  => Inclusivity
+  -> a -- ^ upper bound for negative infinity
+  -> Inclusivity
+  -> a -- ^ lower bound for positive infinite
+  -> Set arr a
+infinities negInfHiInc negInfHi posInfLoInc posInfLo =
+  case compare negInfHi posInfLo of
+    GT -> universe
+    EQ -> if negInfHiInc == Exclusive && posInfLoInc == Exclusive
+      then except negInfHi
+      else universe
+    LT -> unsafeInfinities negInfHiInc negInfHi posInfLoInc posInfLo
+
+-- the caller must ensure that the upper bound for neg-inf is
+-- less than the lower bound for pos inf
+unsafeInfinities :: (Contiguous arr, Element arr a) => Inclusivity -> a -> Inclusivity -> a -> Set arr a
+unsafeInfinities negInfHiInc negInfHi posInfLoInc posInfLo = runST $ do
+  keysMut <- I.replicateM 2 negInfHi
+  I.write keysMut 1 posInfLo
+  keys <- I.unsafeFreeze keysMut
+  incsMut <- I.new 1
+  I.write incsMut 0 (edgePairToWord8 (inclusivityToEdge negInfHiInc) (inclusivityToEdge posInfLoInc))
+  incs <- I.unsafeFreeze incsMut
+  return (Set keys incs)
+
+append :: forall arr a. (Ord a, Contiguous arr, Element arr a) => Set arr a -> Set arr a -> Set arr a
+append s1@(Set keys1 incs1) s2@(Set keys2 incs2)
+  | null s1 = s2
+  | null s2 = s1
+  | universal s1 = s1
+  | universal s2 = s2
+  | pairsCount1 == 0 && pairsCount2 == 0 = case lowerPair1 of
+      Nothing -> case upperPair1 of
+        Nothing -> error (errMsg 9)
+        Just (posInfLoInc1,posInfLo1) -> case lowerPair2 of
+          Nothing -> case upperPair2 of
+            Just (posInfLoInc2,posInfLo2) -> case compare posInfLo1 posInfLo2 of
+              EQ -> if posInfLoInc1 > posInfLoInc2 then s1 else s2
+              GT -> s2
+              LT -> s1
+      Just (negInfHiInc1,negInfHi1) -> case upperPair1 of
+        Nothing -> case lowerPair2 of
+          Nothing -> case upperPair2 of
+            Nothing -> error (errMsg 1)
+            Just (posInfLoInc2,posInfLo2) ->
+              case compare negInfHi1 posInfLo2 of
+                GT -> universe
+                EQ -> if negInfHiInc1 == Inclusive || posInfLoInc2 == Inclusive
+                  then universe
+                  else except negInfHi1
+                LT -> unsafeInfinities negInfHiInc1 negInfHi1 posInfLoInc2 posInfLo2
+          Just (negInfHiInc2,negInfHi2) -> case upperPair2 of
+            Nothing -> case compare negInfHi1 negInfHi2 of
+              EQ -> if negInfHiInc1 > negInfHiInc2 then s1 else s2
+              GT -> s1
+              LT -> s2
+            Just (posInfLoInc2,posInfLo2) -> case compare negInfHi1 negInfHi2 of
+              LT -> s2
+              EQ -> if negInfHiInc1 > negInfHiInc2
+                then infinities negInfHiInc1 negInfHi1 posInfLoInc2 posInfLo2
+                else s2
+              GT -> infinities negInfHiInc1 negInfHi1 posInfLoInc2 posInfLo2
+  | otherwise = runST $ do
+      let maxSz = pairsCount1 + pairsCount2 + 1
+      keysMut <- I.new (maxSz * 2)
+      incsMut <- I.new maxSz
+      case lowerPairRes of
+        Just (negInfHiIncOriginal,negInfHiOriginal) -> do
+          let (negInfHiIncFinal,negInfHiFinal,ixInit1,ixInit2) = eatFromNegativeInfinity negInfHiIncOriginal negInfHiOriginal keys1 incs1 pairsCount1 keys2 incs2 pairsCount2
+          case upperPairRes of
+            Just (posInfLoIncOriginal,posInfLoOriginal) -> do
+              let (posInfLoIncFinal,posInfLoFinal,ixLast1,ixLast2) = eatFromPositiveInfinity posInfLoIncOriginal posInfLoOriginal keys1 incs1 pairsCount1 keys2 incs2 pairsCount2
+              finalIx <- go keysMut incsMut ixInit1 ixLast1 ixInit2 ixLast2 0 negInfHiIncFinal negInfHiFinal
+              I.write incsMut finalIx (edgePairToWord8 (inclusivityToEdge negInfHiIncFinal) (inclusivityToEdge posInfLoIncFinal))
+              I.write keysMut (finalIx * 2) negInfHiFinal
+              I.write keysMut (finalIx * 2 + 1) posInfLoFinal
+              keysFrozen <- I.resize keysMut (finalIx * 2 + 2) >>= I.unsafeFreeze
+              incsFrozen <- I.resize incsMut (finalIx * 1) >>= I.unsafeFreeze
+              return (Set keysFrozen incsFrozen)
+            Nothing -> error (errMsg 102)
+        Nothing -> error (errMsg 101)
+  where
+  -- do not make these patterns strict
+  (lowerPair1,upperPair1,pairsCount1) = edges keys1 incs1
+  (lowerPair2,upperPair2,pairsCount2) = edges keys2 incs2
+  lowerPairRes = combineNegativeInfinities lowerPair1 lowerPair2
+  upperPairRes = combineNegativeInfinities upperPair1 upperPair2
+  go :: forall s.
+        Mutable arr s a
+     -> MutablePrimArray s Word8
+     -> Int -- index 1
+     -> Int -- index 1 last
+     -> Int -- index 2
+     -> Int -- index 2 last
+     -> Int -- destination index
+     -> Inclusivity -- previous inclusivity
+     -> a -- previous destination value
+     -> ST s Int -- returns size
+  go !keysMut !incsMut !ix1 !ixLast1 !ix2 !ixLast2 !ixDst inc a = if ix1 <= ixLast1
+    then error (errMsg 103)
+    else if ix2 <= ixLast2
+      then error (errMsg 104)
+      else case upperPair1 of
+        Just _ -> error (errMsg 105)
+        Nothing -> case upperPair2 of
+          Nothing -> return ixDst
+
+combineNegativeInfinities :: Ord a => Maybe (Inclusivity,a) -> Maybe (Inclusivity,a) -> Maybe (Inclusivity,a)
+combineNegativeInfinities Nothing Nothing = Nothing
+combineNegativeInfinities Nothing x@(Just _) = x
+combineNegativeInfinities x@(Just _) Nothing = x
+combineNegativeInfinities (Just (xinc,x)) (Just (yinc,y)) = case compare x y of
+  GT -> Just (xinc,x)
+  LT -> Just (yinc,y)
+  EQ -> Just (max xinc yinc,y)
+      
+eatFromPositiveInfinity ::
+     Inclusivity -- inclusivity for positive infinity
+  -> a -- lower bound for positive infinity
+  -> arr a -- set 1
+  -> PrimArray Word8
+  -> Int -- pairs in set 1 
+  -> arr a -- set 2
+  -> PrimArray Word8
+  -> Int -- pairs in set 2
+  -> (Inclusivity,a,Int,Int) -- index for set 1 and set2, lower bound for positive infinity
+eatFromPositiveInfinity = error (errMsg 110)
+
+eatFromNegativeInfinity :: (Contiguous arr, Element arr a, Ord a)
+  => Inclusivity -- inclusivity for negative infinity
+  -> a -- upper bound for negative infinity
+  -> arr a -- set 1
+  -> PrimArray Word8
+  -> Int -- pairs in set 1 
+  -> arr a -- set 2
+  -> PrimArray Word8
+  -> Int -- pairs in set 2
+  -> (Inclusivity,a,Int,Int) -- index for set 1 and set2, upper bound for negative infinity
+eatFromNegativeInfinity negInfInc0 negInfHi0 keys1 incs1 sz1 keys2 incs2 sz2 = go negInfInc0 negInfHi0 0 0
+  where
+  go negInfHiInc negInfHi !ix1 !ix2 = if ix1 < sz1
+    then error (errMsg 111)
+    else if ix2 < sz2
+      then let (# lo #) = I.index# keys2 (ix2 * 2)
+               (# hi #) = I.index# keys2 (ix2 * 2 + 1)
+               (loInc,hiInc) = indexInclusivityPair incs2 ix2
+            in case compare negInfHi lo of
+                 LT -> (negInfHiInc,negInfHi,ix1,ix2)
+                 GT -> case compare negInfHi hi of
+                   LT -> go hiInc hi ix1 (ix2 + 1)
+                   GT -> go negInfHiInc negInfHi ix1 (ix2 + 1)
+                   EQ -> go (max hiInc negInfHiInc) hi ix1 (ix2 + 1)
+                 EQ -> if negInfHiInc == Exclusive && loInc == Exclusive
+                   then (Exclusive,negInfHi,ix1,ix2)
+                   else case compare negInfHi hi of
+                     LT -> go hiInc hi ix1 (ix2 + 1)
+                     GT -> go negInfHiInc negInfHi ix1 (ix2 + 1)
+                     EQ -> go (max hiInc negInfHiInc) hi ix1 (ix2 + 1)
+      else (negInfHiInc,negInfHi,ix1,ix2)
+
+inclusivityToEdge :: Inclusivity -> Edge
+inclusivityToEdge Inclusive = EdgeInclusive
+inclusivityToEdge Exclusive = EdgeExclusive
+
+inclusivityToWord8 :: Inclusivity -> Word8
+inclusivityToWord8 Inclusive = 0
+inclusivityToWord8 Exclusive = 1
+
+inclusivityPairToWord8 :: Inclusivity -> Inclusivity -> Word8
+inclusivityPairToWord8 a b =
+      unsafeShiftL (inclusivityToWord8 a) 1
+  .|. inclusivityToWord8 b
+
+word8ToInclusivity :: Word8 -> Inclusivity
+word8ToInclusivity 0 = Inclusive
+word8ToInclusivity _ = Exclusive
+
+indexInclusivityPair :: PrimArray Word8 -> Int -> (Inclusivity,Inclusivity)
+indexInclusivityPair xs ix = case I.index xs ix of
+  0 -> (Inclusive,Inclusive)
+  1 -> (Inclusive,Exclusive)
+  2 -> (Exclusive,Inclusive)
+  _ -> (Exclusive,Exclusive)
+
+edgeToWord8 :: Edge -> Word8
+edgeToWord8 EdgeInclusive = 0
+edgeToWord8 EdgeExclusive = 1
+edgeToWord8 EdgeAbsent = 2
+edgeToWord8 EdgeUniversal = 3
+
+word8ToEdge :: Word8 -> Edge
+word8ToEdge x = case x of
+  0 -> EdgeInclusive
+  1 -> EdgeExclusive
+  2 -> EdgeAbsent
+  _ -> EdgeUniversal
+
+edgePairToWord8 :: Edge -> Edge -> Word8
+edgePairToWord8 a b = unsafeShiftL (edgeToWord8 a) 2 .|. edgeToWord8 b
+
+edgeMetadata :: PrimArray Word8 -> (Edge,Edge)
+edgeMetadata xs = (word8ToEdge (unsafeShiftR w 2), word8ToEdge (0b00000011 .&. w))
+  where
+  w = I.index xs (I.size xs - 1)
+
+-- please check for EdgeUniversal before calling this function. The
+-- resulting triple includes the size of the keys array in pairs. The
+-- divisions used internally here should always divide two evenly.
+edges :: (Contiguous arr, Element arr a)
+  => arr a
+  -> PrimArray Word8
+  -> (Maybe (Inclusivity,a), Maybe (Inclusivity,a),Int)
+edges keys incs = case edgeMetadata incs of
+  (lower,upper) -> case lower of
+    EdgeUniversal -> error (errMsg 2)
+    EdgeAbsent -> case upper of
+      EdgeInclusive -> (Nothing,Just (Inclusive,I.index keys (sz - 1)),div (sz - 1) 2)
+      EdgeExclusive -> (Nothing,Just (Exclusive,I.index keys (sz - 1)),div (sz - 1) 2)
+      EdgeAbsent -> (Nothing,Nothing,div sz 2)
+      _ -> error (errMsg 3)
+    EdgeInclusive -> case upper of
+      EdgeInclusive -> (Just (Inclusive,I.index keys (sz - 2)),Just (Inclusive,I.index keys (sz - 1)),div (sz - 2) 2)
+      EdgeExclusive -> (Just (Inclusive,I.index keys (sz - 2)),Just (Exclusive,I.index keys (sz - 1)),div (sz - 2) 2)
+      EdgeAbsent -> (Just (Inclusive,I.index keys (sz - 1)),Nothing,div (sz - 1) 2)
+      EdgeUniversal -> error (errMsg 4)
+    EdgeExclusive -> case upper of
+      EdgeInclusive -> (Just (Exclusive,I.index keys (sz - 2)),Just (Inclusive,I.index keys (sz - 1)),div (sz - 2) 2)
+      EdgeExclusive -> (Just (Exclusive,I.index keys (sz - 2)),Just (Exclusive,I.index keys (sz - 1)),div (sz - 2) 2)
+      EdgeAbsent -> (Just (Exclusive,I.index keys (sz - 1)),Nothing,div (sz - 1) 2)
+      EdgeUniversal -> error (errMsg 5)
+  where
+  sz = I.size keys
+
+member :: forall arr a. (Contiguous arr, Element arr a, Ord a)
+  => a
+  -> Set arr a
+  -> Bool
+member val (Set keys incs) = case edges keys incs of
+  (!mnegInfHi,!mposInfLo,!n) ->
+    case mnegInfHi of
+      Nothing -> case mposInfLo of
+        Nothing -> go 0 (n - 1)
+        Just (!posInfLoInc,!posInfLo) -> case compare val posInfLo of
+          GT -> True
+          LT -> go 0 (n - 1)
+          EQ -> posInfLoInc == Inclusive
+      Just (!negInfHiInc,!negInfHi) -> case mposInfLo of
+        Nothing -> case compare val negInfHi of
+          LT -> True
+          GT -> go 0 (n - 1)
+          EQ -> negInfHiInc == Inclusive
+        Just (!posInfLoInc,!posInfLo) -> case compare val posInfLo of
+          GT -> True
+          LT -> case compare val negInfHi of
+            GT -> go 0 (n - 1)
+            LT -> True
+            EQ -> negInfHiInc == Inclusive
+          EQ -> posInfLoInc == Inclusive
+  where
+  go !start !end = if end <= start
+    then if end == start
+      then 
+        let !(# valLo #) = I.index# keys (2 * start)
+            !(# valHi #) = I.index# keys (2 * start + 1)
+         in case indexInclusivityPair incs start of
+              (Exclusive,Exclusive) -> val > valLo && val < valHi
+              (Exclusive,Inclusive) -> val > valLo && val <= valHi
+              (Inclusive,Exclusive) -> val >= valLo && val < valHi
+              (Inclusive,Inclusive) -> val >= valLo && val <= valHi
+      else False
+    else
+      let !mid = div (end + start + 1) 2
+          !valLo = I.index keys (2 * mid)
+       in case P.compare val valLo of
+            LT -> go start (mid - 1)
+            EQ -> True
+            GT -> go mid end
+{-# INLINEABLE member #-}
+
+errMsg :: Int -> String
+errMsg n = "Data.Continuous.Set.Internal: invariant " ++ show n ++ " violated"
+
+toPairs :: (Contiguous arr, Element arr a) => Int -> Set arr a -> [(Inclusivity,a,Inclusivity,a)]
+toPairs n (Set keys incs) = go 0 where
+  go !ix = if ix < n
+    then
+      let (incLo,incHi) = indexInclusivityPair incs ix
+          lo = I.index keys (2 * ix)
+          hi = I.index keys (2 * ix + 1)
+       in (incLo,lo,incHi,hi) : go (ix + 1)
+    else []
+
+showsPrec :: (Contiguous arr, Element arr a, Show a)
+  => Int
+  -> Set arr a
+  -> ShowS
+showsPrec _ s@(Set keys incs)
+  | null s = showString "{}"
+  | universal s = showString "{(-∞,+∞)}"
+  | otherwise = showChar '{' . showListInf shows lowerPair (toPairs pairsCount s) upperPair . showChar '}'
+  where
+  -- do not make these patterns strict
+  (lowerPair,upperPair,pairsCount) = edges keys incs
+
+showListInf :: (a -> ShowS) -> Maybe (Inclusivity,a) -> [(Inclusivity,a,Inclusivity,a)] -> Maybe (Inclusivity,a) -> ShowS
+showListInf showx mnegInfHi [] mposInfLo s = case mnegInfHi of
+  Nothing -> case mposInfLo of
+    Nothing -> s
+    Just (posInfLoInc,posInfLo) -> showPosInfLo showx posInfLoInc posInfLo s
+  Just (negInfHiInc,negInfHi) -> case mposInfLo of
+    Nothing -> showNegInfHi showx negInfHiInc negInfHi s
+    Just (posInfLoInc,posInfLo) -> showChar '{'
+      $ showNegInfHi showx negInfHiInc negInfHi
+      $ showChar ','
+      $ showPosInfLo showx posInfLoInc posInfLo
+      $ showChar '}'
+      $ s
+showListInf showx mnegInfHi ((ainc0,a0,binc0,b0):xs) mposInfLo s =
+  maybe id (\(negInfHiInc,negInfHi) s' -> showNegInfHi showx negInfHiInc negInfHi (',' : s')) mnegInfHi (case ainc0 of {Inclusive -> '[';Exclusive -> '('} : showx a0 (',' : showx b0 (case binc0 of {Inclusive -> ']'; Exclusive -> ')'} : showl xs)))
+  where
+    showl [] = maybe id (\(posInfLoInc,posInfLo) -> showChar ',' . showPosInfLo showx posInfLoInc posInfLo) mposInfLo (']' : s)
+    showl ((ainc,a,binc,b):ys) = ',' : case ainc of {Inclusive -> '[';Exclusive -> '('} : showx a (',' : showx b (case binc of {Inclusive -> ']'; Exclusive -> ')'} : showl ys))
+
+showNegInfHi :: (a -> ShowS) -> Inclusivity -> a -> ShowS
+showNegInfHi showx inc x s = "(-∞," ++ showx x ((case inc of { Inclusive -> ']'; Exclusive -> ')'} : s))
+
+showPosInfLo :: (a -> ShowS) -> Inclusivity -> a -> ShowS
+showPosInfLo showx inc x s = case inc of { Inclusive -> '['; Exclusive -> '('} : (showx x (",+∞)" ++ s))
+
diff --git a/src/Data/Continuous/Set/Lifted.hs b/src/Data/Continuous/Set/Lifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Continuous/Set/Lifted.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# OPTIONS_GHC -O2 #-}
+module Data.Continuous.Set.Lifted
+  ( Set
+  , Inclusivity(..)
+  , singleton
+  , member
+  , empty
+  , universe
+  , null
+  , universal
+  ) where
+
+import Prelude hiding (lookup,map,foldr,negate,null)
+
+import Data.Semigroup (Semigroup)
+import Data.Primitive (Array)
+import Data.Continuous.Set.Internal (Inclusivity(..))
+import qualified Data.Semigroup as SG
+import qualified Data.Continuous.Set.Internal as I
+
+-- | A diet set. Currently, the data constructor for this type is
+-- exported. Please do not use it. It will be moved to an internal
+-- module at some point.
+newtype Set a = Set (I.Set Array a)
+
+-- | /O(1)/ Create a continuous interval set with a single interval.
+singleton :: Ord a
+  => Maybe (Inclusivity,a) -- ^ lower bound
+  -> Maybe (Inclusivity,a) -- ^ upper bound
+  -> Set a
+singleton lo hi = Set (I.singleton lo hi)
+
+-- | /O(log n)/ Returns @True@ if the element is a member of the continuous
+-- interval set.
+member :: Ord a => a -> Set a -> Bool
+member a (Set s) = I.member a s
+
+empty :: Set a
+empty = Set I.empty
+
+universe :: Set a
+universe = Set I.universe
+
+null :: Set a -> Bool
+null (Set s) = I.null s
+
+universal :: Set a -> Bool
+universal (Set s) = I.universal s
+
+instance Show a => Show (Set a) where
+  showsPrec p (Set s) = I.showsPrec p s
+
+instance Eq a => Eq (Set a) where
+  Set x == Set y = I.equals x y
+
+instance (Ord a) => Semigroup (Set a) where
+  Set x <> Set y = Set (I.append x y)
+
+instance (Ord a, Enum a) => Monoid (Set a) where
+  mempty = Set I.empty
+  mappend = (SG.<>)
+
diff --git a/src/Data/Dependent/Map/Class.hs b/src/Data/Dependent/Map/Class.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Dependent/Map/Class.hs
@@ -0,0 +1,78 @@
+{-# language ConstraintKinds #-}
+{-# language CPP #-}
+{-# language ExistentialQuantification #-}
+{-# language FlexibleContexts #-}
+{-# language FlexibleInstances #-}
+{-# language MagicHash #-}
+{-# language MultiParamTypeClasses #-}
+{-# language PolyKinds #-}
+{-# language RankNTypes #-}
+{-# language ScopedTypeVariables #-}
+{-# language TypeFamilies #-}
+{-# language TypeFamilyDependencies #-}
+{-# language TypeInType #-}
+{-# language UnboxedTuples #-}
+
+-- I really do not like the typeclasses defined in this module.
+-- With the QuantifiedConstraints extension (in GHC 8.6), we should
+-- be able to get rid of this entire module. But we will want to
+-- wait a while before doing that.
+module Data.Dependent.Map.Class
+  ( Apply(..)
+  , Universally(..)
+  , ApplyUniversally(..)
+  ) where
+
+import Data.Kind (Type,Constraint)
+import Data.Proxy (Proxy(..))
+import Data.Exists (OrdForall(..),EqForall(..),PrimForall(..))
+import Data.Primitive (Prim(..))
+import Data.Primitive.Contiguous (Always)
+import Data.Primitive.UnliftedArray (PrimUnlifted(..))
+import GHC.Exts
+
+newtype Apply f a = Apply (f a)
+
+class ApplyUniversally (f :: k -> Type) (x :: Type -> Constraint) where
+  applyUniversallyLifted :: forall a y. Proxy f -> Proxy x -> Proxy a -> (x (f a) => y) -> y
+#if MIN_VERSION_base(4,10,0) 
+  applyUniversallyUnlifted :: forall a (y :: TYPE 'UnliftedRep). Proxy f -> Proxy x -> Proxy a -> (x (f a) => y) -> y
+#else
+  applyUniversallyUnlifted :: forall a (y :: TYPE 'PtrRepUnlifted). Proxy f -> Proxy x -> Proxy a -> (x (f a) => y) -> y
+#endif
+
+class Universally (f :: k -> Type) (x :: Type -> Constraint) where
+  universally :: Proxy f -> Proxy x -> Proxy a -> (x (Apply f a) => y) -> y
+
+instance ApplyUniversally f PrimUnlifted => PrimUnlifted (Apply f a) where
+  toArrayArray# (Apply v) = applyUniversallyUnlifted (Proxy :: Proxy f) (Proxy :: Proxy PrimUnlifted) (Proxy :: Proxy a) (toArrayArray# v)
+  fromArrayArray# a = applyUniversallyLifted (Proxy :: Proxy f) (Proxy :: Proxy PrimUnlifted) (Proxy :: Proxy a) (fromArrayArray# a)
+
+instance EqForall f => Eq (Apply f a) where
+  Apply x == Apply y = eqForall x y
+
+instance OrdForall f => Ord (Apply f a) where
+  compare (Apply x) (Apply y) = compareForall x y
+
+instance PrimForall f => Prim (Apply f a) where
+  sizeOf# _ = sizeOfForall# (proxy# :: Proxy# f)
+  alignment# _ = alignmentForall# (proxy# :: Proxy# f)
+  indexByteArray# = coerce (indexByteArrayForall# :: ByteArray# -> Int# -> f a)
+  readByteArray# = coerce (readByteArrayForall# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, f a #) )
+  writeByteArray# = coerce (writeByteArrayForall# :: MutableByteArray# s -> Int# -> f a -> State# s -> State# s )
+  setByteArray# = coerce (setByteArrayForall# :: MutableByteArray# s -> Int# -> Int# -> f a -> State# s -> State# s )
+  indexOffAddr# = coerce (indexOffAddrForall# :: Addr# -> Int# -> f a)
+  readOffAddr# = coerce (readOffAddrForall# :: Addr# -> Int# -> State# s -> (# State# s, f a #) )
+  writeOffAddr# = coerce (writeOffAddrForall# :: Addr# -> Int# -> f a -> State# s -> State# s)
+  setOffAddr# = coerce (setOffAddrForall# :: Addr# -> Int# -> Int# -> f a -> State# s -> State# s)
+
+instance Universally f Always where
+  universally _ _ _ y = y
+
+instance ApplyUniversally f Always where
+  applyUniversallyLifted _ _ _ y = y
+  applyUniversallyUnlifted _ _ _ y = y
+
+instance ApplyUniversally f PrimUnlifted => Universally f PrimUnlifted where
+  universally _ _ _ y = y
+
diff --git a/src/Data/Dependent/Map/Internal.hs b/src/Data/Dependent/Map/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Dependent/Map/Internal.hs
@@ -0,0 +1,401 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Data.Dependent.Map.Internal
+  ( Map(..)
+  , empty
+  , null
+  , singleton
+  , lookup
+  , fromList
+  , fromListN
+  , map
+  , mapWithKey
+  , mapMaybe
+  , mapMaybeWithKey
+  , appendRightBiased
+  , append
+  , toList
+  , showsPrec
+  , equals
+  , compare
+  , unsafeFreezeZip
+  , toJSON
+  , parseJSON
+  , foldrWithKey
+  , foldlWithKeyM'
+  , foldMapWithKey
+  , traverseWithKey_
+  , size
+  ) where
+
+import Prelude hiding (lookup,showsPrec,compare,null,map)
+
+import Data.Dependent.Map.Class (Universally,Apply,ApplyUniversally)
+import Data.Primitive.Contiguous (Contiguous,Mutable,Element)
+import Control.Monad.ST (ST,runST)
+import Data.Proxy (Proxy(..))
+import GHC.Exts (Any,coerce)
+import Unsafe.Coerce (unsafeCoerce)
+import Data.Exists (OrdForallPoly(..),EqForallPoly(..),DependentPair(..),ShowForall,ToSing)
+import Data.Exists (ShowForeach,EqForeach,OrdForeach,ToJSONKeyForall,FromJSONForeach)
+import Data.Exists (ToJSONForall,ToJSONKeyFunctionForall,ToJSONForeach)
+import Data.Exists (FromJSONKeyExists,SemigroupForeach,Sing)
+import Data.Semigroup (Semigroup)
+import Data.Primitive.Sort (sortUniqueTaggedMutable)
+import Data.Kind (Type)
+import Data.Aeson (ToJSON,FromJSON)
+import Data.Text (Text)
+import qualified Data.Vector as V
+import qualified Data.Exists as EX
+import qualified Data.Aeson as AE
+import qualified Data.Aeson.Types as AET
+import qualified Data.HashMap.Strict as HM
+import qualified Prelude as P
+import qualified Data.Map.Internal as I
+import qualified Data.Primitive.Contiguous as I
+import qualified Data.Dependent.Map.Class as C
+import qualified Data.Map.Internal as M
+import qualified Data.Foldable as F
+
+newtype Map karr varr (k :: u -> Type) (v :: u -> Type) = Map (M.Map karr varr (Apply k Any) (v Any))
+
+empty :: (Contiguous karr, Contiguous varr) => Map karr varr k v
+empty = Map M.empty
+
+null :: forall karr varr k v. (Contiguous varr) => Map karr varr k v -> Bool
+null (Map m) = M.null m
+
+singleton :: forall karr varr k v a.
+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr))
+  => k a -> v a -> Map karr varr k v
+singleton k v = id
+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ Map (M.singleton (wrapKey k) (wrapValue (Proxy :: Proxy v) (Proxy :: Proxy a) v))
+
+toJSON :: forall karr varr k v.
+     (ToJSONKeyForall k, ToJSONForeach v, ToSing k, Contiguous karr, Contiguous varr,ApplyUniversally v (Element varr),Universally k (Element karr))
+  => Map karr varr k v
+  -> AE.Value
+toJSON (Map m) = id
+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ case EX.toJSONKeyForall :: ToJSONKeyFunctionForall k of
+      EX.ToJSONKeyValueForall toValue _ -> AE.Array $ V.fromListN
+        ( M.size m )
+        ( M.foldrWithKey
+          ( \(C.Apply k) v xs -> AE.toJSON (toValue k,EX.toJSONForeach (EX.toSing k) v) : xs
+          ) [] m
+        )
+      EX.ToJSONKeyTextForall toText _ -> AE.Object
+        ( M.foldlWithKey'
+          ( \hm (C.Apply k) v -> HM.insert (toText k) (EX.toJSONForeach (EX.toSing k) v) hm
+          ) HM.empty m
+        )
+
+parseJSON :: forall karr varr k v.
+     (FromJSONKeyExists k, ToSing k, OrdForallPoly k, FromJSONForeach v, Contiguous karr, Contiguous varr, ApplyUniversally v (Element varr),Universally k (Element karr),ApplyUniversally k (Element karr))
+  => AE.Value
+  -> AET.Parser (Map karr varr k v)
+parseJSON theValue =
+  case EX.fromJSONKeyExists :: AE.FromJSONKeyFunction (EX.Exists k) of
+    AE.FromJSONKeyCoerce _ -> error "Data.Dependent.Map.Internal.fromJSON: this cannot happen"
+    AE.FromJSONKeyText fromText -> AET.withObject "DependentMap"
+      (fmap fromList . HM.foldrWithKey (f1 fromText) (return []))
+      theValue
+    AE.FromJSONKeyTextParser fromText -> AET.withObject "DependentMap"
+      (fmap fromList . HM.foldrWithKey (f2 fromText) (return []))
+      theValue
+    AE.FromJSONKeyValue fromValue -> AET.withArray "DependentMap"
+      (fmap fromList . F.foldlM (f3 fromValue) [])
+      theValue
+  where
+  f1 :: (Text -> EX.Exists k) -> Text -> AE.Value -> AET.Parser [DependentPair k v] -> AET.Parser [DependentPair k v]
+  f1 fromText keyText valRaw m = case fromText keyText of
+    EX.Exists key -> do
+      let keySing = EX.toSing key
+      val <- EX.parseJSONForeach keySing valRaw
+      dm <- m
+      return (DependentPair key val : dm)
+  f2 :: (Text -> AET.Parser (EX.Exists k)) -> Text -> AE.Value -> AET.Parser [DependentPair k v] -> AET.Parser [DependentPair k v]
+  f2 fromText keyText valRaw m = do
+    EX.Exists key <- fromText keyText
+    let keySing = EX.toSing key
+    val <- EX.parseJSONForeach keySing valRaw
+    dm <- m
+    return (DependentPair key val : dm)
+  f3 :: (AE.Value -> AET.Parser (EX.Exists k)) -> [DependentPair k v] -> AE.Value -> AET.Parser [DependentPair k v]
+  f3 fromValue dm pairRaw = do
+    (keyRaw :: AE.Value,valRaw :: AE.Value) <- AE.parseJSON pairRaw
+    EX.Exists key <- fromValue keyRaw
+    let keySing = EX.toSing key
+    val <- EX.parseJSONForeach keySing valRaw
+    return (DependentPair key val : dm)
+
+
+        
+
+lookup :: forall karr varr k v a.
+     (OrdForallPoly k, Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr))
+  => k a
+  -> Map karr varr k v
+  -> Maybe (v a)
+{-# INLINABLE lookup #-}
+lookup k (Map m) = id
+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ case M.lookup (wrapKey k) m of
+      Nothing -> Nothing
+      Just v -> Just (unwrapValue (Proxy :: Proxy v) (Proxy :: Proxy a) v)
+
+appendWith :: forall karr varr k v.
+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k, ToSing k)
+  => (forall a. Sing a -> v a -> v a -> v a)
+  -> Map karr varr k v
+  -> Map karr varr k v
+  -> Map karr varr k v
+appendWith f (Map m1) (Map m2) = id
+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ Map (M.appendKeyWith (\(C.Apply k) v1 v2 -> f (EX.toSing k) v1 v2) m1 m2)
+
+append :: forall karr varr k v.
+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k, SemigroupForeach v, ToSing k)
+  => Map karr varr k v
+  -> Map karr varr k v
+  -> Map karr varr k v
+append = appendWith EX.appendForeach
+
+appendRightBiased :: forall karr varr k v.
+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k)
+  => Map karr varr k v
+  -> Map karr varr k v
+  -> Map karr varr k v
+appendRightBiased (Map m1) (Map m2) = id
+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ Map (M.appendRightBiased m1 m2)
+
+wrapKeyUnapplied :: f k -> f Any
+wrapKeyUnapplied = unsafeCoerce
+
+wrapKey :: f k -> Apply f Any
+wrapKey = unsafeCoerce
+
+wrapValue :: Proxy v -> Proxy a -> v a -> v Any
+wrapValue _ _ = unsafeCoerce
+
+unwrapValue :: Proxy v -> Proxy a -> v Any -> v a
+unwrapValue _ _ = unsafeCoerce
+
+unsafeCoerceMutableKeyArray ::
+     Mutable karr s (f Any)
+  -> Mutable karr s (Apply f Any)
+unsafeCoerceMutableKeyArray = unsafeCoerce
+
+fromList ::
+     (Contiguous karr, ApplyUniversally k (Element karr), Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k)
+  => [DependentPair k v]
+  -> Map karr varr k v
+fromList = fromListN 1
+
+fromListN ::
+     (Contiguous karr, ApplyUniversally k (Element karr), Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k)
+  => Int
+  -> [DependentPair k v]
+  -> Map karr varr k v
+{-# INLINABLE fromListN #-}
+fromListN n xs = runST $ do
+  (ks,vs) <- mutableArraysFromPairs (max n 1) xs
+  unsafeFreezeZip ks vs
+
+-- | This function is really unsafe. The user needs to use unsafeCoerce to even use it.
+unsafeFreezeZip :: forall karr varr k v s.
+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k)
+  => Mutable karr s (k Any)
+  -> Mutable varr s (v Any)
+  -> ST s (Map karr varr k v)
+{-# INLINABLE unsafeFreezeZip #-}
+unsafeFreezeZip keys0 vals0 = id
+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ fmap Map (M.unsafeFreezeZip (unsafeCoerceMutableKeyArray keys0) vals0)
+
+mutableArraysFromPairs :: forall karr varr k v s.
+     (Contiguous karr, ApplyUniversally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), OrdForallPoly k)
+  => Int -- must be at least one
+  -> [DependentPair k v]
+  -> ST s (Mutable karr s (k Any), Mutable varr s (v Any))
+{-# INLINABLE mutableArraysFromPairs #-}
+mutableArraysFromPairs n xs = id
+  $ C.applyUniversallyLifted (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ do
+    let go :: Int
+           -> Int
+           -> Mutable karr s (k Any)
+           -> Mutable varr s (v Any)
+           -> [DependentPair k v]
+           -> ST s (Int,Mutable karr s (k Any),Mutable varr s (v Any))
+        go !ix !_ !ks !vs [] = return (ix,ks,vs)
+        go !ix !len !ks !vs (DependentPair k v : ys) = if ix < len
+          then do
+            I.write ks ix (wrapKeyUnapplied k)
+            I.write vs ix (wrapValue (Proxy :: Proxy v) Proxy v)
+            go (ix + 1) len ks vs ys
+          else do
+            let len' = len * 2
+            ks' <- I.new len'
+            vs' <- I.new len'
+            I.copyMutable ks' 0 ks 0 len
+            I.copyMutable vs' 0 vs 0 len
+            I.write ks' ix (wrapKeyUnapplied k)
+            I.write vs' ix (wrapValue (Proxy :: Proxy v) Proxy v)
+            go (ix + 1) len' ks' vs' ys
+    ks0 <- I.new n
+    vs0 <- I.new n
+    (len,ks',vs') <- go 0 n ks0 vs0 xs
+    ksFinal <- I.resize ks' len
+    vsFinal <- I.resize vs' len
+    return (ksFinal,vsFinal)
+
+foldrWithKey :: forall karr varr k v b.
+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr))
+  => (forall a. k a -> v a -> b -> b)
+  -> b
+  -> Map karr varr k v
+  -> b
+foldrWithKey f z (Map m) = id
+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ M.foldrWithKey (unsafeCoerceRightFoldFunction f) z m
+
+foldMapWithKey :: forall karr varr k v m.
+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), Monoid m)
+  => (forall a. k a -> v a -> m)
+  -> Map karr varr k v
+  -> m
+foldMapWithKey f (Map m) = id
+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ M.foldMapWithKey (unsafeCoerceFoldMapFunction f) m
+
+traverseWithKey_ :: forall karr varr k v m b.
+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), Applicative m)
+  => (forall a. k a -> v a -> m b)
+  -> Map karr varr k v
+  -> m ()
+traverseWithKey_ f (Map m) = id
+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ M.traverseWithKey_ (unsafeCoerceFoldMapFunction f) m
+
+foldlWithKeyM' :: forall karr varr k v m b.
+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), Monad m)
+  => (forall a. b -> k a -> v a -> m b)
+  -> b
+  -> Map karr varr k v
+  -> m b
+foldlWithKeyM' f z (Map m) = id
+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ M.foldlWithKeyM' (unsafeCoerceLeftFoldFunctionM f) z m
+
+toList :: 
+     (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr))
+  => Map karr varr k v
+  -> [DependentPair k v]
+toList = foldrWithKey (\k v xs -> DependentPair k v : xs) []
+
+unsafeCoerceMapMaybeWithKeyFunction ::
+     (forall a. k a -> v a -> Maybe (w a))
+  -> Apply k Any -> v Any -> Maybe (w Any)
+unsafeCoerceMapMaybeWithKeyFunction = unsafeCoerce
+
+unsafeCoerceMapWithKeyFunction ::
+     (forall a. k a -> v a -> w a)
+  -> Apply k Any -> v Any -> w Any
+unsafeCoerceMapWithKeyFunction = unsafeCoerce
+
+unsafeCoerceLeftFoldFunctionM :: 
+     (forall a. b -> k a -> v a -> m b)
+  -> b -> Apply k Any -> v Any -> m b
+unsafeCoerceLeftFoldFunctionM = unsafeCoerce
+
+unsafeCoerceRightFoldFunction :: 
+     (forall a. k a -> v a -> b -> b)
+  -> Apply k Any -> v Any -> b -> b
+unsafeCoerceRightFoldFunction = unsafeCoerce
+
+unsafeCoerceFoldMapFunction :: 
+     (forall a. k a -> v a -> m)
+  -> Apply k Any -> v Any -> m
+unsafeCoerceFoldMapFunction = unsafeCoerce
+
+showsPrec :: (Contiguous karr, Universally k (Element karr), ShowForall k, ShowForeach v, ToSing k, Contiguous varr, ApplyUniversally v (Element varr))
+  => Int -> Map karr varr k v -> ShowS
+showsPrec p xs = showParen (p > 10) $
+  showString "fromList " . shows (toList xs)
+
+equals :: (Contiguous karr, Universally k (Element karr), EqForallPoly k, EqForeach v, ToSing k, Contiguous varr, ApplyUniversally v (Element varr))
+  => Map karr varr k v
+  -> Map karr varr k v
+  -> Bool
+equals a b = toList a == toList b
+
+compare :: (Contiguous karr, Universally k (Element karr), OrdForallPoly k, OrdForeach v, ToSing k, Contiguous varr, ApplyUniversally v (Element varr))
+  => Map karr varr k v
+  -> Map karr varr k v
+  -> Ordering
+compare a b = P.compare (toList a) (toList b)
+
+size :: forall karr varr k v. (Contiguous varr, ApplyUniversally v (Element varr)) => Map karr varr k v -> Int
+size (Map m) = id
+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ M.size m
+
+map :: forall karr varr k v w. (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), ApplyUniversally w (Element varr))
+  => (forall a. v a -> w a)
+  -> Map karr varr k v
+  -> Map karr varr k w
+map f (Map m) = id
+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy w) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ Map (M.map f m)
+
+mapMaybe :: forall karr varr k v w. (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), ApplyUniversally w (Element varr))
+  => (forall a. v a -> Maybe (w a))
+  -> Map karr varr k v
+  -> Map karr varr k w
+mapMaybe f (Map m) = id
+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy w) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ Map (M.mapMaybe f m)
+
+mapMaybeWithKey :: forall karr varr k v w. (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), ApplyUniversally w (Element varr))
+  => (forall a. k a -> v a -> Maybe (w a))
+  -> Map karr varr k v
+  -> Map karr varr k w
+mapMaybeWithKey f (Map m) = id
+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy w) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ Map (M.mapMaybeWithKey (unsafeCoerceMapMaybeWithKeyFunction f) m)
+
+mapWithKey :: forall karr varr k v w. (Contiguous karr, Universally k (Element karr), Contiguous varr, ApplyUniversally v (Element varr), ApplyUniversally w (Element varr))
+  => (forall a. k a -> v a -> w a)
+  -> Map karr varr k v
+  -> Map karr varr k w
+mapWithKey f (Map m) = id
+  $ C.universally (Proxy :: Proxy k) (Proxy :: Proxy (Element karr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy v) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ C.applyUniversallyLifted (Proxy :: Proxy w) (Proxy :: Proxy (Element varr)) (Proxy :: Proxy Any)
+  $ Map (M.mapWithKey (unsafeCoerceMapWithKeyFunction f) m)
diff --git a/src/Data/Dependent/Map/Lifted/Lifted.hs b/src/Data/Dependent/Map/Lifted/Lifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Dependent/Map/Lifted/Lifted.hs
@@ -0,0 +1,88 @@
+{-# language GeneralizedNewtypeDeriving #-}
+{-# language PolyKinds #-}
+{-# language RankNTypes #-}
+{-# language TypeFamilies #-}
+
+module Data.Dependent.Map.Lifted.Lifted
+  ( Map
+  , singleton
+  , lookup
+  , toList
+  , fromList
+  , mapMaybe
+  , mapMaybeWithKey
+  ) where
+
+import Prelude hiding (lookup)
+
+import Data.Aeson (FromJSON,ToJSON)
+import Data.Primitive (Array)
+import Data.Semigroup (Semigroup)
+import Data.Exists (EqForallPoly,EqForeach,OrdForeach)
+import Data.Exists (OrdForallPoly,DependentPair,ShowForall,ShowForeach,ToSing)
+import Data.Exists (ToJSONKeyForall,FromJSONKeyExists,ToJSONForeach,SemigroupForeach)
+import Data.Exists (FromJSONForeach)
+import GHC.Exts (IsList)
+
+import qualified Data.Aeson as AE
+import qualified Data.Dependent.Map.Internal as I
+import qualified Data.Semigroup as SG
+import qualified GHC.Exts
+
+newtype Map k v = Map (I.Map Array Array k v)
+
+singleton :: k a -> v a -> Map k v
+singleton f v = Map (I.singleton f v)
+
+lookup :: OrdForallPoly k => k a -> Map k v -> Maybe (v a)
+lookup k (Map x) = I.lookup k x
+
+fromList :: OrdForallPoly k => [DependentPair k v] -> Map k v
+fromList xs = Map (I.fromList xs)
+
+fromListN :: OrdForallPoly k => Int -> [DependentPair k v] -> Map k v
+fromListN n xs = Map (I.fromListN n xs)
+
+toList :: Map k v -> [DependentPair k v]
+toList (Map x) = I.toList x
+
+mapMaybe ::
+     (forall a. v a -> Maybe (w a))
+  -> Map k v
+  -> Map k w
+mapMaybe f (Map m) = Map (I.mapMaybe f m)
+
+mapMaybeWithKey ::
+     (forall a. k a -> v a -> Maybe (w a))
+  -> Map k v
+  -> Map k w
+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m)
+
+instance OrdForallPoly k => IsList (Map k v) where
+  type Item (Map k v) = DependentPair k v
+  fromListN = fromListN
+  fromList = fromList
+  toList = toList
+  
+instance (ShowForall k, ToSing k, ShowForeach v) => Show (Map k v) where
+  showsPrec p (Map s) = I.showsPrec p s
+
+instance (EqForallPoly k, ToSing k, EqForeach v) => Eq (Map k v) where
+  Map x == Map y = I.equals x y
+
+instance (OrdForallPoly k, ToSing k, OrdForeach v) => Ord (Map k v) where
+  compare (Map x) (Map y) = I.compare x y
+
+instance (ToSing k, OrdForallPoly k, SemigroupForeach v) => Semigroup (Map k v) where
+  Map x <> Map y = Map (I.append x y)
+
+instance (ToSing k, OrdForallPoly k, SemigroupForeach v) => Monoid (Map k v) where
+  mempty = Map I.empty
+  mappend = (SG.<>)
+
+instance (ToSing k, ToJSONKeyForall k, ToJSONForeach v) => ToJSON (Map k v) where
+  toJSON (Map m) = I.toJSON m
+
+instance (ToSing k, FromJSONKeyExists k, FromJSONForeach v, OrdForallPoly k) => FromJSON (Map k v) where
+  parseJSON v = fmap Map (I.parseJSON v)
+
diff --git a/src/Data/Dependent/Map/Unboxed/Lifted.hs b/src/Data/Dependent/Map/Unboxed/Lifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Dependent/Map/Unboxed/Lifted.hs
@@ -0,0 +1,189 @@
+{-# language FlexibleContexts #-}
+{-# language GeneralizedNewtypeDeriving #-}
+{-# language PolyKinds #-}
+{-# language RankNTypes #-}
+{-# language TypeFamilies #-}
+
+module Data.Dependent.Map.Unboxed.Lifted
+  ( Map
+  , empty
+  , null
+  , singleton
+  , lookup
+  , foldrWithKey
+  , foldlWithKeyM'
+  , foldMapWithKey
+  , traverseWithKey_
+  , toList
+  , fromList
+  , map
+  , mapWithKey
+  , mapMaybe
+  , mapMaybeWithKey
+  , size
+    -- * Unsafe Functions
+  , unsafeFreezeZip
+  , unsafeCoerceKeys
+  ) where
+
+import Prelude hiding (lookup,null,map)
+
+import Control.Monad.ST (ST)
+import Data.Aeson (FromJSON,ToJSON)
+import Data.Dependent.Map.Class (Universally,ApplyUniversally)
+import Data.Exists (EqForallPoly,EqForeach,OrdForeach)
+import Data.Exists (OrdForallPoly,DependentPair,ShowForall,ShowForeach,ToSing)
+import Data.Exists (ToJSONKeyForall,FromJSONKeyExists,ToJSONForeach,SemigroupForeach)
+import Data.Exists (FromJSONForeach)
+import Data.Primitive (Array,PrimArray,Prim,MutablePrimArray,MutableArray)
+import Data.Proxy (Proxy)
+import Data.Semigroup (Semigroup)
+import GHC.Exts (IsList,Any)
+import Unsafe.Coerce (unsafeCoerce)
+
+import qualified Data.Aeson as AE
+import qualified Data.Semigroup as SG
+import qualified Data.Dependent.Map.Internal as I
+import qualified GHC.Exts
+import qualified Data.Set.Unboxed.Internal as SU
+import qualified Data.Map.Internal as M
+
+newtype Map k v = Map (I.Map PrimArray Array k v)
+
+empty :: Map k v
+empty = Map I.empty
+
+null :: Map k v -> Bool
+null (Map m) = I.null m
+
+singleton :: Universally k Prim => k a -> v a -> Map k v
+singleton f v = Map (I.singleton f v)
+
+lookup :: (Universally k Prim, ApplyUniversally k Prim, OrdForallPoly k) => k a -> Map k v -> Maybe (v a)
+lookup k (Map x) = I.lookup k x
+
+fromList :: (Universally k Prim, ApplyUniversally k Prim, OrdForallPoly k) => [DependentPair k v] -> Map k v
+fromList xs = Map (I.fromList xs)
+
+fromListN :: (Universally k Prim, ApplyUniversally k Prim, OrdForallPoly k) => Int -> [DependentPair k v] -> Map k v
+fromListN n xs = Map (I.fromListN n xs)
+
+toList :: Universally k Prim => Map k v -> [DependentPair k v]
+toList (Map x) = I.toList x
+
+size :: Map k v -> Int
+size (Map x) = I.size x
+
+foldrWithKey :: 
+     Universally k Prim
+  => (forall a. k a -> v a -> b -> b)
+  -> b
+  -> Map k v
+  -> b
+foldrWithKey f b (Map m) = I.foldrWithKey f b m
+
+foldlWithKeyM' :: 
+     (Universally k Prim, Monad m)
+  => (forall a. b -> k a -> v a -> m b)
+  -> b
+  -> Map k v
+  -> m b
+foldlWithKeyM' f b (Map m) = I.foldlWithKeyM' f b m
+
+foldMapWithKey :: 
+     (Universally k Prim, Monoid m)
+  => (forall a. k a -> v a -> m)
+  -> Map k v
+  -> m
+foldMapWithKey f (Map m) = I.foldMapWithKey f m
+
+traverseWithKey_ :: 
+     (Universally k Prim, Applicative m)
+  => (forall a. k a -> v a -> m b)
+  -> Map k v
+  -> m ()
+traverseWithKey_ f (Map m) = I.traverseWithKey_ f m
+
+map ::
+     Universally k Prim
+  => (forall a. v a -> w a)
+  -> Map k v
+  -> Map k w
+map f (Map m) = Map (I.map f m)
+
+mapMaybe ::
+     Universally k Prim
+  => (forall a. v a -> Maybe (w a))
+  -> Map k v
+  -> Map k w
+mapMaybe f (Map m) = Map (I.mapMaybe f m)
+
+mapMaybeWithKey ::
+     Universally k Prim
+  => (forall a. k a -> v a -> Maybe (w a))
+  -> Map k v
+  -> Map k w
+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m)
+
+mapWithKey ::
+     Universally k Prim
+  => (forall a. k a -> v a -> w a)
+  -> Map k v
+  -> Map k w
+mapWithKey f (Map m) = Map (I.mapWithKey f m)
+
+-- | This function is even more unsafe than the @unsafeFreezeZip@ provided by
+-- @Data.Map.Unboxed.Lifted@. The user needs to use @unsafeCoerce@ to even use this
+-- function.
+unsafeFreezeZip :: 
+     (Universally k Prim, OrdForallPoly k)
+  => MutablePrimArray s (k Any)
+  -> MutableArray s (v Any)
+  -> ST s (Map k v)
+{-# INLINABLE unsafeFreezeZip #-}
+unsafeFreezeZip keys0 vals0 =
+  fmap Map (I.unsafeFreezeZip keys0 vals0)
+
+-- | /O(1)/ This function is highly unsafe. The user is responsible for ensuring
+-- that:
+--
+-- * Both @k'@ and @forall a. k a@ have the same runtime representation.
+-- * The @Ord@ instance for @k'@ agrees with the @OrdForallPoly@ instance
+--   for @k@.
+unsafeCoerceKeys :: Proxy k' -> Map k v -> SU.Set k'
+unsafeCoerceKeys p (Map (I.Map m)) =
+  -- TODO: Technical debt. Add this function to the Internal module
+  -- so that the data constructor does not have to be exported.
+  unsafeCoerceSet p (SU.Set (M.keys m))
+
+unsafeCoerceSet :: Proxy k' -> SU.Set (k Any) -> SU.Set k'
+unsafeCoerceSet _ = unsafeCoerce
+
+instance (Universally k Prim, ApplyUniversally k Prim, OrdForallPoly k) => IsList (Map k v) where
+  type Item (Map k v) = DependentPair k v
+  fromListN = fromListN
+  fromList = fromList
+  toList = toList
+  
+instance (Universally k Prim, ApplyUniversally k Prim, ShowForall k, ToSing k, ShowForeach v) => Show (Map k v) where
+  showsPrec p (Map s) = I.showsPrec p s
+
+instance (Universally k Prim, ApplyUniversally k Prim, EqForallPoly k, ToSing k, EqForeach v) => Eq (Map k v) where
+  Map x == Map y = I.equals x y
+
+instance (Universally k Prim, ApplyUniversally k Prim, OrdForallPoly k, ToSing k, OrdForeach v) => Ord (Map k v) where
+  compare (Map x) (Map y) = I.compare x y
+
+instance (Universally k Prim, ToSing k, ToJSONKeyForall k, ToJSONForeach v) => ToJSON (Map k v) where
+  toJSON (Map m) = I.toJSON m
+
+instance (Universally k Prim, ApplyUniversally k Prim, ToSing k, FromJSONKeyExists k, FromJSONForeach v, OrdForallPoly k) => FromJSON (Map k v) where
+  parseJSON v = fmap Map (I.parseJSON v)
+
+instance (Universally k Prim, ToSing k, OrdForallPoly k, SemigroupForeach v) => Semigroup (Map k v) where
+  Map x <> Map y = Map (I.append x y)
+
+instance (Universally k Prim, ToSing k, OrdForallPoly k, SemigroupForeach v) => Monoid (Map k v) where
+  mempty = Map I.empty
+  mappend = (SG.<>)
+
diff --git a/src/Data/Dependent/Map/Unlifted/Lifted.hs b/src/Data/Dependent/Map/Unlifted/Lifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Dependent/Map/Unlifted/Lifted.hs
@@ -0,0 +1,23 @@
+{-# language FlexibleContexts #-}
+
+module Data.Dependent.Map.Unlifted.Lifted
+  ( Map
+  , singleton
+  , lookup
+  ) where
+
+import Prelude hiding (lookup)
+
+import Data.Primitive (Array,UnliftedArray,PrimUnlifted)
+import Data.Dependent.Map.Class
+import Data.Exists (OrdForallPoly)
+import qualified Data.Dependent.Map.Internal as I
+
+newtype Map k v = Map (I.Map UnliftedArray Array k v)
+
+singleton :: ApplyUniversally k PrimUnlifted => k a -> v a -> Map k v
+singleton f v = Map (I.singleton f v)
+
+lookup :: (OrdForallPoly k, ApplyUniversally k PrimUnlifted) => k a -> Map k v -> Maybe (v a)
+lookup k (Map x) = I.lookup k x
+
diff --git a/src/Data/Diet/Map/Internal.hs b/src/Data/Diet/Map/Internal.hs
deleted file mode 100644
--- a/src/Data/Diet/Map/Internal.hs
+++ /dev/null
@@ -1,395 +0,0 @@
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE UnboxedTuples #-}
-{-# LANGUAGE MagicHash #-}
-
-{-# OPTIONS_GHC -O2 -Wall #-}
-module Data.Diet.Map.Internal
-  ( Map
-  , empty
-  , singleton
-  , map
-  , append
-  , lookup
-  , concat
-  , equals
-  , showsPrec
-  , liftShowsPrec2
-    -- list conversion
-  , fromListN
-  , fromList
-  , fromListAppend
-  , fromListAppendN
-  , toList
-  ) where
-
-import Prelude hiding (lookup,showsPrec,concat,map)
-
-import Control.Applicative (liftA2)
-import Control.Monad.ST (ST,runST)
-import Data.Semigroup (Semigroup)
-import Data.Foldable (foldl')
-import Text.Show (showListWith)
-import Data.Primitive.Contiguous (Contiguous,Element,Mutable)
-import qualified Data.List as L
-import qualified Data.Semigroup as SG
-import qualified Prelude as P
-import qualified Data.Primitive.Contiguous as I
-import qualified Data.Concatenation as C
-
--- The key array is twice as long as the value array since
--- everything is stored as a range. Also, figure out how to
--- unpack these two arguments at some point.
-data Map karr varr k v = Map !(karr k) !(varr v)
-
-empty :: (Contiguous karr, Contiguous varr) => Map karr varr k v
-empty = Map I.empty I.empty
-
-map :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w) => (v -> w) -> Map karr varr k v -> Map karr varr k w
-map f (Map k v) = Map k (I.map f v)
-
-equals :: (Contiguous karr, Element karr k, Eq k, Contiguous varr, Element varr v, Eq v) => Map karr varr k v -> Map karr varr k v -> Bool
-equals (Map k1 v1) (Map k2 v2) = I.equals k1 k2 && I.equals v1 v2
-
-fromListN :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) => Int -> [(k,k,v)] -> Map karr varr k v
-fromListN = fromListWithN (\_ a -> a)
-
-fromList :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) => [(k,k,v)] -> Map karr varr k v
-fromList = fromListN 1
-
-fromListAppendN :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Semigroup v, Eq v) => Int -> [(k,k,v)] -> Map karr varr k v
-fromListAppendN = fromListWithN (SG.<>)
-
-fromListAppend :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Semigroup v, Eq v) => [(k,k,v)] -> Map karr varr k v
-fromListAppend = fromListAppendN 1
-
-fromListWithN :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) => (v -> v -> v) -> Int -> [(k,k,v)] -> Map karr varr k v
-fromListWithN combine _ xs =
-  concatWith combine (P.map (\(lo,hi,v) -> singleton lo hi v) xs)
-
-concat :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Semigroup v, Eq v) => [Map karr varr k v] -> Map karr varr k v
-concat = concatWith (SG.<>)
-
-singleton :: forall karr varr k v. (Contiguous karr, Element karr k,Ord k,Contiguous varr, Element varr v) => k -> k -> v -> Map karr varr k v
-singleton !lo !hi !v = if lo <= hi
-  then Map
-    ( runST $ do
-        !(arr :: Mutable karr s k) <- I.new 2
-        I.write arr 0 lo
-        I.write arr 1 hi
-        I.unsafeFreeze arr
-    )
-    ( runST $ do
-        !(arr :: Mutable varr s v) <- I.new 1
-        I.write arr 0 v
-        I.unsafeFreeze arr
-    )
-  else empty
-
-lookup :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => k -> Map karr varr k v -> Maybe v
-lookup a (Map keys vals) = go 0 (I.size vals - 1) where
-  go :: Int -> Int -> Maybe v
-  go !start !end = if end <= start
-    then if end == start
-      then 
-        let !valLo = I.index keys (2 * start)
-            !valHi = I.index keys (2 * start + 1)
-         in if a >= valLo && a <= valHi
-              then case I.index# vals start of
-                (# v #) -> Just v
-              else Nothing
-      else Nothing
-    else
-      let !mid = div (end + start + 1) 2
-          !valLo = I.index keys (2 * mid)
-       in case P.compare a valLo of
-            LT -> go start (mid - 1)
-            EQ -> case I.index# vals mid of
-              (# v #) -> Just v
-            GT -> go mid end
-{-# INLINEABLE lookup #-}
-
-
-append :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Semigroup v, Eq v) => Map karr varr k v -> Map karr varr k v -> Map karr varr k v
-append (Map ksA vsA) (Map ksB vsB) =
-  case unionArrWith (SG.<>) ksA vsA ksB vsB of
-    (k,v) -> Map k v
-
-appendWith :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) => (v -> v -> v) -> Map karr varr k v -> Map karr varr k v -> Map karr varr k v
-appendWith combine (Map ksA vsA) (Map ksB vsB) =
-  case unionArrWith combine ksA vsA ksB vsB of
-    (k,v) -> Map k v
-  
-  
-unionArrWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v)
-  => (v -> v -> v)
-  -> karr k -- keys a
-  -> varr v -- values a
-  -> karr k -- keys b
-  -> varr v -- values b
-  -> (karr k, varr v)
-unionArrWith combine keysA valsA keysB valsB
-  | I.size valsA < 1 = (keysB,valsB)
-  | I.size valsB < 1 = (keysA,valsA)
-  | otherwise = runST action
-  where
-  action :: forall s. ST s (karr k, varr v)
-  action = do
-    let !szA = I.size valsA
-        !szB = I.size valsB
-    !(keysDst :: Mutable karr s k) <- I.new (max szA szB * 8)
-    !(valsDst :: Mutable varr s v) <- I.new (max szA szB * 4)
-    let writeKeyRange :: Int -> k -> k -> ST s ()
-        writeKeyRange !ix !lo !hi = do
-          I.write keysDst (2 * ix) lo
-          I.write keysDst (2 * ix + 1) hi
-        writeDstHiKey :: Int -> k -> ST s ()
-        writeDstHiKey !ix !hi = I.write keysDst (2 * ix + 1) hi
-        writeDstValue :: Int -> v -> ST s ()
-        writeDstValue !ix !v = I.write valsDst ix v
-        readDstHiKey :: Int -> ST s k
-        readDstHiKey !ix = I.read keysDst (2 * ix + 1)
-        readDstVal :: Int -> ST s v
-        readDstVal !ix = I.read valsDst ix
-        indexLoKeyA :: Int -> k
-        indexLoKeyA !ix = I.index keysA (ix * 2)
-        indexLoKeyB :: Int -> k
-        indexLoKeyB !ix = I.index keysB (ix * 2)
-        indexHiKeyA :: Int -> k
-        indexHiKeyA !ix = I.index keysA (ix * 2 + 1)
-        indexHiKeyB :: Int -> k
-        indexHiKeyB !ix = I.index keysB (ix * 2 + 1)
-        indexValueA :: Int -> v
-        indexValueA !ix = I.index valsA ix
-        indexValueB :: Int -> v
-        indexValueB !ix = I.index valsB ix
-    -- In the go functon, ixDst is always at least one. Similarly,
-    -- all key arguments are always greater than minBound.
-    let go :: Int -> k -> k -> v -> Int -> k -> k -> v -> Int -> ST s Int
-        go !ixA !loA !hiA !valA !ixB !loB !hiB !valB !ixDst = do
-          prevHi <- readDstHiKey (ixDst - 1) 
-          prevVal <- readDstVal (ixDst - 1) 
-          case compare loA loB of
-            LT -> do
-              let (upper,ixA') = if hiA < loB
-                    then (hiA,ixA + 1)
-                    else (pred loB,ixA)
-              ixDst' <- if pred loA == prevHi && valA == prevVal
-                then do
-                  writeDstHiKey (ixDst - 1) upper
-                  return ixDst
-                else do
-                  writeKeyRange ixDst loA upper
-                  writeDstValue ixDst valA
-                  return (ixDst + 1)
-              if ixA' < szA
-                then do
-                  let (loA',hiA') = if hiA < loB
-                        then (indexLoKeyA ixA',indexHiKeyA ixA')
-                        else (loB,hiA)
-                  go ixA' loA' hiA' (indexValueA ixA') ixB loB hiB valB ixDst'
-                else copyB ixB loB hiB valB ixDst'
-            GT -> do
-              let (upper,ixB') = if hiB < loA
-                    then (hiB,ixB + 1)
-                    else (pred loA,ixB)
-              ixDst' <- if pred loB == prevHi && valB == prevVal
-                then do
-                  writeDstHiKey (ixDst - 1) upper
-                  return ixDst
-                else do
-                  writeKeyRange ixDst loB upper
-                  writeDstValue ixDst valB
-                  return (ixDst + 1)
-              if ixB' < szB
-                then do
-                  let (loB',hiB') = if hiB < loA
-                        then (indexLoKeyB ixB',indexHiKeyB ixB')
-                        else (loA,hiB)
-                  go ixA loA hiA valA ixB' loB' hiB' (indexValueB ixB') ixDst'
-                else copyA ixA loA hiA valA ixDst'
-            EQ -> do
-              let valCombination = combine valA valB
-              case compare hiA hiB of
-                LT -> do
-                  ixDst' <- if pred loA == prevHi && valCombination == prevVal
-                    then do
-                      writeDstHiKey (ixDst - 1) hiA
-                      return ixDst
-                    else do
-                      writeKeyRange ixDst loA hiA
-                      writeDstValue ixDst valCombination
-                      return (ixDst + 1)
-                  let ixA' = ixA + 1
-                      loB' = succ hiA
-                  if ixA' < szA
-                    then go ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') (indexValueA ixA') ixB loB' hiB valB ixDst'
-                    else copyB ixB loB' hiB valB ixDst'
-                GT -> do
-                  ixDst' <- if pred loB == prevHi && valCombination == prevVal
-                    then do
-                      writeDstHiKey (ixDst - 1) hiB
-                      return ixDst
-                    else do
-                      writeKeyRange ixDst loB hiB
-                      writeDstValue ixDst valCombination
-                      return (ixDst + 1)
-                  let ixB' = ixB + 1
-                      loA' = succ hiB
-                  if ixB' < szB
-                    then go ixA loA' hiA valA ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') (indexValueB ixB') ixDst'
-                    else copyA ixA loA' hiA valA ixDst'
-                EQ -> do
-                  ixDst' <- if pred loB == prevHi && valCombination == prevVal
-                    then do
-                      writeDstHiKey (ixDst - 1) hiB
-                      return ixDst
-                    else do
-                      writeKeyRange ixDst loB hiB
-                      writeDstValue ixDst valCombination
-                      return (ixDst + 1)
-                  let ixA' = ixA + 1
-                      ixB' = ixB + 1
-                  if ixA' < szA
-                    then if ixB' < szB
-                      then go ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') (indexValueA ixA') ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') (indexValueB ixB') ixDst'
-                      else copyA ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') (indexValueA ixA') ixDst'
-                    else if ixB' < szB
-                      then copyB ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') (indexValueB ixB') ixDst'
-                      else return ixDst'
-        copyB :: Int -> k -> k -> v -> Int -> ST s Int
-        copyB !ixB !loB !hiB !valB !ixDst = do
-          prevHi <- readDstHiKey (ixDst - 1) 
-          prevVal <- readDstVal (ixDst - 1) 
-          ixDst' <- if pred loB == prevHi && valB == prevVal
-            then do
-              writeDstHiKey (ixDst - 1) hiB
-              return ixDst
-            else do
-              writeKeyRange ixDst loB hiB
-              writeDstValue ixDst valB
-              return (ixDst + 1)
-          let ixB' = ixB + 1
-              remaining = szB - ixB'
-          I.copy keysDst (ixDst' * 2) keysB (ixB' * 2) (remaining * 2)
-          I.copy valsDst ixDst' valsB ixB' remaining
-          return (ixDst' + remaining)
-        copyA :: Int -> k -> k -> v -> Int -> ST s Int
-        copyA !ixA !loA !hiA !valA !ixDst = do
-          prevHi <- readDstHiKey (ixDst - 1) 
-          prevVal <- readDstVal (ixDst - 1) 
-          ixDst' <- if pred loA == prevHi && valA == prevVal
-            then do
-              writeDstHiKey (ixDst - 1) hiA
-              return ixDst
-            else do
-              writeKeyRange ixDst loA hiA
-              writeDstValue ixDst valA
-              return (ixDst + 1)
-          let ixA' = ixA + 1
-              remaining = szA - ixA'
-          I.copy keysDst (ixDst' * 2) keysA (ixA' * 2) (remaining * 2)
-          I.copy valsDst ixDst' valsA ixA' remaining
-          return (ixDst' + remaining)
-    let !loA0 = indexLoKeyA 0
-        !loB0 = indexLoKeyB 0
-        !hiA0 = indexHiKeyA 0
-        !hiB0 = indexHiKeyB 0
-        !valA0 = indexValueA 0
-        !valB0 = indexValueB 0
-    total <- case compare loA0 loB0 of
-      LT -> if hiA0 < loB0
-        then do
-          writeKeyRange 0 loA0 hiA0
-          writeDstValue 0 valA0
-          if 1 < szA
-            then go 1 (indexLoKeyA 1) (indexHiKeyA 1) (indexValueA 1) 0 loB0 hiB0 valB0 1
-            else copyB 0 loB0 hiB0 valB0 1
-        else do
-          -- here we know that hiA > loA
-          let !upperA = pred loB0
-          writeKeyRange 0 loA0 upperA
-          writeDstValue 0 valA0
-          go 0 loB0 hiA0 valA0 0 loB0 hiB0 valB0 1
-      EQ -> case compare hiA0 hiB0 of
-        LT -> do
-          writeKeyRange 0 loA0 hiA0
-          writeDstValue 0 (combine valA0 valB0)
-          if 1 < szA
-            then go 1 (indexLoKeyA 1) (indexHiKeyA 1) (indexValueA 1) 0 (succ hiA0) hiB0 valB0 1
-            else copyB 0 (succ hiA0) hiB0 valB0 1
-        GT -> do
-          writeKeyRange 0 loB0 hiB0
-          writeDstValue 0 (combine valA0 valB0)
-          if 1 < szB
-            then go 0 (succ hiB0) hiA0 valA0 1 (indexLoKeyB 1) (indexHiKeyB 1) (indexValueB 1) 1
-            else copyA 0 (succ hiB0) hiA0 valA0 1
-        EQ -> do
-          writeKeyRange 0 loA0 hiA0
-          writeDstValue 0 (combine valA0 valB0)
-          if 1 < szA
-            then if 1 < szB
-              then go 1 (indexLoKeyA 1) (indexHiKeyA 1) (indexValueA 1) 1 (indexLoKeyB 1) (indexHiKeyB 1) (indexValueB 1) 1
-              else copyA 1 (indexLoKeyA 1) (indexHiKeyA 1) (indexValueA 1) 1
-            else if 1 < szB
-              then copyB 1 (indexLoKeyB 1) (indexHiKeyB 1) (indexValueB 1) 1
-              else return 1
-      GT -> if hiB0 < loA0
-        then do
-          writeKeyRange 0 loB0 hiB0
-          writeDstValue 0 valB0
-          if 1 < szB
-            then go 0 loA0 hiA0 valA0 1 (indexLoKeyB 1) (indexHiKeyB 1) (indexValueB 1) 1
-            else copyA 0 loA0 hiA0 valA0 1
-        else do
-          let !upperB = pred loA0
-          writeKeyRange 0 loB0 upperB
-          writeDstValue 0 valB0
-          go 0 loA0 hiA0 valA0 0 loA0 hiB0 valB0 1
-    !keysFinal <- I.resize keysDst (total * 2)
-    !valsFinal <- I.resize valsDst total
-    liftA2 (,) (I.unsafeFreeze keysFinal) (I.unsafeFreeze valsFinal)
-
-concatWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v)
-  => (v -> v -> v)
-  -> [Map karr varr k v]
-  -> Map karr varr k v
-concatWith combine = C.concatSized size empty (appendWith combine)
-
-size :: (Contiguous varr, Element varr v) => Map karr varr k v -> Int
-size (Map _ vals) = I.size vals 
-
-toList :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => Map karr varr k v -> [(k,k,v)]
-toList = foldrWithKey (\lo hi v xs -> (lo,hi,v) : xs) []
-
-foldrWithKey :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => (k -> k -> v -> b -> b) -> b -> Map karr varr k v -> b
-foldrWithKey f z (Map keys vals) =
-  let !sz = I.size vals
-      go !i
-        | i == sz = z
-        | otherwise =
-            let !lo = I.index keys (i * 2)
-                !hi = I.index keys (i * 2 + 1)
-                !v = I.index vals i
-             in f lo hi v (go (i + 1))
-   in go 0
-
-showsPrec :: (Contiguous karr, Element karr k, Show k, Contiguous varr, Element varr v, Show v) => Int -> Map karr varr k v -> ShowS
-showsPrec p xs = showParen (p > 10) $
-  showString "fromList " . shows (toList xs)
-
-liftShowsPrec2 :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => (Int -> k -> ShowS) -> ([k] -> ShowS) -> (Int -> v -> ShowS) -> ([v] -> ShowS) -> Int -> Map karr varr k v -> ShowS
-liftShowsPrec2 showsPrecK _ showsPrecV _ p xs = showParen (p > 10) $
-  showString "fromList " . showListWith (\(a,b,c) -> show_tuple [showsPrecK 0 a, showsPrecK 0 b, showsPrecV 0 c])  (toList xs)
-
--- implementation copied from GHC.Show
-show_tuple :: [ShowS] -> ShowS
-show_tuple ss = id
-  . showChar '('
-  . foldr1 (\s r -> s . showChar ',' . r) ss
-  . showChar ')'
-
-
diff --git a/src/Data/Diet/Map/Lifted/Lifted.hs b/src/Data/Diet/Map/Lifted/Lifted.hs
deleted file mode 100644
--- a/src/Data/Diet/Map/Lifted/Lifted.hs
+++ /dev/null
@@ -1,77 +0,0 @@
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeFamilies #-}
-
-{-# OPTIONS_GHC -O2 #-}
-module Data.Diet.Map.Lifted.Lifted
-  ( Map
-  , singleton
-  , lookup
-    -- * List Conversion
-  , fromList
-  , fromListAppend
-  , fromListN
-  , fromListAppendN
-  ) where
-
-import Prelude hiding (lookup,map)
-
-import Data.Semigroup (Semigroup)
-import Data.Functor.Classes (Show2(..))
-import Data.Primitive (Array)
-import qualified GHC.Exts as E
-import qualified Data.Semigroup as SG
-import qualified Data.Diet.Map.Internal as I
-
-newtype Map k v = Map (I.Map Array Array k v)
-
--- | /O(1)/ Create a diet map with a single element.
-singleton :: Ord k
-  => k -- ^ inclusive lower bound
-  -> k -- ^ inclusive upper bound
-  -> v -- ^ value
-  -> Map k v
-singleton lo hi v = Map (I.singleton lo hi v)
-
--- | /O(log n)/ Lookup the value at a key in the map.
-lookup :: Ord k => k -> Map k v -> Maybe v
-lookup a (Map s) = I.lookup a s
-
-instance (Show k, Show v) => Show (Map k v) where
-  showsPrec p (Map m) = I.showsPrec p m
-
-instance (Eq k, Eq v) => Eq (Map k v) where
-  Map x == Map y = I.equals x y
-
-instance (Ord k, Enum k, Semigroup v, Eq v) => Semigroup (Map k v) where
-  Map x <> Map y = Map (I.append x y)
-
-instance (Ord k, Enum k, Semigroup v, Eq v) => Monoid (Map k v) where
-  mempty = Map I.empty
-  mappend = (SG.<>)
-  mconcat = Map . I.concat . E.coerce
-
-instance (Ord k, Enum k, Eq v) => E.IsList (Map k v) where
-  type Item (Map k v) = (k,k,v)
-  fromListN n = Map . I.fromListN n
-  fromList = Map . I.fromList
-  toList (Map s) = I.toList s
-
-fromList :: (Ord k, Enum k, Eq v) => [(k,k,v)] -> Map k v
-fromList = Map . I.fromList
-
-fromListN :: (Ord k, Enum k, Eq v)
-  => Int -- ^ expected size of resulting 'Map'
-  -> [(k,k,v)] -- ^ key-value pairs
-  -> Map k v
-fromListN n = Map . I.fromListN n
-
-fromListAppend :: (Ord k, Enum k, Semigroup v, Eq v) => [(k,k,v)] -> Map k v
-fromListAppend = Map . I.fromListAppend
-
-fromListAppendN :: (Ord k, Enum k, Semigroup v, Eq v)
-  => Int -- ^ expected size of resulting 'Map'
-  -> [(k,k,v)] -- ^ key-value pairs
-  -> Map k v
-fromListAppendN n = Map . I.fromListAppendN n
diff --git a/src/Data/Diet/Map/Strict/Internal.hs b/src/Data/Diet/Map/Strict/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Diet/Map/Strict/Internal.hs
@@ -0,0 +1,418 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+
+{-# OPTIONS_GHC -O2 -Wall #-}
+module Data.Diet.Map.Strict.Internal
+  ( Map
+  , empty
+  , singleton
+  , map
+  , append
+  , lookup
+  , concat
+  , equals
+  , fromSet
+  , showsPrec
+  , liftShowsPrec2
+    -- list conversion
+  , fromListN
+  , fromList
+  , fromListAppend
+  , fromListAppendN
+  , toList
+  ) where
+
+import Prelude hiding (lookup,showsPrec,concat,map)
+
+import Control.Applicative (liftA2)
+import Control.Monad.ST (ST,runST)
+import Data.Semigroup (Semigroup)
+import Data.Foldable (foldl')
+import Text.Show (showListWith)
+import Data.Primitive.Contiguous (Contiguous,Element,Mutable)
+import Data.Diet.Set.Internal (Set(..))
+import qualified Data.List as L
+import qualified Data.Semigroup as SG
+import qualified Prelude as P
+import qualified Data.Primitive.Contiguous as I
+import qualified Data.Concatenation as C
+
+-- The key array is twice as long as the value array since
+-- everything is stored as a range. Also, figure out how to
+-- unpack these two arguments at some point.
+data Map karr varr k v = Map !(karr k) !(varr v)
+
+empty :: (Contiguous karr, Contiguous varr) => Map karr varr k v
+empty = Map I.empty I.empty
+
+map :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w) => (v -> w) -> Map karr varr k v -> Map karr varr k w
+map f (Map k v) = Map k (I.map f v)
+
+equals :: (Contiguous karr, Element karr k, Eq k, Contiguous varr, Element varr v, Eq v) => Map karr varr k v -> Map karr varr k v -> Bool
+equals (Map k1 v1) (Map k2 v2) = I.equals k1 k2 && I.equals v1 v2
+
+fromListN :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) => Int -> [(k,k,v)] -> Map karr varr k v
+fromListN = fromListWithN (\_ a -> a)
+
+fromList :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) => [(k,k,v)] -> Map karr varr k v
+fromList = fromListN 1
+
+fromListAppendN :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Semigroup v, Eq v) => Int -> [(k,k,v)] -> Map karr varr k v
+fromListAppendN = fromListWithN (SG.<>)
+
+fromListAppend :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Semigroup v, Eq v) => [(k,k,v)] -> Map karr varr k v
+fromListAppend = fromListAppendN 1
+
+fromListWithN :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) => (v -> v -> v) -> Int -> [(k,k,v)] -> Map karr varr k v
+fromListWithN combine _ xs =
+  concatWith combine (P.map (\(lo,hi,v) -> singleton lo hi v) xs)
+
+concat :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Semigroup v, Eq v) => [Map karr varr k v] -> Map karr varr k v
+concat = concatWith (SG.<>)
+
+singleton :: forall karr varr k v. (Contiguous karr, Element karr k,Ord k,Contiguous varr, Element varr v) => k -> k -> v -> Map karr varr k v
+singleton !lo !hi !v = if lo <= hi
+  then Map
+    ( runST $ do
+        !(arr :: Mutable karr s k) <- I.new 2
+        I.write arr 0 lo
+        I.write arr 1 hi
+        I.unsafeFreeze arr
+    )
+    ( runST $ do
+        !(arr :: Mutable varr s v) <- I.new 1
+        I.write arr 0 v
+        I.unsafeFreeze arr
+    )
+  else empty
+
+lookup :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => k -> Map karr varr k v -> Maybe v
+lookup a (Map keys vals) = go 0 (I.size vals - 1) where
+  go :: Int -> Int -> Maybe v
+  go !start !end = if end <= start
+    then if end == start
+      then 
+        let !valLo = I.index keys (2 * start)
+            !valHi = I.index keys (2 * start + 1)
+         in if a >= valLo && a <= valHi
+              then case I.index# vals start of
+                (# v #) -> Just v
+              else Nothing
+      else Nothing
+    else
+      let !mid = div (end + start + 1) 2
+          !valLo = I.index keys (2 * mid)
+       in case P.compare a valLo of
+            LT -> go start (mid - 1)
+            EQ -> case I.index# vals mid of
+              (# v #) -> Just v
+            GT -> go mid end
+{-# INLINEABLE lookup #-}
+
+
+append :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Semigroup v, Eq v) => Map karr varr k v -> Map karr varr k v -> Map karr varr k v
+append (Map ksA vsA) (Map ksB vsB) =
+  case unionArrWith (SG.<>) ksA vsA ksB vsB of
+    (k,v) -> Map k v
+
+appendWith :: (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v) => (v -> v -> v) -> Map karr varr k v -> Map karr varr k v -> Map karr varr k v
+appendWith combine (Map ksA vsA) (Map ksB vsB) =
+  case unionArrWith combine ksA vsA ksB vsB of
+    (k,v) -> Map k v
+  
+  
+unionArrWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v)
+  => (v -> v -> v)
+  -> karr k -- keys a
+  -> varr v -- values a
+  -> karr k -- keys b
+  -> varr v -- values b
+  -> (karr k, varr v)
+unionArrWith combine keysA valsA keysB valsB
+  | I.size valsA < 1 = (keysB,valsB)
+  | I.size valsB < 1 = (keysA,valsA)
+  | otherwise = runST action
+  where
+  action :: forall s. ST s (karr k, varr v)
+  action = do
+    let !szA = I.size valsA
+        !szB = I.size valsB
+    !(keysDst :: Mutable karr s k) <- I.new (max szA szB * 8)
+    !(valsDst :: Mutable varr s v) <- I.new (max szA szB * 4)
+    let writeKeyRange :: Int -> k -> k -> ST s ()
+        writeKeyRange !ix !lo !hi = do
+          I.write keysDst (2 * ix) lo
+          I.write keysDst (2 * ix + 1) hi
+        writeDstHiKey :: Int -> k -> ST s ()
+        writeDstHiKey !ix !hi = I.write keysDst (2 * ix + 1) hi
+        writeDstValue :: Int -> v -> ST s ()
+        writeDstValue !ix !v = I.write valsDst ix v
+        readDstHiKey :: Int -> ST s k
+        readDstHiKey !ix = I.read keysDst (2 * ix + 1)
+        readDstVal :: Int -> ST s v
+        readDstVal !ix = I.read valsDst ix
+        indexLoKeyA :: Int -> k
+        indexLoKeyA !ix = I.index keysA (ix * 2)
+        indexLoKeyB :: Int -> k
+        indexLoKeyB !ix = I.index keysB (ix * 2)
+        indexHiKeyA :: Int -> k
+        indexHiKeyA !ix = I.index keysA (ix * 2 + 1)
+        indexHiKeyB :: Int -> k
+        indexHiKeyB !ix = I.index keysB (ix * 2 + 1)
+        indexValueA :: Int -> v
+        indexValueA !ix = I.index valsA ix
+        indexValueB :: Int -> v
+        indexValueB !ix = I.index valsB ix
+    -- In the go functon, ixDst is always at least one. Similarly,
+    -- all key arguments are always greater than minBound.
+    let go :: Int -> k -> k -> v -> Int -> k -> k -> v -> Int -> ST s Int
+        go !ixA !loA !hiA !valA !ixB !loB !hiB !valB !ixDst = do
+          prevHi <- readDstHiKey (ixDst - 1) 
+          prevVal <- readDstVal (ixDst - 1) 
+          case compare loA loB of
+            LT -> do
+              let (upper,ixA') = if hiA < loB
+                    then (hiA,ixA + 1)
+                    else (pred loB,ixA)
+              ixDst' <- if pred loA == prevHi && valA == prevVal
+                then do
+                  writeDstHiKey (ixDst - 1) upper
+                  return ixDst
+                else do
+                  writeKeyRange ixDst loA upper
+                  writeDstValue ixDst valA
+                  return (ixDst + 1)
+              if ixA' < szA
+                then do
+                  let (loA',hiA') = if hiA < loB
+                        then (indexLoKeyA ixA',indexHiKeyA ixA')
+                        else (loB,hiA)
+                  go ixA' loA' hiA' (indexValueA ixA') ixB loB hiB valB ixDst'
+                else copyB ixB loB hiB valB ixDst'
+            GT -> do
+              let (upper,ixB') = if hiB < loA
+                    then (hiB,ixB + 1)
+                    else (pred loA,ixB)
+              ixDst' <- if pred loB == prevHi && valB == prevVal
+                then do
+                  writeDstHiKey (ixDst - 1) upper
+                  return ixDst
+                else do
+                  writeKeyRange ixDst loB upper
+                  writeDstValue ixDst valB
+                  return (ixDst + 1)
+              if ixB' < szB
+                then do
+                  let (loB',hiB') = if hiB < loA
+                        then (indexLoKeyB ixB',indexHiKeyB ixB')
+                        else (loA,hiB)
+                  go ixA loA hiA valA ixB' loB' hiB' (indexValueB ixB') ixDst'
+                else copyA ixA loA hiA valA ixDst'
+            EQ -> do
+              let valCombination = combine valA valB
+              case compare hiA hiB of
+                LT -> do
+                  ixDst' <- if pred loA == prevHi && valCombination == prevVal
+                    then do
+                      writeDstHiKey (ixDst - 1) hiA
+                      return ixDst
+                    else do
+                      writeKeyRange ixDst loA hiA
+                      writeDstValue ixDst valCombination
+                      return (ixDst + 1)
+                  let ixA' = ixA + 1
+                      loB' = succ hiA
+                  if ixA' < szA
+                    then go ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') (indexValueA ixA') ixB loB' hiB valB ixDst'
+                    else copyB ixB loB' hiB valB ixDst'
+                GT -> do
+                  ixDst' <- if pred loB == prevHi && valCombination == prevVal
+                    then do
+                      writeDstHiKey (ixDst - 1) hiB
+                      return ixDst
+                    else do
+                      writeKeyRange ixDst loB hiB
+                      writeDstValue ixDst valCombination
+                      return (ixDst + 1)
+                  let ixB' = ixB + 1
+                      loA' = succ hiB
+                  if ixB' < szB
+                    then go ixA loA' hiA valA ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') (indexValueB ixB') ixDst'
+                    else copyA ixA loA' hiA valA ixDst'
+                EQ -> do
+                  ixDst' <- if pred loB == prevHi && valCombination == prevVal
+                    then do
+                      writeDstHiKey (ixDst - 1) hiB
+                      return ixDst
+                    else do
+                      writeKeyRange ixDst loB hiB
+                      writeDstValue ixDst valCombination
+                      return (ixDst + 1)
+                  let ixA' = ixA + 1
+                      ixB' = ixB + 1
+                  if ixA' < szA
+                    then if ixB' < szB
+                      then go ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') (indexValueA ixA') ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') (indexValueB ixB') ixDst'
+                      else copyA ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') (indexValueA ixA') ixDst'
+                    else if ixB' < szB
+                      then copyB ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') (indexValueB ixB') ixDst'
+                      else return ixDst'
+        copyB :: Int -> k -> k -> v -> Int -> ST s Int
+        copyB !ixB !loB !hiB valB !ixDst = do
+          prevHi <- readDstHiKey (ixDst - 1) 
+          prevVal <- readDstVal (ixDst - 1) 
+          ixDst' <- if pred loB == prevHi && valB == prevVal
+            then do
+              writeDstHiKey (ixDst - 1) hiB
+              return ixDst
+            else do
+              writeKeyRange ixDst loB hiB
+              writeDstValue ixDst valB
+              return (ixDst + 1)
+          let ixB' = ixB + 1
+              remaining = szB - ixB'
+          I.copy keysDst (ixDst' * 2) keysB (ixB' * 2) (remaining * 2)
+          I.copy valsDst ixDst' valsB ixB' remaining
+          return (ixDst' + remaining)
+        copyA :: Int -> k -> k -> v -> Int -> ST s Int
+        copyA !ixA !loA !hiA !valA !ixDst = do
+          prevHi <- readDstHiKey (ixDst - 1) 
+          prevVal <- readDstVal (ixDst - 1) 
+          ixDst' <- if pred loA == prevHi && valA == prevVal
+            then do
+              writeDstHiKey (ixDst - 1) hiA
+              return ixDst
+            else do
+              writeKeyRange ixDst loA hiA
+              writeDstValue ixDst valA
+              return (ixDst + 1)
+          let ixA' = ixA + 1
+              remaining = szA - ixA'
+          I.copy keysDst (ixDst' * 2) keysA (ixA' * 2) (remaining * 2)
+          I.copy valsDst ixDst' valsA ixA' remaining
+          return (ixDst' + remaining)
+    let !loA0 = indexLoKeyA 0
+        !loB0 = indexLoKeyB 0
+        !hiA0 = indexHiKeyA 0
+        !hiB0 = indexHiKeyB 0
+        valA0 = indexValueA 0
+        valB0 = indexValueB 0
+    total <- case compare loA0 loB0 of
+      LT -> if hiA0 < loB0
+        then do
+          writeKeyRange 0 loA0 hiA0
+          writeDstValue 0 valA0
+          if 1 < szA
+            then go 1 (indexLoKeyA 1) (indexHiKeyA 1) (indexValueA 1) 0 loB0 hiB0 valB0 1
+            else copyB 0 loB0 hiB0 valB0 1
+        else do
+          -- here we know that hiA > loA
+          let !upperA = pred loB0
+          writeKeyRange 0 loA0 upperA
+          writeDstValue 0 valA0
+          go 0 loB0 hiA0 valA0 0 loB0 hiB0 valB0 1
+      EQ -> case compare hiA0 hiB0 of
+        LT -> do
+          writeKeyRange 0 loA0 hiA0
+          writeDstValue 0 (combine valA0 valB0)
+          if 1 < szA
+            then go 1 (indexLoKeyA 1) (indexHiKeyA 1) (indexValueA 1) 0 (succ hiA0) hiB0 valB0 1
+            else copyB 0 (succ hiA0) hiB0 valB0 1
+        GT -> do
+          writeKeyRange 0 loB0 hiB0
+          writeDstValue 0 (combine valA0 valB0)
+          if 1 < szB
+            then go 0 (succ hiB0) hiA0 valA0 1 (indexLoKeyB 1) (indexHiKeyB 1) (indexValueB 1) 1
+            else copyA 0 (succ hiB0) hiA0 valA0 1
+        EQ -> do
+          writeKeyRange 0 loA0 hiA0
+          writeDstValue 0 (combine valA0 valB0)
+          if 1 < szA
+            then if 1 < szB
+              then go 1 (indexLoKeyA 1) (indexHiKeyA 1) (indexValueA 1) 1 (indexLoKeyB 1) (indexHiKeyB 1) (indexValueB 1) 1
+              else copyA 1 (indexLoKeyA 1) (indexHiKeyA 1) (indexValueA 1) 1
+            else if 1 < szB
+              then copyB 1 (indexLoKeyB 1) (indexHiKeyB 1) (indexValueB 1) 1
+              else return 1
+      GT -> if hiB0 < loA0
+        then do
+          writeKeyRange 0 loB0 hiB0
+          writeDstValue 0 valB0
+          if 1 < szB
+            then go 0 loA0 hiA0 valA0 1 (indexLoKeyB 1) (indexHiKeyB 1) (indexValueB 1) 1
+            else copyA 0 loA0 hiA0 valA0 1
+        else do
+          let !upperB = pred loA0
+          writeKeyRange 0 loB0 upperB
+          writeDstValue 0 valB0
+          go 0 loA0 hiA0 valA0 0 loA0 hiB0 valB0 1
+    !keysFinal <- I.resize keysDst (total * 2)
+    !valsFinal <- I.resize valsDst total
+    liftA2 (,) (I.unsafeFreeze keysFinal) (I.unsafeFreeze valsFinal)
+
+concatWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Enum k, Contiguous varr, Element varr v, Eq v)
+  => (v -> v -> v)
+  -> [Map karr varr k v]
+  -> Map karr varr k v
+concatWith combine = C.concatSized size empty (appendWith combine)
+
+size :: (Contiguous varr, Element varr v) => Map karr varr k v -> Int
+size (Map _ vals) = I.size vals 
+
+toList :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => Map karr varr k v -> [(k,k,v)]
+toList = foldrWithKey (\lo hi v xs -> (lo,hi,v) : xs) []
+
+foldrWithKey :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => (k -> k -> v -> b -> b) -> b -> Map karr varr k v -> b
+foldrWithKey f z (Map keys vals) =
+  let !sz = I.size vals
+      go !i
+        | i == sz = z
+        | otherwise =
+            let !lo = I.index keys (i * 2)
+                !hi = I.index keys (i * 2 + 1)
+                !(# v #) = I.index# vals i
+             in f lo hi v (go (i + 1))
+   in go 0
+
+-- Convert a diet set to a diet map. The function takes the
+-- low and high keys in a range. This function should probably
+-- have a test written for it.
+fromSet :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v)
+  => (k -> k -> v) -> Set karr k -> Map karr varr k v
+fromSet f (Set keys) = Map keys values
+  where
+  values = runST $ do
+    let !sz = div (I.size keys) 2
+    m <- I.new sz
+    let go !ix !twiceIx = if ix < sz
+          then do
+            let !(# lo #) = I.index# keys twiceIx
+                !(# hi #) = I.index# keys (twiceIx + 1)
+            I.write m ix (f lo hi)
+            go (ix + 1) (twiceIx + 2)
+          else return ()
+    go 0 0
+    I.unsafeFreeze m
+
+
+showsPrec :: (Contiguous karr, Element karr k, Show k, Contiguous varr, Element varr v, Show v) => Int -> Map karr varr k v -> ShowS
+showsPrec p xs = showParen (p > 10) $
+  showString "fromList " . shows (toList xs)
+
+liftShowsPrec2 :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => (Int -> k -> ShowS) -> ([k] -> ShowS) -> (Int -> v -> ShowS) -> ([v] -> ShowS) -> Int -> Map karr varr k v -> ShowS
+liftShowsPrec2 showsPrecK _ showsPrecV _ p xs = showParen (p > 10) $
+  showString "fromList " . showListWith (\(a,b,c) -> show_tuple [showsPrecK 0 a, showsPrecK 0 b, showsPrecV 0 c])  (toList xs)
+
+-- implementation copied from GHC.Show
+show_tuple :: [ShowS] -> ShowS
+show_tuple ss = id
+  . showChar '('
+  . foldr1 (\s r -> s . showChar ',' . r) ss
+  . showChar ')'
+
+
diff --git a/src/Data/Diet/Map/Strict/Lifted/Lifted.hs b/src/Data/Diet/Map/Strict/Lifted/Lifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Diet/Map/Strict/Lifted/Lifted.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# OPTIONS_GHC -O2 #-}
+module Data.Diet.Map.Strict.Lifted.Lifted
+  ( Map
+  , singleton
+  , lookup
+    -- * List Conversion
+  , fromList
+  , fromListAppend
+  , fromListN
+  , fromListAppendN
+  ) where
+
+import Prelude hiding (lookup,map)
+
+import Data.Semigroup (Semigroup)
+import Data.Functor.Classes (Show2(..))
+import Data.Primitive (Array)
+import qualified GHC.Exts as E
+import qualified Data.Semigroup as SG
+import qualified Data.Diet.Map.Strict.Internal as I
+
+newtype Map k v = Map (I.Map Array Array k v)
+
+-- | /O(1)/ Create a diet map with a single element.
+singleton :: Ord k
+  => k -- ^ inclusive lower bound
+  -> k -- ^ inclusive upper bound
+  -> v -- ^ value
+  -> Map k v
+singleton lo hi v = Map (I.singleton lo hi v)
+
+-- | /O(log n)/ Lookup the value at a key in the map.
+lookup :: Ord k => k -> Map k v -> Maybe v
+lookup a (Map s) = I.lookup a s
+
+instance (Show k, Show v) => Show (Map k v) where
+  showsPrec p (Map m) = I.showsPrec p m
+
+instance (Eq k, Eq v) => Eq (Map k v) where
+  Map x == Map y = I.equals x y
+
+instance (Ord k, Enum k, Semigroup v, Eq v) => Semigroup (Map k v) where
+  Map x <> Map y = Map (I.append x y)
+
+instance (Ord k, Enum k, Semigroup v, Eq v) => Monoid (Map k v) where
+  mempty = Map I.empty
+  mappend = (SG.<>)
+  mconcat = Map . I.concat . E.coerce
+
+instance (Ord k, Enum k, Eq v) => E.IsList (Map k v) where
+  type Item (Map k v) = (k,k,v)
+  fromListN n = Map . I.fromListN n
+  fromList = Map . I.fromList
+  toList (Map s) = I.toList s
+
+fromList :: (Ord k, Enum k, Eq v) => [(k,k,v)] -> Map k v
+fromList = Map . I.fromList
+
+fromListN :: (Ord k, Enum k, Eq v)
+  => Int -- ^ expected size of resulting 'Map'
+  -> [(k,k,v)] -- ^ key-value pairs
+  -> Map k v
+fromListN n = Map . I.fromListN n
+
+fromListAppend :: (Ord k, Enum k, Semigroup v, Eq v) => [(k,k,v)] -> Map k v
+fromListAppend = Map . I.fromListAppend
+
+fromListAppendN :: (Ord k, Enum k, Semigroup v, Eq v)
+  => Int -- ^ expected size of resulting 'Map'
+  -> [(k,k,v)] -- ^ key-value pairs
+  -> Map k v
+fromListAppendN n = Map . I.fromListAppendN n
diff --git a/src/Data/Diet/Map/Strict/Unboxed/Lifted.hs b/src/Data/Diet/Map/Strict/Unboxed/Lifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Diet/Map/Strict/Unboxed/Lifted.hs
@@ -0,0 +1,108 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# OPTIONS_GHC -O2 #-}
+module Data.Diet.Map.Strict.Unboxed.Lifted
+  ( Map
+  , empty
+  , singleton
+  , lookup
+  , mapEqualityMorphism
+  , fromSet
+    -- * List Conversion
+  , fromList
+  , fromListAppend
+  , fromListN
+  , fromListAppendN
+  ) where
+
+import Prelude hiding (lookup,map)
+
+import Data.Diet.Set.Unboxed (Set(..))
+import Data.Functor.Classes (Show2(..))
+import Data.Primitive.Array (Array)
+import Data.Primitive.PrimArray (PrimArray)
+import Data.Primitive.Types (Prim)
+import Data.Semigroup (Semigroup)
+import qualified GHC.Exts as E
+import qualified Data.Semigroup as SG
+import qualified Data.Diet.Map.Strict.Internal as I
+
+newtype Map k v = Map (I.Map PrimArray Array k v)
+
+-- | The empty diet map.
+empty :: Map k v
+empty = Map I.empty
+
+-- | /O(1)/ Create a diet map with a single element.
+singleton :: (Prim k,Ord k)
+  => k -- ^ inclusive lower bound
+  -> k -- ^ inclusive upper bound
+  -> v -- ^ value
+  -> Map k v
+singleton lo hi v = Map (I.singleton lo hi v)
+
+-- | /O(log n)/ Lookup the value at a key in the map.
+lookup :: (Prim k, Ord k) => k -> Map k v -> Maybe v
+lookup a (Map s) = I.lookup a s
+
+instance (Prim k, Show k, Show v) => Show (Map k v) where
+  showsPrec p (Map m) = I.showsPrec p m
+
+instance (Prim k, Eq k, Eq v) => Eq (Map k v) where
+  Map x == Map y = I.equals x y
+
+instance (Prim k, Ord k, Enum k, Semigroup v, Eq v) => Semigroup (Map k v) where
+  Map x <> Map y = Map (I.append x y)
+
+instance (Prim k, Ord k, Enum k, Semigroup v, Eq v) => Monoid (Map k v) where
+  mempty = Map I.empty
+  mappend = (SG.<>)
+  mconcat = Map . I.concat . E.coerce
+
+instance (Prim k, Ord k, Enum k, Eq v) => E.IsList (Map k v) where
+  type Item (Map k v) = (k,k,v)
+  fromListN n = Map . I.fromListN n
+  fromList = Map . I.fromList
+  toList (Map s) = I.toList s
+
+fromList :: (Ord k, Enum k, Prim k, Eq v) => [(k,k,v)] -> Map k v
+fromList = Map . I.fromList
+
+fromListN :: (Ord k, Enum k, Prim k, Eq v)
+  => Int -- ^ expected size of resulting 'Map'
+  -> [(k,k,v)] -- ^ key-value pairs
+  -> Map k v
+fromListN n = Map . I.fromListN n
+
+fromListAppend :: (Ord k, Enum k, Prim k, Semigroup v, Eq v) => [(k,k,v)] -> Map k v
+fromListAppend = Map . I.fromListAppend
+
+fromListAppendN :: (Ord k, Enum k, Prim k, Semigroup v, Eq v)
+  => Int -- ^ expected size of resulting 'Map'
+  -> [(k,k,v)] -- ^ key-value pairs
+  -> Map k v
+fromListAppendN n = Map . I.fromListAppendN n
+
+-- | Map an equality morphism over the values in a diet map. An equality
+-- morphism @f@ must satisfy the law:
+--
+-- > ∀ x y. x == y ↔ f x == f y
+--
+-- Since this does not actually use the 'Eq' constraint on the new value
+-- type, it is lazy in the values.
+mapEqualityMorphism :: (Prim k, Ord k)
+  => (v -> w) -- ^ equality morphism
+  -> Map k v
+  -> Map k w
+mapEqualityMorphism f (Map m) = Map (I.map f m)
+
+-- | Convert a diet set to a diet map, constructing each value
+-- from the low and high key in its corresponding range.
+fromSet :: Prim k
+  => (k -> k -> v)
+  -> Set k
+  -> Map k v
+fromSet f (Set s) = Map (I.fromSet f s)
diff --git a/src/Data/Diet/Map/Unboxed/Lifted.hs b/src/Data/Diet/Map/Unboxed/Lifted.hs
deleted file mode 100644
--- a/src/Data/Diet/Map/Unboxed/Lifted.hs
+++ /dev/null
@@ -1,79 +0,0 @@
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeFamilies #-}
-
-{-# OPTIONS_GHC -O2 #-}
-module Data.Diet.Map.Unboxed.Lifted
-  ( Map
-  , singleton
-  , lookup
-    -- * List Conversion
-  , fromList
-  , fromListAppend
-  , fromListN
-  , fromListAppendN
-  ) where
-
-import Prelude hiding (lookup,map)
-
-import Data.Semigroup (Semigroup)
-import Data.Primitive.Types (Prim)
-import Data.Functor.Classes (Show2(..))
-import Data.Primitive.PrimArray (PrimArray)
-import Data.Primitive.Array (Array)
-import qualified GHC.Exts as E
-import qualified Data.Semigroup as SG
-import qualified Data.Diet.Map.Internal as I
-
-newtype Map k v = Map (I.Map PrimArray Array k v)
-
--- | /O(1)/ Create a diet map with a single element.
-singleton :: (Prim k,Ord k)
-  => k -- ^ inclusive lower bound
-  -> k -- ^ inclusive upper bound
-  -> v -- ^ value
-  -> Map k v
-singleton lo hi v = Map (I.singleton lo hi v)
-
--- | /O(log n)/ Lookup the value at a key in the map.
-lookup :: (Prim k, Ord k) => k -> Map k v -> Maybe v
-lookup a (Map s) = I.lookup a s
-
-instance (Prim k, Show k, Show v) => Show (Map k v) where
-  showsPrec p (Map m) = I.showsPrec p m
-
-instance (Prim k, Eq k, Eq v) => Eq (Map k v) where
-  Map x == Map y = I.equals x y
-
-instance (Prim k, Ord k, Enum k, Semigroup v, Eq v) => Semigroup (Map k v) where
-  Map x <> Map y = Map (I.append x y)
-
-instance (Prim k, Ord k, Enum k, Semigroup v, Eq v) => Monoid (Map k v) where
-  mempty = Map I.empty
-  mappend = (SG.<>)
-  mconcat = Map . I.concat . E.coerce
-
-instance (Prim k, Ord k, Enum k, Eq v) => E.IsList (Map k v) where
-  type Item (Map k v) = (k,k,v)
-  fromListN n = Map . I.fromListN n
-  fromList = Map . I.fromList
-  toList (Map s) = I.toList s
-
-fromList :: (Ord k, Enum k, Prim k, Eq v) => [(k,k,v)] -> Map k v
-fromList = Map . I.fromList
-
-fromListN :: (Ord k, Enum k, Prim k, Eq v)
-  => Int -- ^ expected size of resulting 'Map'
-  -> [(k,k,v)] -- ^ key-value pairs
-  -> Map k v
-fromListN n = Map . I.fromListN n
-
-fromListAppend :: (Ord k, Enum k, Prim k, Semigroup v, Eq v) => [(k,k,v)] -> Map k v
-fromListAppend = Map . I.fromListAppend
-
-fromListAppendN :: (Ord k, Enum k, Prim k, Semigroup v, Eq v)
-  => Int -- ^ expected size of resulting 'Map'
-  -> [(k,k,v)] -- ^ key-value pairs
-  -> Map k v
-fromListAppendN n = Map . I.fromListAppendN n
diff --git a/src/Data/Diet/Set/Internal.hs b/src/Data/Diet/Set/Internal.hs
--- a/src/Data/Diet/Set/Internal.hs
+++ b/src/Data/Diet/Set/Internal.hs
@@ -1,13 +1,13 @@
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-
-{-# OPTIONS_GHC -O2 -Wall #-}
+{-# LANGUAGE UnboxedTuples #-}
 module Data.Diet.Set.Internal
-  ( Set
+  ( Set(..)
   , empty
   , singleton
   , append
@@ -16,6 +16,8 @@
   , equals
   , showsPrec
   , difference
+  , intersection
+  , negate
   , foldr
   , size
     -- unsafe indexing
@@ -35,15 +37,19 @@
   , toList
   ) where
 
-import Prelude hiding (lookup,showsPrec,concat,map,foldr)
+import Prelude hiding (lookup,showsPrec,concat,map,foldr,negate)
 
 import Control.Monad.ST (ST,runST)
+import Data.Bool (bool)
 import Data.Primitive.Contiguous (Contiguous,Element,Mutable)
 import qualified Data.Foldable as F
 import qualified Prelude as P
 import qualified Data.Primitive.Contiguous as I
 import qualified Data.Concatenation as C
 
+-- Although the data constructor for this type is exported,
+-- it isn't needed by anything in the diet Set modules. It is needed
+-- by the diet Map modules to implement conversion functions.
 newtype Set arr a = Set (arr a)
 
 empty :: Contiguous arr => Set arr a
@@ -92,8 +98,8 @@
   go !start !end = if end <= start
     then if end == start
       then 
-        let !valLo = I.index arr (2 * start)
-            !valHi = I.index arr (2 * start + 1)
+        let !(# valLo #) = I.index# arr (2 * start)
+            !(# valHi #) = I.index# arr (2 * start + 1)
          in a >= valLo && a <= valHi
       else False
     else
@@ -487,6 +493,61 @@
     !keysFinal <- I.resize keysDst (total * 2)
     fmap Set (I.unsafeFreeze keysFinal)
 
+-- The element type must have a Bounded instance for
+-- this to work.
+negate :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a, Bounded a)
+  => Set arr a
+  -> Set arr a
+negate set@(Set arr)
+  | sz == 0 = uncheckedSingleton minBound maxBound
+  | otherwise = runST action
+  where
+  action :: forall s. ST s (Set arr a)
+  action = do
+    let !(# lowest #) = I.index# arr 0
+        !(# highest #) = I.index# arr (sz * 2 - 1)
+        anyBeneath = lowest /= minBound
+        anyAbove = highest /= maxBound
+        newSz =
+          (bool 0 1 anyBeneath) +
+          (bool 0 1 anyAbove) +
+          (sz - 1)
+    (marr :: Mutable arr s a) <- I.new (newSz * 2)
+    startDstIx <- if anyBeneath
+      then do
+        I.write marr 0 minBound
+        I.write marr 1 (pred lowest)
+        return 1
+      else return 0
+    let go !ix !dstIx = if ix < sz - 1
+          then do
+            hi <- I.indexM arr (2 * ix + 1)
+            I.write marr (dstIx * 2) (succ hi)
+            lo <- I.indexM arr (2 * ix + 2)
+            I.write marr (dstIx * 2 + 1) (pred lo)
+            go (ix + 1) (dstIx + 1)
+          else return ()
+    go 0 startDstIx
+    if anyAbove
+      then do
+        I.write marr (newSz * 2 - 2) (succ highest)
+        I.write marr (newSz * 2 - 1) maxBound
+      else return ()
+    frozen <- I.unsafeFreeze (marr :: Mutable arr s a)
+    return (Set frozen)
+  sz = size set
+  
+
+-- This is a disappointing implementation, but it's the best I can
+-- come up with given that I'm not willing to spend very much time
+-- on it. Basically, it builds a list of diet sets where each set is
+-- a slice of setA that only contains the elements from a contiguous range
+-- of the negation of setB. This is simple to implement and it's easy
+-- to see that it is correct. However, it is inefficient. There is a
+-- better solution that writes to a output buffer directly without
+-- building any intermediate artifacts. Additionally, the better solution
+-- should not need an Enum constraint. If anyone can figure out the better
+-- way to do this, I would gladly take a PR for it.
 difference :: forall a arr. (Contiguous arr, Element arr a, Ord a, Enum a)
   => Set arr a
   -> Set arr a
@@ -508,17 +569,44 @@
           highestA = I.index arrA (szA * 2 - 1)
           lowestB = I.index arrB 0
           highestB = I.index arrB (szB * 2 - 1)
-          -- TODO: if we ever add exclusive variants of below
-          -- and above, we should switch to using them here.
           lowFragment = if lowestA < lowestB
-            then [belowInclusive (pred lowestB) (Set arrA)]
+            then [belowExclusive lowestB (Set arrA)]
             else []
           highFragment = if highestA > highestB
-            then [aboveInclusive (succ highestB) (Set arrA)]
+            then [aboveExclusive highestB (Set arrA)]
             else []
           -- we should use a more efficient concat since
           -- we know everything is ordered.
        in concat (lowFragment ++ inners 0 ++ highFragment)
+  where
+    !szA = size setA
+    !szB = size setB
+
+-- This implementation suffers from the same problems as the implementation
+-- for difference. Notice that it's a bit simpler since we do not have to
+-- negate the diet set. This means we do not have to do the weirdness with
+-- treating the first and last elements specially and the weirdness with
+-- straddling ranges as we walk the second diet set.
+intersection :: forall a arr. (Contiguous arr, Element arr a, Ord a, Enum a)
+  => Set arr a
+  -> Set arr a
+  -> Set arr a
+intersection setA@(Set arrA) setB@(Set arrB)
+  | szA == 0 = empty
+  | szB == 0 = empty
+  | otherwise =
+      let inners :: Int -> [Set arr a]
+          inners !ix = if ix < szB
+            then
+              let inner = betweenInclusive
+                    (I.index arrB (2 * ix))
+                    (I.index arrB (2 * ix + 1))
+                    (Set arrA)
+               in inner : inners (ix + 1) 
+            else []
+          -- we should use a more efficient concat since
+          -- we know everything is ordered.
+       in concat (inners 0)
   where
     !szA = size setA
     !szB = size setB
diff --git a/src/Data/Diet/Set/Lifted.hs b/src/Data/Diet/Set/Lifted.hs
--- a/src/Data/Diet/Set/Lifted.hs
+++ b/src/Data/Diet/Set/Lifted.hs
@@ -5,10 +5,12 @@
 
 {-# OPTIONS_GHC -O2 #-}
 module Data.Diet.Set.Lifted
-  ( Set
+  ( Set(..)
   , singleton
   , member
   , difference
+  , intersection
+  , negate
     -- * Split
   , aboveInclusive
   , belowInclusive
@@ -20,7 +22,7 @@
   , fromListN
   ) where
 
-import Prelude hiding (lookup,map,foldr)
+import Prelude hiding (lookup,map,foldr,negate)
 
 import Data.Semigroup (Semigroup)
 import Data.Primitive (Array)
@@ -28,6 +30,9 @@
 import qualified Data.Semigroup as SG
 import qualified Data.Diet.Set.Internal as I
 
+-- | A diet set. Currently, the data constructor for this type is
+-- exported. Please do not use it. It will be moved to an internal
+-- module at some point.
 newtype Set a = Set (I.Set Array a)
 
 -- | /O(1)/ Create a diet set with a single element.
@@ -82,6 +87,21 @@
   -> Set a -- ^ subtrahend
   -> Set a
 difference (Set x) (Set y) = Set (I.difference x y)
+
+-- | The intersection of two diet sets.
+intersection :: (Ord a, Enum a)
+  => Set a -- ^ minuend
+  -> Set a -- ^ subtrahend
+  -> Set a
+intersection (Set x) (Set y) = Set (I.intersection x y)
+
+-- | The negation of a diet set. The resulting set contains
+-- all elements that were not contained by the argument set,
+-- and it only contains these elements.
+negate :: (Ord a, Enum a, Bounded a)
+  => Set a
+  -> Set a
+negate (Set x) = Set (I.negate x)
 
 foldr :: (a -> a -> b -> b) -> b -> Set a -> b
 foldr f z (Set arr) = I.foldr f z arr
diff --git a/src/Data/Diet/Set/Unboxed.hs b/src/Data/Diet/Set/Unboxed.hs
--- a/src/Data/Diet/Set/Unboxed.hs
+++ b/src/Data/Diet/Set/Unboxed.hs
@@ -5,10 +5,12 @@
 
 {-# OPTIONS_GHC -O2 #-}
 module Data.Diet.Set.Unboxed
-  ( Set
+  ( Set(..)
   , singleton
   , member
   , difference
+  , intersection
+  , negate
     -- * Split
   , aboveInclusive
   , belowInclusive
@@ -21,7 +23,7 @@
   , fromListN
   ) where
 
-import Prelude hiding (lookup,map,foldr)
+import Prelude hiding (lookup,map,foldr,negate)
 
 import Data.Semigroup (Semigroup)
 import Data.Functor.Classes (Show2(..))
@@ -31,6 +33,8 @@
 import qualified Data.Semigroup as SG
 import qualified Data.Diet.Set.Internal as I
 
+-- | A diet set. Currently, the data constructor for this type is
+-- exported. Please do not use it.
 newtype Set a = Set (I.Set PrimArray a)
 
 -- | /O(1)/ Create a diet set with a single element.
@@ -88,6 +92,21 @@
   -> Set a -- ^ subtrahend
   -> Set a
 difference (Set x) (Set y) = Set (I.difference x y)
+
+-- | The intersection of two diet sets.
+intersection :: (Ord a, Enum a, Prim a)
+  => Set a -- ^ minuend
+  -> Set a -- ^ subtrahend
+  -> Set a
+intersection (Set x) (Set y) = Set (I.intersection x y)
+
+-- | The negation of a diet set. The resulting set contains
+-- all elements that were not contained by the argument set,
+-- and it only contains these elements.
+negate :: (Ord a, Enum a, Prim a, Bounded a)
+  => Set a
+  -> Set a
+negate (Set x) = Set (I.negate x)
 
 foldr :: Prim a => (a -> a -> b -> b) -> b -> Set a -> b
 foldr f z (Set arr) = I.foldr f z arr
diff --git a/src/Data/Map/Internal.hs b/src/Data/Map/Internal.hs
--- a/src/Data/Map/Internal.hs
+++ b/src/Data/Map/Internal.hs
@@ -11,19 +11,30 @@
   ( Map
   , empty
   , singleton
+  , null
   , map
+  , mapWithKey
   , mapMaybe
+  , mapMaybeWithKey
     -- * Folds
+  , foldrWithKey
   , foldlWithKey'
   , foldrWithKey'
+  , foldMapWithKey
   , foldMapWithKey'
     -- * Monadic Folds
   , foldlWithKeyM'
   , foldrWithKeyM'
   , foldlMapWithKeyM'
   , foldrMapWithKeyM'
+    -- * Traversals
+  , traverseWithKey_
     -- * Functions
   , append
+  , appendWith
+  , appendKeyWith
+  , appendRightBiased
+  , intersectionWith
   , lookup
   , showsPrec
   , equals
@@ -31,23 +42,30 @@
   , toList
   , concat
   , size
+  , keys
+  , elems
+  , restrict
+  , rnf
     -- * List Conversion
   , fromListN
   , fromList
   , fromListAppend
   , fromListAppendN
+  , fromSet
     -- * Array Conversion
   , unsafeFreezeZip
+  , unsafeZipPresorted
   ) where
 
-import Prelude hiding (compare,showsPrec,lookup,map,concat)
+import Prelude hiding (compare,showsPrec,lookup,map,concat,null)
 
 import Control.Applicative (liftA2)
+import Control.DeepSeq (NFData)
 import Control.Monad.ST (ST,runST)
 import Data.Semigroup (Semigroup)
-import Data.Foldable (foldl')
 import Data.Primitive.Contiguous (Contiguous,Mutable,Element)
 import Data.Primitive.Sort (sortUniqueTaggedMutable)
+import Data.Set.Internal (Set(..))
 import qualified Data.List as L
 import qualified Data.Semigroup as SG
 import qualified Prelude as P
@@ -60,6 +78,9 @@
 empty :: (Contiguous karr, Contiguous varr) => Map karr varr k v
 empty = Map I.empty I.empty
 
+null :: Contiguous varr => Map karr varr k v -> Bool
+null (Map _ vals) = I.null vals
+
 singleton :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => k -> v -> Map karr varr k v
 singleton k v = Map
   ( runST $ do
@@ -87,11 +108,45 @@
       let (leftovers, result) = fromAscListWith combine (max 1 n) k v ys
        in concatWith combine (result : P.map (uncurry singleton) leftovers)
 
-fromListN :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => Int -> [(k,v)] -> Map karr varr k v
-fromListN = fromListWithN (\_ a -> a)
+fromListN :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)
+  => Int
+  -> [(k,v)]
+  -> Map karr varr k v
+{-# INLINABLE fromListN #-}
+fromListN n xs = runST $ do
+  (ks,vs) <- mutableArraysFromPairs (max n 1) xs
+  unsafeFreezeZip ks vs
 
+mutableArraysFromPairs :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)
+  => Int -- must be at least one
+  -> [(k,v)]
+  -> ST s (Mutable karr s k, Mutable varr s v)
+{-# INLINABLE mutableArraysFromPairs #-}
+mutableArraysFromPairs n xs = do
+  let go !ix !_ !ks !vs [] = return (ix,ks,vs)
+      go !ix !len !ks !vs ((k,v) : ys) = if ix < len
+        then do
+          I.write ks ix k
+          I.write vs ix v
+          go (ix + 1) len ks vs ys
+        else do
+          let len' = len * 2
+          ks' <- I.new len'
+          vs' <- I.new len'
+          I.copyMutable ks' 0 ks 0 len
+          I.copyMutable vs' 0 vs 0 len
+          I.write ks' ix k
+          I.write vs' ix v
+          go (ix + 1) len' ks' vs' ys
+  ks0 <- I.new n
+  vs0 <- I.new n
+  (len,ks',vs') <- go 0 n ks0 vs0 xs
+  ksFinal <- I.resize ks' len
+  vsFinal <- I.resize vs' len
+  return (ksFinal,vsFinal)
+
 fromList :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => [(k,v)] -> Map karr varr k v
-fromList = fromListN 1
+fromList = fromListN 8
 
 fromListAppendN :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v, Semigroup v) => Int -> [(k,v)] -> Map karr varr k v
 fromListAppendN = fromListWithN (SG.<>)
@@ -112,37 +167,37 @@
   I.write keys0 0 k0
   I.write vals0 0 v0
   let go :: forall s. Int -> k -> Int -> Mutable karr s k -> Mutable varr s v -> [(k,v)] -> ST s ([(k,v)], Map karr varr k v)
-      go !ix !_ !sz !keys !vals [] = if ix == sz
+      go !ix !_ !sz !theKeys !vals [] = if ix == sz
         then do
-          arrKeys <- I.unsafeFreeze keys
+          arrKeys <- I.unsafeFreeze theKeys
           arrVals <- I.unsafeFreeze vals
           return ([],Map arrKeys arrVals)
         else do
-          keys' <- I.resize keys ix
+          keys' <- I.resize theKeys ix
           arrKeys <- I.unsafeFreeze keys'
           vals' <- I.resize vals ix
           arrVals <- I.unsafeFreeze vals'
           return ([],Map arrKeys arrVals)
-      go !ix !old !sz !keys !vals ((k,v) : xs) = if ix < sz
+      go !ix !old !sz !theKeys !vals ((k,v) : xs) = if ix < sz
         then case P.compare k old of
           GT -> do
-            I.write keys ix k
+            I.write theKeys ix k
             I.write vals ix v
-            go (ix + 1) k sz keys vals xs
+            go (ix + 1) k sz theKeys vals xs
           EQ -> do
-            !oldVal <- I.read vals (ix - 1)
+            oldVal <- I.read vals (ix - 1)
             let !newVal = combine oldVal v
             I.write vals (ix - 1) newVal
-            go ix k sz keys vals xs
+            go ix k sz theKeys vals xs
           LT -> do
-            keys' <- I.resize keys ix
+            keys' <- I.resize theKeys ix
             arrKeys <- I.unsafeFreeze keys'
             vals' <- I.resize vals ix
             arrVals <- I.unsafeFreeze vals'
             return ((k,v) : xs,Map arrKeys arrVals)
         else do
           let sz' = sz * 2
-          keys' <- I.resize keys sz'
+          keys' <- I.resize theKeys sz'
           vals' <- I.resize vals sz'
           go ix old sz' keys' vals' ((k,v) : xs)
   go 1 k0 n keys0 vals0 xs0
@@ -152,10 +207,34 @@
 map f (Map k v) = Map k (I.map f v)
 
 -- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.
+mapWithKey :: forall karr varr k v w. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w)
+  => (k -> v -> w)
+  -> Map karr varr k v
+  -> Map karr varr k w
+{-# INLINEABLE mapWithKey #-}
+mapWithKey f (Map ks vs) = runST $ do
+  let !sz = I.size vs
+  !(karr :: Mutable karr s k) <- I.new sz
+  !(varr :: Mutable varr s w) <- I.new sz
+  let go !ix = if ix < sz
+        then do
+          k <- I.indexM ks ix
+          a <- I.indexM vs ix
+          I.write varr ix (f k a)
+          I.write karr ix k
+          go (ix + 1)
+        else return ix
+  dstLen <- go 0
+  ksFinal <- I.resize karr dstLen >>= I.unsafeFreeze
+  vsFinal <- I.resize varr dstLen >>= I.unsafeFreeze
+  return (Map ksFinal vsFinal)
+
+-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.
 mapMaybe :: forall karr varr k v w. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w)
   => (v -> Maybe w)
   -> Map karr varr k v
   -> Map karr varr k w
+{-# INLINEABLE mapMaybe #-}
 mapMaybe f (Map ks vs) = runST $ do
   let !sz = I.size vs
   !(karr :: Mutable karr s k) <- I.new sz
@@ -165,7 +244,7 @@
           a <- I.indexM vs ixSrc
           case f a of
             Nothing -> go (ixSrc + 1) ixDst
-            Just !b -> do
+            Just b -> do
               I.write varr ixDst b
               I.write karr ixDst =<< I.indexM ks ixSrc
               go (ixSrc + 1) (ixDst + 1)
@@ -175,6 +254,32 @@
   vsFinal <- I.resize varr dstLen >>= I.unsafeFreeze
   return (Map ksFinal vsFinal)
 
+-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.
+mapMaybeWithKey :: forall karr varr k v w. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Element varr w)
+  => (k -> v -> Maybe w)
+  -> Map karr varr k v
+  -> Map karr varr k w
+{-# INLINEABLE mapMaybeWithKey #-}
+mapMaybeWithKey f (Map ks vs) = runST $ do
+  let !sz = I.size vs
+  !(karr :: Mutable karr s k) <- I.new sz
+  !(varr :: Mutable varr s w) <- I.new sz
+  let go !ixSrc !ixDst = if ixSrc < sz
+        then do
+          k <- I.indexM ks ixSrc
+          a <- I.indexM vs ixSrc
+          case f k a of
+            Nothing -> go (ixSrc + 1) ixDst
+            Just !b -> do
+              I.write varr ixDst b
+              I.write karr ixDst k
+              go (ixSrc + 1) (ixDst + 1)
+        else return ixDst
+  dstLen <- go 0 0
+  ksFinal <- I.resize karr dstLen >>= I.unsafeFreeze
+  vsFinal <- I.resize varr dstLen >>= I.unsafeFreeze
+  return (Map ksFinal vsFinal)
+
 showsPrec :: (Contiguous karr, Element karr k, Show k, Contiguous varr, Element varr v, Show v) => Int -> Map karr varr k v -> ShowS
 showsPrec p xs = showParen (p > 10) $
   showString "fromList " . shows (toList xs)
@@ -182,17 +287,35 @@
 toList :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => Map karr varr k v -> [(k,v)]
 toList = foldrWithKey (\k v xs -> (k,v) : xs) []
 
-foldrWithKey :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => (k -> v -> b -> b) -> b -> Map karr varr k v -> b
-foldrWithKey f z (Map keys vals) =
+foldrWithKey :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v)
+  => (k -> v -> b -> b)
+  -> b
+  -> Map karr varr k v
+  -> b
+foldrWithKey f z (Map theKeys vals) =
   let !sz = I.size vals
       go !i
         | i == sz = z
         | otherwise =
-            let !k = I.index keys i
-                !v = I.index vals i
+            let !(# k #) = I.index# theKeys i
+                !(# v #) = I.index# vals i
              in f k v (go (i + 1))
    in go 0
 
+foldMapWithKey :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Monoid m)
+  => (k -> v -> m)
+  -> Map karr varr k v
+  -> m
+foldMapWithKey f (Map theKeys vals) =
+  let !sz = I.size vals
+      go !i
+        | i == sz = mempty
+        | otherwise =
+            let !(# k #) = I.index# theKeys i
+                !(# v #) = I.index# vals i
+             in mappend (f k v) (go (i + 1))
+   in go 0
+
 concat :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v, Semigroup v) => [Map karr varr k v] -> Map karr varr k v
 concat = concatWith (SG.<>)
 
@@ -202,18 +325,64 @@
   -> Map karr varr k v
 concatWith combine = C.concatSized size empty (appendWith combine)
 
-appendWith :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k) => (v -> v -> v) -> Map karr varr k v -> Map karr varr k v -> Map karr varr k v
-appendWith combine (Map ksA vsA) (Map ksB vsB) =
+appendRightBiased :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k) => Map karr varr k v -> Map karr varr k v -> Map karr varr k v
+appendRightBiased = appendWith const
+
+appendKeyWith :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k)
+  => (k -> v -> v -> v) -> Map karr varr k v -> Map karr varr k v -> Map karr varr k v
+appendKeyWith combine (Map ksA vsA) (Map ksB vsB) =
   case unionArrWith combine ksA vsA ksB vsB of
     (k,v) -> Map k v
   
-append :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k, Semigroup v) => Map karr varr k v -> Map karr varr k v -> Map karr varr k v
+appendWith :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k)
+  => (v -> v -> v) -> Map karr varr k v -> Map karr varr k v -> Map karr varr k v
+appendWith combine (Map ksA vsA) (Map ksB vsB) =
+  case unionArrWith (\_ x y -> combine x y) ksA vsA ksB vsB of
+    (k,v) -> Map k v
+  
+append :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k, Semigroup v)
+  => Map karr varr k v -> Map karr varr k v -> Map karr varr k v
 append (Map ksA vsA) (Map ksB vsB) =
-  case unionArrWith (SG.<>) ksA vsA ksB vsB of
+  case unionArrWith (\_ x y -> x SG.<> y) ksA vsA ksB vsB of
     (k,v) -> Map k v
   
+intersectionWith :: forall k v w x karr varr warr xarr.
+     (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Contiguous warr, Element warr w, Contiguous xarr, Element xarr x, Ord k)
+  => (v -> w -> x)
+  -> Map karr varr k v
+  -> Map karr warr k w
+  -> Map karr xarr k x
+intersectionWith f s1@(Map karr1 varr1) s2@(Map karr2 varr2)
+  | sz1 == 0 = empty
+  | sz2 == 0 = empty
+  | otherwise = runST $ do
+      let maxSz = min sz1 sz2
+      kdst <- I.new maxSz
+      vdst <- I.new maxSz
+      let go !ix1 !ix2 !dstIx = if ix2 < sz2 && ix1 < sz1
+            then do
+              k1 <- I.indexM karr1 ix1
+              k2 <- I.indexM karr2 ix2
+              case P.compare k1 k2 of
+                EQ -> do
+                  v1 <- I.indexM varr1 ix1
+                  v2 <- I.indexM varr2 ix2
+                  I.write kdst dstIx k1
+                  I.write vdst dstIx (f v1 v2)
+                  go (ix1 + 1) (ix2 + 1) (dstIx + 1)
+                LT -> go (ix1 + 1) ix2 dstIx
+                GT -> go ix1 (ix2 + 1) dstIx
+            else return dstIx
+      dstSz <- go 0 0 0
+      kdstFrozen <- I.resize kdst dstSz >>= I.unsafeFreeze
+      vdstFrozen <- I.resize vdst dstSz >>= I.unsafeFreeze
+      return (Map kdstFrozen vdstFrozen)
+  where
+    !sz1 = size s1
+    !sz2 = size s2
+
 unionArrWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)
-  => (v -> v -> v)
+  => (k -> v -> v -> v)
   -> karr k -- keys a
   -> varr v -- values a
   -> karr k -- keys b
@@ -232,12 +401,12 @@
               then do
                 let !keyA = I.index keysA ixA
                     !keyB = I.index keysB ixB
-                    !valA = I.index valsA ixA
-                    !valB = I.index valsB ixB
+                    !(# valA #) = I.index# valsA ixA
+                    !(# valB #) = I.index# valsB ixB
                 case P.compare keyA keyB of
                   EQ -> do
                     I.write keysDst ixDst keyA
-                    let !r = combine valA valB
+                    let r = combine keyA valA valB
                     I.write valsDst ixDst r
                     go (ixA + 1) (ixB + 1) (ixDst + 1)
                   LT -> do
@@ -263,7 +432,11 @@
       !valsFinal <- I.resize valsDst total
       liftA2 (,) (I.unsafeFreeze keysFinal) (I.unsafeFreeze valsFinal)
  
-lookup :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => k -> Map karr varr k v -> Maybe v
+lookup :: forall karr varr k v.
+     (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)
+  => k
+  -> Map karr varr k v
+  -> Maybe v
 lookup a (Map arr vals) = go 0 (I.size vals - 1) where
   go :: Int -> Int -> Maybe v
   go !start !end = if end < start
@@ -283,7 +456,9 @@
 
 -- | Sort and deduplicate the key array, preserving the last value associated
 -- with each key. The argument arrays may not be reused after being passed
--- to this function.
+-- to this function. This function is only unsafe because of the requirement
+-- that the arguments not be reused. If the arrays do not match in size, the
+-- larger one will be truncated to the length of the shorter one.
 unsafeFreezeZip :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)
   => Mutable karr s k
   -> Mutable varr s v
@@ -295,6 +470,19 @@
   return (Map keys2 vals2)
 {-# INLINEABLE unsafeFreezeZip #-}
 
+-- | There are two preconditions:
+--
+-- * The array of keys is sorted
+-- * The array of keys and the array of values have the same length.
+--
+-- If either of these conditions is not met, this function will introduce
+-- undefined behavior or segfaults.
+unsafeZipPresorted :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v)
+  => karr k -- array of keys, must already be sorted
+  -> varr v -- array of values
+  -> Map karr varr k v
+unsafeZipPresorted = Map
+
 foldlWithKeyM' :: forall karr varr k v m b. (Monad m, Contiguous karr, Element karr k, Contiguous varr, Element varr v)
   => (b -> k -> v -> m b)
   -> b
@@ -306,8 +494,8 @@
   go :: Int -> b -> m b
   go !ix !acc = if ix < len
     then
-      let (# k #) = I.index# ks ix
-          (# v #) = I.index# vs ix
+      let !(# k #) = I.index# ks ix
+          !(# v #) = I.index# vs ix
        in f acc k v >>= go (ix + 1)
     else return acc
 {-# INLINEABLE foldlWithKeyM' #-}
@@ -322,8 +510,8 @@
   go :: Int -> b -> m b
   go !ix !acc = if ix >= 0
     then
-      let (# k #) = I.index# ks ix
-          (# v #) = I.index# vs ix
+      let !(# k #) = I.index# ks ix
+          !(# v #) = I.index# vs ix
        in f k v acc >>= go (ix - 1)
     else return acc
 {-# INLINEABLE foldrWithKeyM' #-}
@@ -338,14 +526,30 @@
   go :: Int -> b -> m b
   go !ix !accl = if ix < len
     then
-      let (# k #) = I.index# ks ix
-          (# v #) = I.index# vs ix
+      let !(# k #) = I.index# ks ix
+          !(# v #) = I.index# vs ix
        in do
          accr <- f k v
          go (ix + 1) (mappend accl accr)
     else return accl
 {-# INLINEABLE foldlMapWithKeyM' #-}
 
+traverseWithKey_ :: forall karr varr k v m b. (Applicative m, Contiguous karr, Element karr k, Contiguous varr, Element varr v)
+  => (k -> v -> m b)
+  -> Map karr varr k v
+  -> m ()
+traverseWithKey_ f (Map ks vs) = go 0
+  where
+  !len = I.size vs
+  go :: Int -> m ()
+  go !ix = if ix < len
+    then
+      let !(# k #) = I.index# ks ix
+          !(# v #) = I.index# vs ix
+       in f k v *> go (ix + 1)
+    else pure ()
+{-# INLINEABLE traverseWithKey_ #-}
+
 foldrMapWithKeyM' :: forall karr varr k v m b. (Monad m, Contiguous karr, Element karr k, Contiguous varr, Element varr v, Monoid b)
   => (k -> v -> m b)
   -> Map karr varr k v
@@ -355,26 +559,26 @@
   go :: Int -> b -> m b
   go !ix !accr = if ix >= 0
     then
-      let (# k #) = I.index# ks ix
-          (# v #) = I.index# vs ix
+      let !(# k #) = I.index# ks ix
+          !(# v #) = I.index# vs ix
        in do
          accl <- f k v
-         go (ix + 1) (mappend accl accr)
+         go (ix - 1) (mappend accl accr)
     else return accr
 {-# INLINEABLE foldrMapWithKeyM' #-}
 
-foldMapWithKey' :: forall karr varr k v b. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Monoid b)
-  => (k -> v -> b)
+foldMapWithKey' :: forall karr varr k v m. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Monoid m)
+  => (k -> v -> m)
   -> Map karr varr k v
-  -> b
+  -> m
 foldMapWithKey' f (Map ks vs) = go 0 mempty
   where
   !len = I.size vs
-  go :: Int -> b -> b
+  go :: Int -> m -> m
   go !ix !accl = if ix < len
     then 
-      let (# k #) = I.index# ks ix
-          (# v #) = I.index# vs ix
+      let !(# k #) = I.index# ks ix
+          !(# v #) = I.index# vs ix
        in go (ix + 1) (mappend accl (f k v))
     else accl
 {-# INLINEABLE foldMapWithKey' #-}
@@ -390,8 +594,8 @@
   go :: Int -> b -> b
   go !ix !acc = if ix < len
     then 
-      let (# k #) = I.index# ks ix
-          (# v #) = I.index# vs ix
+      let !(# k #) = I.index# ks ix
+          !(# v #) = I.index# vs ix
        in go (ix + 1) (f acc k v)
     else acc
 {-# INLINEABLE foldlWithKey' #-}
@@ -406,9 +610,83 @@
   go :: Int -> b -> b
   go !ix !acc = if ix >= 0
     then
-      let (# k #) = I.index# ks ix
-          (# v #) = I.index# vs ix
+      let !(# k #) = I.index# ks ix
+          !(# v #) = I.index# vs ix
        in go (ix - 1) (f k v acc)
     else acc
 {-# INLINEABLE foldrWithKey' #-}
+
+-- The algorithm used here is good when the subset is small, but
+-- when the subset is large, it is worse that just walking the map.
+restrict :: forall karr varr k v. (Contiguous karr, Element karr k, Contiguous varr, Element varr v, Ord k)
+  => Map karr varr k v
+  -> Set karr k
+  -> Map karr varr k v
+restrict m@(Map ks vs) (Set rs)
+  | I.same ks rs = m
+  | otherwise = stage1 0
+  where
+  szMap = I.size vs
+  szSet = I.size rs
+  szMin = min szMap szSet
+  -- Locate the first difference between the two. This stage is useful
+  -- because, in the case that the subset perfectly matches the keys,
+  -- we do not need to do any copying.
+  stage1 :: Int -> Map karr varr k v
+  stage1 !ix = if ix < szMin
+    then
+      let !(# k #) = I.index# ks ix
+          !(# r #) = I.index# rs ix
+       in if k == r
+            then stage1 (ix + 1)
+            else stage2 ix
+    else if szMin == szMap
+      then m
+      else Map rs vs
+  -- In stage two, we walk the map and the set with possibly differing
+  -- indices, writing each matching key (along with its value) into
+  -- the result map.
+  stage2 :: Int -> Map karr varr k v
+  stage2 !ix = runST $ do
+    ksMut <- I.new szMin
+    vsMut <- I.new szMin
+    I.copy ksMut 0 ks 0 ix
+    I.copy vsMut 0 vs 0 ix
+    let -- TODO: Turn this into a galloping search. It would
+        -- probably be worth trying this out on
+        -- Data.Set.Internal.intersection first.
+        go !ixRes !ixm !ixs = if ixm < szMin && ixs < szMin
+          then do
+            k <- I.indexM ks ixm
+            r <- I.indexM rs ixs
+            case P.compare k r of
+              EQ -> do
+                I.write ksMut ixRes k
+                I.write vsMut ixRes =<< I.indexM vs ixm
+                go (ixRes + 1) (ixm + 1) (ixs + 1)
+              LT -> go ixRes (ixm + 1) ixs
+              GT -> go ixRes ixm (ixs + 1)
+          else return ixRes
+    total <- go ix ix ix
+    ks' <- I.resize ksMut total >>= I.unsafeFreeze
+    vs' <- I.resize vsMut total >>= I.unsafeFreeze
+    return (Map ks' vs')
+{-# INLINEABLE restrict #-}
+
+fromSet :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v)
+  => (k -> v)
+  -> Set karr k
+  -> Map karr varr k v
+fromSet f (Set arr) = Map arr (I.map f arr)
+
+keys :: Map karr varr k v -> Set karr k
+keys (Map k _) = Set k
+
+elems :: Map karr varr k v -> varr v
+elems (Map _ v) = v
+
+rnf :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v, NFData k, NFData v)
+  => Map karr varr k v
+  -> ()
+rnf (Map k v) = seq (I.rnf k) (seq (I.rnf v) ())
 
diff --git a/src/Data/Map/Lifted/Lifted.hs b/src/Data/Map/Lifted/Lifted.hs
--- a/src/Data/Map/Lifted/Lifted.hs
+++ b/src/Data/Map/Lifted/Lifted.hs
@@ -5,12 +5,15 @@
 
 {-# OPTIONS_GHC -O2 -Wall #-}
 module Data.Map.Lifted.Lifted
-  ( Map
+  ( Map(..)
+  , empty
   , singleton
   , lookup
   , size
   , map
   , mapMaybe
+  , mapMaybeWithKey
+  , union
     -- * Folds
   , foldlWithKey'
   , foldrWithKey'
@@ -25,12 +28,15 @@
   , fromListAppend
   , fromListN
   , fromListAppendN
+  , fromSet
+  , elems
   ) where
 
 import Prelude hiding (lookup,map)
 
 import Data.Semigroup (Semigroup)
 import Data.Primitive.Array (Array)
+import Data.Set.Lifted.Internal (Set(..))
 import qualified GHC.Exts as E
 import qualified Data.Semigroup as SG
 import qualified Data.Map.Internal as I
@@ -39,6 +45,9 @@
 --   type must both have 'Prim' instances.
 newtype Map k v = Map (I.Map Array Array k v)
 
+instance Functor (Map k) where
+  fmap = map
+
 instance (Ord k, Semigroup v) => Semigroup (Map k v) where
   Map x <> Map y = Map (I.append x y)
 
@@ -62,6 +71,10 @@
 instance (Show k, Show v) => Show (Map k v) where
   showsPrec p (Map s) = I.showsPrec p s
 
+-- | The empty diet map.
+empty :: Map k v
+empty = Map I.empty
+
 -- | /O(log n)/ Lookup the value at a key in the map.
 lookup :: Ord k => k -> Map k v -> Maybe v
 lookup a (Map s) = I.lookup a s
@@ -95,6 +108,15 @@
 fromListAppend :: (Ord k, Semigroup v) => [(k,v)] -> Map k v
 fromListAppend = Map . I.fromListAppend
 
+-- | /O(n)/ Build a map from a set. This function is uses the underlying
+-- array that backs the set as the array for the keys. It constructs the
+-- values by apply the given function to each key.
+fromSet ::
+     (k -> v)
+  -> Set k
+  -> Map k v
+fromSet f (Set s) = Map (I.fromSet f s)
+
 -- | /O(n*log n)/ This function has the same behavior as 'fromListN',
 -- but it combines values with the 'Semigroup' instances instead of
 -- choosing the last occurrence.
@@ -122,6 +144,14 @@
   -> Map k w
 mapMaybe f (Map m) = Map (I.mapMaybe f m)
 
+-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.
+-- The predicate is given access to the key.
+mapMaybeWithKey ::
+     (k -> v -> Maybe w)
+  -> Map k v
+  -> Map k w
+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m)
+
 -- | /O(n)/ Left monadic fold over the keys and values of the map. This fold
 -- is strict in the accumulator.
 foldlWithKeyM' :: Monad m
@@ -183,3 +213,13 @@
   -> Map k v -- ^ map
   -> b
 foldrWithKey' f b0 (Map m) = I.foldrWithKey' f b0 m
+
+-- | /O(n+m)/ The expression (@'union' t1 t2@) takes the left-biased union
+-- of @t1@ and @t2@. It prefers @t1@ when duplicate keys are encountered.
+union :: Ord k => Map k v -> Map k v -> Map k v
+union (Map a) (Map b) = Map (I.appendWith const a b)
+
+-- | /O(1)/ The values in a map. This is a zero-cost operation.
+elems :: Map k v -> Array v
+elems (Map m) = I.elems m
+
diff --git a/src/Data/Map/Subset/Internal.hs b/src/Data/Map/Subset/Internal.hs
deleted file mode 100644
--- a/src/Data/Map/Subset/Internal.hs
+++ /dev/null
@@ -1,170 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UnboxedTuples #-}
-
-module Data.Map.Subset.Internal
-  ( Map
-  , lookup
-  , empty
-  , singleton
-  , toList
-  , fromList
-  ) where
-
-import Prelude hiding (lookup,concat)
-
-import Data.Primitive.Contiguous (Contiguous,Element)
-import Data.Set.Internal (Set(..))
-import Data.Bifunctor (first)
-import Data.Semigroup (Semigroup,(<>),First(..))
-
-import qualified Data.Primitive.Contiguous as A
-import qualified Data.Set.Internal as S
-import qualified Data.Set.Lifted.Internal as SL
-import qualified Data.Semigroup as SG
-import qualified Prelude as P
-import qualified Data.Foldable as F
-
--- There are two invariants for Map.
---
--- 1. The children of any Map may only contain keys that are
---    greater than the key in their parent.
--- 2. A parent's two children must not be equal.
---
--- This type cannot be a Functor since it needs to uses
--- an Eq instance for a kind of simple compression.
-data Map k v
-  = MapElement !k !(Map k v) !(Map k v)
-  | MapValue !v
-  | MapEmpty
-  deriving (Eq,Ord)
-
-instance (Semigroup v, Eq v, Ord k) => Semigroup (Map k v) where
-  (<>) = append
-
-instance (Semigroup v, Eq v, Ord k) => Monoid (Map k v) where
-  mempty = empty
-  mappend = (SG.<>)
-  -- mconcat = concat 
-
-instance (Show k, Show v) => Show (Map k v) where
-  showsPrec p xs = showParen (p > 10) $
-    showString "fromList " . shows (P.map (first SL.Set) (toList xs))
-
--- the functon f must satisfy the following:
--- a == b <=> f a == f b
-unsafeMapValues :: (v -> w) -> Map k v -> Map k w
-unsafeMapValues f = go where
-  go MapEmpty = MapEmpty
-  go (MapValue x) = MapValue (f x)
-  go (MapElement k present absent) =
-    MapElement k (go present) (go absent)
-
-toList :: (Contiguous arr, Element arr k)
-  => Map k v
-  -> [(Set arr k,v)]
-toList = foldrWithKey (\k v xs -> (k,v) : xs) []
-
-fromList :: (Contiguous arr, Element arr k, Ord k, Eq v)
-  => [(Set arr k,v)]
-  -> Map k v
-fromList = unsafeMapValues getFirst . concat . P.map (\(s,v) -> singleton s (First v))
-
-concat :: (Ord k,Semigroup v,Eq v)
-  => [Map k v]
-  -> Map k v
-concat = F.foldl' (\r x -> append r x) empty
-
-foldrWithKey :: (Contiguous arr, Element arr k)
-  => (Set arr k -> v -> b -> b)
-  -> b
-  -> Map k v
-  -> b
-foldrWithKey f b0 = go 0 [] b0 where
-  go !_ !_ b MapEmpty = b
-  go !n !xs b (MapValue v) = f (Set (A.unsafeFromListReverseN n xs)) v b
-  go !n !xs b (MapElement k present absent) =
-    go (n + 1) (k : xs) (go n xs b absent) present
-
-empty :: Map k v
-empty = MapEmpty
-
-singleton :: (Eq v, Contiguous arr, Element arr k)
-  => Set arr k
-  -> v
-  -> Map k v
-singleton s v = S.foldr (\k m -> MapElement k m empty) (MapValue v) s
-  
-lookup :: forall arr k v. (Ord k, Contiguous arr, Element arr k)
-  => Set arr k
-  -> Map k v
-  -> Maybe v
-{-# INLINABLE lookup #-}
-lookup (Set arr) = go 0 where
-  !sz = A.size arr
-  go :: Int -> Map k v -> Maybe v
-  go !_ MapEmpty = Nothing
-  go !_ (MapValue v) = Just v
-  go !ix (MapElement element present absent) =
-    choose ix element present absent
-  choose :: Int -> k -> Map k v -> Map k v -> Maybe v
-  choose !ix element present absent = if ix < sz
-    then 
-      let (# k #) = A.index# arr ix
-       in case compare k element of
-            EQ -> go (ix + 1) present
-            LT -> choose (ix + 1) element present absent
-            GT -> go ix absent
-    else followAbsent absent
-
-followAbsent :: Map k v -> Maybe v
-followAbsent (MapElement _ _ x) = followAbsent x
-followAbsent (MapValue v) = Just v
-followAbsent MapEmpty = Nothing
-
-augment :: (Eq k, Eq v) => (v -> v) -> v -> Map k v -> Map k v
-augment _ v MapEmpty = MapValue v
-augment f _ (MapValue x) = MapValue (f x)
-augment f v (MapElement k present absent) =
-  let present' = augment f v present
-      absent' = augment f v absent
-   in if present' == absent'
-        then present' 
-        else MapElement k present' absent'
-
-append :: forall k v. (Semigroup v, Eq v, Ord k) => Map k v -> Map k v -> Map k v
-append = go where
-  go :: Map k v -> Map k v -> Map k v
-  go MapEmpty m = m
-  go (MapValue x) (MapValue y) = MapValue (x <> y)
-  go (MapValue x) MapEmpty = MapValue x
-  go (MapValue x) (MapElement elemY presentY absentY) =
-    augment (x SG.<>) x (MapElement elemY presentY absentY)
-  go (MapElement elemX presentX absentX) MapEmpty =
-    MapElement elemX presentX absentX
-  go (MapElement elemX presentX absentX) (MapValue y) =
-    augment (SG.<> y) y (MapElement elemX presentX absentX)
-  go (MapElement elemX presentX absentX) (MapElement elemY presentY absentY) = case compare elemX elemY of
-    EQ -> 
-      let present = go presentX presentY
-          absent = go absentX absentY
-       in if present == absent
-            then present
-            else MapElement elemX present absent
-    LT ->
-      let present = go presentX (MapElement elemY presentY absentY)
-          absent = go absentX (MapElement elemY presentY absentY)
-       in if present == absent
-            then present
-            else MapElement elemX present absent
-    GT ->
-      let present = go (MapElement elemX presentX absentX) presentY
-          absent = go (MapElement elemX presentX absentX) absentY
-       in if present == absent
-            then present
-            else MapElement elemY present absent
-      
diff --git a/src/Data/Map/Subset/Lazy/Internal.hs b/src/Data/Map/Subset/Lazy/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Map/Subset/Lazy/Internal.hs
@@ -0,0 +1,174 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Data.Map.Subset.Lazy.Internal
+  ( Map
+  , lookup
+  , empty
+  , singleton
+  , antisingleton
+  , fromPolarities
+  , toList
+  , fromList
+  ) where
+
+import Prelude hiding (lookup,concat)
+
+import Data.Bifunctor (first)
+import Data.Bool (bool)
+import Data.Primitive (Array)
+import Data.Primitive.Contiguous (Contiguous,Element)
+import Data.Semigroup (Semigroup,(<>),First(..))
+import Data.Set.Internal (Set(..))
+
+import qualified Data.Foldable as F
+import qualified Data.Map.Internal as M
+import qualified Data.Primitive.Contiguous as A
+import qualified Data.Semigroup as SG
+import qualified Data.Set.Internal as S
+import qualified Data.Set.Lifted.Internal as SL
+import qualified Prelude as P
+
+-- There are two invariants for Map.
+--
+-- 1. The children of any Map may only contain keys that are
+--    greater than the key in their parent.
+-- 2. A parent's two children must not be equal.
+--
+-- Unlike the strict variant, which imposes an Eq constraint on
+-- values, the lazy variant is able to have a Functor instance.
+data Map k v
+  = MapElement k (Map k v) (Map k v)
+  | MapValue v
+  | MapEmpty
+  deriving (Functor,Eq,Ord)
+
+instance (Semigroup v, Ord k) => Semigroup (Map k v) where
+  (<>) = append
+
+instance (Semigroup v, Ord k) => Monoid (Map k v) where
+  mempty = empty
+  mappend = (SG.<>)
+  -- mconcat = concat 
+
+instance (Show k, Show v) => Show (Map k v) where
+  showsPrec p xs = showParen (p > 10) $
+    showString "fromList " . shows (P.map (first SL.Set) (toList xs))
+
+toList :: (Contiguous arr, Element arr k)
+  => Map k v
+  -> [(Set arr k,v)]
+toList = foldrWithKey (\k v xs -> (k,v) : xs) []
+
+fromList :: (Contiguous arr, Element arr k, Ord k)
+  => [(Set arr k,v)]
+  -> Map k v
+fromList = fmap getFirst . concat . P.map (\(s,v) -> singleton s (First v))
+
+concat :: (Ord k,Semigroup v)
+  => [Map k v]
+  -> Map k v
+concat = F.foldl' (\r x -> append r x) empty
+
+foldrWithKey :: (Contiguous arr, Element arr k)
+  => (Set arr k -> v -> b -> b)
+  -> b
+  -> Map k v
+  -> b
+foldrWithKey f b0 = go 0 [] b0 where
+  go !_ !_ b MapEmpty = b
+  go !n !xs b (MapValue v) = f (Set (A.unsafeFromListReverseN n xs)) v b
+  go !n !xs b (MapElement k present absent) =
+    go (n + 1) (k : xs) (go n xs b absent) present
+
+empty :: Map k v
+empty = MapEmpty
+
+singleton :: (Contiguous arr, Element arr k)
+  => Set arr k
+  -> v
+  -> Map k v
+singleton s v = S.foldr (\k m -> MapElement k m empty) (MapValue v) s
+
+antisingleton :: (Contiguous arr, Element arr k)
+  => Set arr k
+  -> v
+  -> Map k v
+antisingleton s v = S.foldr (\k m -> MapElement k empty m) (MapValue v) s
+
+fromPolarities :: (Contiguous karr, Element karr k)
+  => M.Map karr Array k Bool
+  -> v
+  -> Map k v
+fromPolarities s v = M.foldrWithKey
+  (\k p m -> MapElement k (bool empty m p) (bool m empty p))
+  (MapValue v) s
+  
+lookup :: forall arr k v. (Ord k, Contiguous arr, Element arr k)
+  => Set arr k
+  -> Map k v
+  -> Maybe v
+{-# INLINABLE lookup #-}
+lookup (Set arr) = go 0 where
+  !sz = A.size arr
+  go :: Int -> Map k v -> Maybe v
+  go !_ MapEmpty = Nothing
+  go !_ (MapValue v) = Just v
+  go !ix (MapElement element present absent) =
+    choose ix element present absent
+  choose :: Int -> k -> Map k v -> Map k v -> Maybe v
+  choose !ix element present absent = if ix < sz
+    then 
+      let (# k #) = A.index# arr ix
+       in case compare k element of
+            EQ -> go (ix + 1) present
+            LT -> choose (ix + 1) element present absent
+            GT -> go ix absent
+    else followAbsent absent
+
+followAbsent :: Map k v -> Maybe v
+followAbsent (MapElement _ _ x) = followAbsent x
+followAbsent (MapValue v) = Just v
+followAbsent MapEmpty = Nothing
+
+augment :: Eq k => (v -> v) -> v -> Map k v -> Map k v
+augment _ v MapEmpty = MapValue v
+augment f _ (MapValue x) = MapValue (f x)
+augment f v (MapElement k present absent) =
+  let present' = augment f v present
+      absent' = augment f v absent
+   in MapElement k present' absent'
+
+append :: forall k v. (Semigroup v, Ord k) => Map k v -> Map k v -> Map k v
+append = go where
+  go :: Map k v -> Map k v -> Map k v
+  go MapEmpty m = m
+  go (MapValue x) (MapValue y) = MapValue (x <> y)
+  go (MapValue x) MapEmpty = MapValue x
+  go (MapValue x) (MapElement elemY presentY absentY) =
+    augment (x SG.<>) x (MapElement elemY presentY absentY)
+  go (MapElement elemX presentX absentX) MapEmpty =
+    MapElement elemX presentX absentX
+  go (MapElement elemX presentX absentX) (MapValue y) =
+    augment (SG.<> y) y (MapElement elemX presentX absentX)
+  go (MapElement elemX presentX absentX) (MapElement elemY presentY absentY) = case compare elemX elemY of
+    EQ -> 
+      let present = go presentX presentY
+          absent = go absentX absentY
+       in MapElement elemX present absent
+    LT ->
+      let present = go presentX (MapElement elemY presentY absentY)
+          absent = go absentX (MapElement elemY presentY absentY)
+       in MapElement elemX present absent
+    GT ->
+      let present = go (MapElement elemX presentX absentX) presentY
+          absent = go (MapElement elemX presentX absentX) absentY
+       in MapElement elemY present absent
+      
+
diff --git a/src/Data/Map/Subset/Lazy/Lifted.hs b/src/Data/Map/Subset/Lazy/Lifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Map/Subset/Lazy/Lifted.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Data.Map.Subset.Lazy.Lifted
+  ( I.Map
+  , I.empty
+    -- * Singleton Subset Maps
+  , singleton
+  , antisingleton
+  , fromPolarities
+    -- * Querying
+  , lookup
+    -- * List Conversion
+  , toList
+  , fromList
+  ) where
+
+import Prelude hiding (lookup)
+
+import Data.Map.Subset.Lazy.Internal (Map)
+import Data.Set.Lifted.Internal (Set(..))
+import Data.Bifunctor (first)
+import Data.Semigroup (Semigroup)
+
+import qualified Data.Map.Lifted.Lifted as M
+import qualified Data.Map.Subset.Lazy.Internal as I
+
+-- | A subset map with a single set as its key.
+singleton :: 
+     Set k
+  -> v
+  -> Map k v
+singleton (Set s) v = I.singleton s v
+
+-- | A subset map with a single negative set as its key. That is,
+-- a lookup into this map will only succeed if the needle set and the
+-- negative set do not overlap.
+antisingleton ::
+     Set k -- ^ negative set
+  -> v -- ^ value
+  -> Map k v
+antisingleton (Set s) v = I.antisingleton s v
+
+-- | Construct a singleton subset map by interpreting a
+-- @Data.Map.Unlifted.Lifted.Map@ as requirements about
+-- what must be present and absent.
+fromPolarities ::
+     M.Map k Bool -- ^ Map of required presences and absences
+  -> v -- 
+  -> Map k v 
+fromPolarities (M.Map m) v = I.fromPolarities m v
+
+lookup :: Ord k => Set k -> Map k v -> Maybe v
+lookup (Set s) m = I.lookup s m
+
+toList :: Map k v -> [(Set k,v)]
+toList = map (first Set) . I.toList
+
+fromList :: Ord k => [(Set k,v)] -> Map k v
+fromList = I.fromList . map (first getSet)
+
diff --git a/src/Data/Map/Subset/Lazy/Unlifted.hs b/src/Data/Map/Subset/Lazy/Unlifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Map/Subset/Lazy/Unlifted.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Data.Map.Subset.Lazy.Unlifted
+  ( I.Map
+  , I.empty
+    -- * Singleton Subset Maps
+  , singleton
+  , antisingleton
+  , fromPolarities
+    -- * Querying
+  , lookup
+    -- * List Conversion
+  , toList
+  , fromList
+  ) where
+
+import Prelude hiding (lookup)
+
+import Data.Map.Subset.Lazy.Internal (Map)
+import Data.Set.Unlifted.Internal (Set(..))
+import Data.Bifunctor (first)
+import Data.Semigroup (Semigroup)
+import Data.Primitive (PrimUnlifted)
+
+import qualified Data.Map.Unlifted.Lifted as M
+import qualified Data.Map.Subset.Lazy.Internal as I
+
+-- | A subset map with a single set as its key.
+singleton :: PrimUnlifted k
+  => Set k
+  -> v
+  -> Map k v
+singleton (Set s) v = I.singleton s v
+
+-- | A subset map with a single negative set as its key. That is,
+-- a lookup into this map will only succeed if the needle set and the
+-- negative set do not overlap.
+antisingleton :: PrimUnlifted k
+  => Set k -- ^ negative set
+  -> v -- ^ value
+  -> Map k v
+antisingleton (Set s) v = I.antisingleton s v
+
+-- | Construct a singleton subset map by interpreting a
+-- @Data.Map.Unlifted.Lifted.Map@ as requirements about
+-- what must be present and absent.
+fromPolarities :: PrimUnlifted k
+  => M.Map k Bool -- ^ Map of required presences and absences
+  -> v -- 
+  -> Map k v 
+fromPolarities (M.Map m) v = I.fromPolarities m v
+
+lookup :: (Ord k, PrimUnlifted k) => Set k -> Map k v -> Maybe v
+lookup (Set s) m = I.lookup s m
+
+toList :: PrimUnlifted k => Map k v -> [(Set k,v)]
+toList = map (first Set) . I.toList
+
+fromList :: (Ord k, PrimUnlifted k) => [(Set k,v)] -> Map k v
+fromList = I.fromList . map (first getSet)
+
diff --git a/src/Data/Map/Subset/Lifted.hs b/src/Data/Map/Subset/Lifted.hs
deleted file mode 100644
--- a/src/Data/Map/Subset/Lifted.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UnboxedTuples #-}
-
-module Data.Map.Subset.Lifted
-  ( I.Map
-  , singleton
-  , lookup
-  , toList
-  , fromList
-  ) where
-
-import Prelude hiding (lookup)
-
-import Data.Map.Subset.Internal (Map)
-import Data.Set.Lifted.Internal (Set(..))
-import Data.Bifunctor (first)
-import Data.Semigroup (Semigroup)
-
-import qualified Data.Map.Subset.Internal as I
-
-singleton :: (Monoid v, Eq v)
-  => Set k
-  -> v
-  -> Map k v
-singleton (Set s) v = I.singleton s v
-
-lookup :: Ord k => Set k -> Map k v -> Maybe v
-lookup (Set s) m = I.lookup s m
-
-toList :: Map k v -> [(Set k,v)]
-toList = map (first Set) . I.toList
-
-fromList :: (Ord k, Eq v, Semigroup v) => [(Set k,v)] -> Map k v
-fromList = I.fromList . map (first getSet)
diff --git a/src/Data/Map/Subset/Strict/Internal.hs b/src/Data/Map/Subset/Strict/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Map/Subset/Strict/Internal.hs
@@ -0,0 +1,170 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Data.Map.Subset.Strict.Internal
+  ( Map
+  , lookup
+  , empty
+  , singleton
+  , toList
+  , fromList
+  ) where
+
+import Prelude hiding (lookup,concat)
+
+import Data.Primitive.Contiguous (Contiguous,Element)
+import Data.Set.Internal (Set(..))
+import Data.Bifunctor (first)
+import Data.Semigroup (Semigroup,(<>),First(..))
+
+import qualified Data.Primitive.Contiguous as A
+import qualified Data.Set.Internal as S
+import qualified Data.Set.Lifted.Internal as SL
+import qualified Data.Semigroup as SG
+import qualified Prelude as P
+import qualified Data.Foldable as F
+
+-- There are two invariants for Map.
+--
+-- 1. The children of any Map may only contain keys that are
+--    greater than the key in their parent.
+-- 2. A parent's two children must not be equal.
+--
+-- This type cannot be a Functor since it needs to uses
+-- an Eq instance for a kind of simple compression.
+data Map k v
+  = MapElement !k !(Map k v) !(Map k v)
+  | MapValue !v
+  | MapEmpty
+  deriving (Eq,Ord)
+
+instance (Semigroup v, Eq v, Ord k) => Semigroup (Map k v) where
+  (<>) = append
+
+instance (Semigroup v, Eq v, Ord k) => Monoid (Map k v) where
+  mempty = empty
+  mappend = (SG.<>)
+  -- mconcat = concat 
+
+instance (Show k, Show v) => Show (Map k v) where
+  showsPrec p xs = showParen (p > 10) $
+    showString "fromList " . shows (P.map (first SL.Set) (toList xs))
+
+-- the functon f must satisfy the following:
+-- a == b <=> f a == f b
+unsafeMapValues :: (v -> w) -> Map k v -> Map k w
+unsafeMapValues f = go where
+  go MapEmpty = MapEmpty
+  go (MapValue x) = MapValue (f x)
+  go (MapElement k present absent) =
+    MapElement k (go present) (go absent)
+
+toList :: (Contiguous arr, Element arr k)
+  => Map k v
+  -> [(Set arr k,v)]
+toList = foldrWithKey (\k v xs -> (k,v) : xs) []
+
+fromList :: (Contiguous arr, Element arr k, Ord k, Eq v)
+  => [(Set arr k,v)]
+  -> Map k v
+fromList = unsafeMapValues getFirst . concat . P.map (\(s,v) -> singleton s (First v))
+
+concat :: (Ord k,Semigroup v,Eq v)
+  => [Map k v]
+  -> Map k v
+concat = F.foldl' (\r x -> append r x) empty
+
+foldrWithKey :: (Contiguous arr, Element arr k)
+  => (Set arr k -> v -> b -> b)
+  -> b
+  -> Map k v
+  -> b
+foldrWithKey f b0 = go 0 [] b0 where
+  go !_ !_ b MapEmpty = b
+  go !n !xs b (MapValue v) = f (Set (A.unsafeFromListReverseN n xs)) v b
+  go !n !xs b (MapElement k present absent) =
+    go (n + 1) (k : xs) (go n xs b absent) present
+
+empty :: Map k v
+empty = MapEmpty
+
+singleton :: (Eq v, Contiguous arr, Element arr k)
+  => Set arr k
+  -> v
+  -> Map k v
+singleton s v = S.foldr (\k m -> MapElement k m empty) (MapValue v) s
+  
+lookup :: forall arr k v. (Ord k, Contiguous arr, Element arr k)
+  => Set arr k
+  -> Map k v
+  -> Maybe v
+{-# INLINABLE lookup #-}
+lookup (Set arr) = go 0 where
+  !sz = A.size arr
+  go :: Int -> Map k v -> Maybe v
+  go !_ MapEmpty = Nothing
+  go !_ (MapValue v) = Just v
+  go !ix (MapElement element present absent) =
+    choose ix element present absent
+  choose :: Int -> k -> Map k v -> Map k v -> Maybe v
+  choose !ix element present absent = if ix < sz
+    then 
+      let (# k #) = A.index# arr ix
+       in case compare k element of
+            EQ -> go (ix + 1) present
+            LT -> choose (ix + 1) element present absent
+            GT -> go ix absent
+    else followAbsent absent
+
+followAbsent :: Map k v -> Maybe v
+followAbsent (MapElement _ _ x) = followAbsent x
+followAbsent (MapValue v) = Just v
+followAbsent MapEmpty = Nothing
+
+augment :: (Eq k, Eq v) => (v -> v) -> v -> Map k v -> Map k v
+augment _ v MapEmpty = MapValue v
+augment f _ (MapValue x) = MapValue (f x)
+augment f v (MapElement k present absent) =
+  let present' = augment f v present
+      absent' = augment f v absent
+   in if present' == absent'
+        then present' 
+        else MapElement k present' absent'
+
+append :: forall k v. (Semigroup v, Eq v, Ord k) => Map k v -> Map k v -> Map k v
+append = go where
+  go :: Map k v -> Map k v -> Map k v
+  go MapEmpty m = m
+  go (MapValue x) (MapValue y) = MapValue (x <> y)
+  go (MapValue x) MapEmpty = MapValue x
+  go (MapValue x) (MapElement elemY presentY absentY) =
+    augment (x SG.<>) x (MapElement elemY presentY absentY)
+  go (MapElement elemX presentX absentX) MapEmpty =
+    MapElement elemX presentX absentX
+  go (MapElement elemX presentX absentX) (MapValue y) =
+    augment (SG.<> y) y (MapElement elemX presentX absentX)
+  go (MapElement elemX presentX absentX) (MapElement elemY presentY absentY) = case compare elemX elemY of
+    EQ -> 
+      let present = go presentX presentY
+          absent = go absentX absentY
+       in if present == absent
+            then present
+            else MapElement elemX present absent
+    LT ->
+      let present = go presentX (MapElement elemY presentY absentY)
+          absent = go absentX (MapElement elemY presentY absentY)
+       in if present == absent
+            then present
+            else MapElement elemX present absent
+    GT ->
+      let present = go (MapElement elemX presentX absentX) presentY
+          absent = go (MapElement elemX presentX absentX) absentY
+       in if present == absent
+            then present
+            else MapElement elemY present absent
+      
diff --git a/src/Data/Map/Subset/Strict/Lifted.hs b/src/Data/Map/Subset/Strict/Lifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Map/Subset/Strict/Lifted.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Data.Map.Subset.Strict.Lifted
+  ( I.Map
+  , singleton
+  , lookup
+  , toList
+  , fromList
+  ) where
+
+import Prelude hiding (lookup)
+
+import Data.Map.Subset.Strict.Internal (Map)
+import Data.Set.Lifted.Internal (Set(..))
+import Data.Bifunctor (first)
+import Data.Semigroup (Semigroup)
+
+import qualified Data.Map.Subset.Strict.Internal as I
+
+singleton :: Eq v
+  => Set k
+  -> v
+  -> Map k v
+singleton (Set s) v = I.singleton s v
+
+lookup :: Ord k => Set k -> Map k v -> Maybe v
+lookup (Set s) m = I.lookup s m
+
+toList :: Map k v -> [(Set k,v)]
+toList = map (first Set) . I.toList
+
+fromList :: (Ord k, Eq v, Semigroup v) => [(Set k,v)] -> Map k v
+fromList = I.fromList . map (first getSet)
diff --git a/src/Data/Map/Subset/Strict/Unlifted.hs b/src/Data/Map/Subset/Strict/Unlifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Map/Subset/Strict/Unlifted.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Data.Map.Subset.Strict.Unlifted
+  ( I.Map
+  , singleton
+  , lookup
+  , toList
+  , fromList
+  ) where
+
+import Prelude hiding (lookup)
+
+import Data.Map.Subset.Strict.Internal (Map)
+import Data.Set.Unlifted.Internal (Set(..))
+import Data.Bifunctor (first)
+import Data.Semigroup (Semigroup)
+import Data.Primitive (PrimUnlifted)
+
+import qualified Data.Map.Subset.Strict.Internal as I
+
+singleton :: (PrimUnlifted k, Monoid v, Eq v)
+  => Set k
+  -> v
+  -> Map k v
+singleton (Set s) v = I.singleton s v
+
+lookup :: (Ord k, PrimUnlifted k) => Set k -> Map k v -> Maybe v
+lookup (Set s) m = I.lookup s m
+
+toList :: PrimUnlifted k => Map k v -> [(Set k,v)]
+toList = map (first Set) . I.toList
+
+fromList :: (Ord k, PrimUnlifted k, Eq v, Semigroup v) => [(Set k,v)] -> Map k v
+fromList = I.fromList . map (first getSet)
+
diff --git a/src/Data/Map/Unboxed/Lifted.hs b/src/Data/Map/Unboxed/Lifted.hs
--- a/src/Data/Map/Unboxed/Lifted.hs
+++ b/src/Data/Map/Unboxed/Lifted.hs
@@ -6,12 +6,21 @@
 {-# OPTIONS_GHC -O2 #-}
 module Data.Map.Unboxed.Lifted
   ( Map
+  , empty
   , singleton
   , lookup
   , size
   , map
   , mapMaybe
+  , mapMaybeWithKey
+  , keys
+  , intersectionWith
+  , restrict
     -- * Folds
+  , foldrWithKey
+  , foldlWithKey'
+  , foldrWithKey'
+  , foldMapWithKey
   , foldMapWithKey'
     -- * Monadic Folds
   , foldlWithKeyM'
@@ -19,20 +28,25 @@
   , foldlMapWithKeyM'
   , foldrMapWithKeyM'
     -- * List Conversion
+  , toList
   , fromList
   , fromListAppend
   , fromListN
   , fromListAppendN
+  , elems
     -- * Array Conversion
   , unsafeFreezeZip
   ) where
 
 import Prelude hiding (lookup,map)
 
+import Control.DeepSeq (NFData)
 import Control.Monad.ST (ST)
 import Data.Semigroup (Semigroup)
 import Data.Primitive.Types (Prim)
 import Data.Primitive (PrimArray,Array,MutablePrimArray,MutableArray)
+import Data.Set.Unboxed.Internal (Set(..))
+import qualified Control.DeepSeq
 import qualified GHC.Exts as E
 import qualified Data.Semigroup as SG
 import qualified Data.Map.Internal as I
@@ -45,6 +59,9 @@
 instance Prim k => Functor (Map k) where
   fmap = map
 
+instance (Prim k, NFData k, NFData v) => NFData (Map k v) where
+  rnf (Map m) = I.rnf m
+
 instance (Prim k, Ord k, Semigroup v) => Semigroup (Map k v) where
   Map x <> Map y = Map (I.append x y)
 
@@ -72,10 +89,18 @@
 lookup :: (Prim k, Ord k) => k -> Map k v -> Maybe v
 lookup a (Map s) = I.lookup a s
 
+-- | The empty map.
+empty :: Map k v
+empty = Map I.empty
+
 -- | /O(1)/ Create a map with a single element.
 singleton :: (Prim k) => k -> v -> Map k v
 singleton k v = Map (I.singleton k v)
 
+-- | /O(n)/ A list of key-value pairs in ascending order.
+toList :: (Prim k, Ord k, Prim v) => Map k v -> [(k,v)]
+toList (Map m) = I.toList m
+
 -- | /O(n*log n)/ Create a map from a list of key-value pairs.
 -- If the list contains more than one value for the same key,
 -- the last value is retained. If the keys in the argument are
@@ -128,6 +153,14 @@
   -> Map k w
 mapMaybe f (Map m) = Map (I.mapMaybe f m)
 
+-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.
+-- The predicate is given access to the key.
+mapMaybeWithKey :: Prim k
+  => (k -> v -> Maybe w)
+  -> Map k v
+  -> Map k w
+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m)
+
 -- | /O(n)/ Left monadic fold over the keys and values of the map. This fold
 -- is strict in the accumulator.
 foldlWithKeyM' :: (Monad m, Prim k)
@@ -164,6 +197,40 @@
   -> m b
 foldrMapWithKeyM' f (Map m) = I.foldrMapWithKeyM' f m
 
+-- | /O(n)/ Left fold over the keys and values with a strict accumulator.
+foldlWithKey' :: Prim k
+  => (b -> k -> v -> b) -- ^ reduction
+  -> b -- ^ initial accumulator
+  -> Map k v -- ^ map
+  -> b
+foldlWithKey' f b0 (Map m) = I.foldlWithKey' f b0 m
+
+-- | /O(n)/ Right fold over the keys and values with a lazy accumulator.
+foldrWithKey :: Prim k
+  => (k -> v -> b -> b) -- ^ reduction
+  -> b -- ^ initial accumulator
+  -> Map k v -- ^ map
+  -> b
+foldrWithKey f b0 (Map m) = I.foldrWithKey f b0 m
+
+-- | /O(n)/ Right fold over the keys and values with a strict accumulator.
+foldrWithKey' :: Prim k
+  => (k -> v -> b -> b) -- ^ reduction
+  -> b -- ^ initial accumulator
+  -> Map k v -- ^ map
+  -> b
+foldrWithKey' f b0 (Map m) = I.foldrWithKey' f b0 m
+
+-- | /O(n)/ Fold over the keys and values of the map with a lazy monoidal
+-- accumulator. This function does not have left and right variants since
+-- the associativity required by a monoid instance means that both variants
+-- would always produce the same result.
+foldMapWithKey :: (Monoid b, Prim k)
+  => (k -> v -> b)
+  -> Map k v
+  -> b
+foldMapWithKey f (Map m) = I.foldMapWithKey f m
+
 -- | /O(n)/ Fold over the keys and values of the map with a strict monoidal
 -- accumulator. This function does not have left and right variants since
 -- the associativity required by a monoid instance means that both variants
@@ -188,4 +255,26 @@
   => MutablePrimArray s k
   -> MutableArray s v
   -> ST s (Map k v)
-unsafeFreezeZip keys vals = fmap Map (I.unsafeFreezeZip keys vals)
+unsafeFreezeZip theKeys vals = fmap Map (I.unsafeFreezeZip theKeys vals)
+
+-- | /O(1)/ Get the keys from the map.
+keys :: Map k v -> Set k
+keys (Map m) = Set (I.keys m)
+
+intersectionWith :: (Prim k, Ord k)
+  => (a -> b -> c)
+  -> Map k a
+  -> Map k b
+  -> Map k c
+intersectionWith f (Map a) (Map b) = Map (I.intersectionWith f a b)
+
+restrict :: (Prim k, Ord k)
+  => Map k v
+  -> Set k
+  -> Map k v
+restrict (Map m) (Set s) = Map (I.restrict m s)
+
+-- | /O(1)/ The values in a map. This is a zero-cost operation.
+elems :: Map k v -> Array v
+elems (Map m) = I.elems m
+
diff --git a/src/Data/Map/Unboxed/Unboxed.hs b/src/Data/Map/Unboxed/Unboxed.hs
--- a/src/Data/Map/Unboxed/Unboxed.hs
+++ b/src/Data/Map/Unboxed/Unboxed.hs
@@ -6,11 +6,13 @@
 {-# OPTIONS_GHC -O2 -Wall #-}
 module Data.Map.Unboxed.Unboxed
   ( Map
+  , empty
   , singleton
   , lookup
   , size
   , map
   , mapMaybe
+  , mapMaybeWithKey
     -- * Folds
   , foldlWithKey'
   , foldrWithKey'
@@ -20,7 +22,10 @@
   , foldrWithKeyM'
   , foldlMapWithKeyM'
   , foldrMapWithKeyM'
+    -- * Traversals
+  , traverseWithKey_
     -- * List Conversion
+  , toList
   , fromList
   , fromListAppend
   , fromListN
@@ -70,10 +75,18 @@
 lookup :: (Prim k, Ord k, Prim v) => k -> Map k v -> Maybe v
 lookup a (Map s) = I.lookup a s
 
+-- | The empty diet map.
+empty :: Map k v
+empty = Map I.empty
+
 -- | /O(1)/ Create a map with a single element.
 singleton :: (Prim k, Prim v) => k -> v -> Map k v
 singleton k v = Map (I.singleton k v)
 
+-- | /O(n)/ A list of key-value pairs in ascending order.
+toList :: (Prim k, Ord k, Prim v) => Map k v -> [(k,v)]
+toList (Map m) = I.toList m
+
 -- | /O(n*log n)/ Create a map from a list of key-value pairs.
 -- If the list contains more than one value for the same key,
 -- the last value is retained. If the keys in the argument are
@@ -126,6 +139,14 @@
   -> Map k w
 mapMaybe f (Map m) = Map (I.mapMaybe f m)
 
+-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.
+-- The predicate is given access to the key.
+mapMaybeWithKey :: (Prim k, Prim v, Prim w)
+  => (k -> v -> Maybe w)
+  -> Map k v
+  -> Map k w
+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m)
+
 -- | /O(n)/ Left monadic fold over the keys and values of the map. This fold
 -- is strict in the accumulator.
 foldlWithKeyM' :: (Monad m, Prim k, Prim v)
@@ -161,6 +182,13 @@
   -> Map k v -- ^ map
   -> m b
 foldrMapWithKeyM' f (Map m) = I.foldrMapWithKeyM' f m
+
+-- | /O(n)/ Traverse the keys and values of the map from left to right.
+traverseWithKey_ :: (Monad m, Prim k, Prim v)
+  => (k -> v -> m b) -- ^ reduction
+  -> Map k v -- ^ map
+  -> m ()
+traverseWithKey_ f (Map m) = I.traverseWithKey_ f m
 
 -- | /O(n)/ Fold over the keys and values of the map with a strict monoidal
 -- accumulator. This function does not have left and right variants since
diff --git a/src/Data/Map/Unboxed/Unlifted.hs b/src/Data/Map/Unboxed/Unlifted.hs
--- a/src/Data/Map/Unboxed/Unlifted.hs
+++ b/src/Data/Map/Unboxed/Unlifted.hs
@@ -6,22 +6,38 @@
 {-# OPTIONS_GHC -O2 #-}
 module Data.Map.Unboxed.Unlifted
   ( Map
+  , empty
   , singleton
   , lookup
   , size
+  , map
+  , mapMaybe
+  , mapMaybeWithKey
+    -- * Folds
+  , foldlWithKey'
+  , foldrWithKey'
+  , foldMapWithKey'
+    -- * Monadic Folds
+  , foldlWithKeyM'
+  , foldrWithKeyM'
+  , foldlMapWithKeyM'
+  , foldrMapWithKeyM'
     -- * List Conversion
   , fromList
   , fromListAppend
   , fromListN
   , fromListAppendN
+    -- * Array Conversion
+  , unsafeFreezeZip
   ) where
 
-import Prelude hiding (lookup)
+import Prelude hiding (lookup,map)
 
 import Data.Semigroup (Semigroup)
 import Data.Primitive.Types (Prim)
-import Data.Primitive.UnliftedArray (PrimUnlifted,UnliftedArray)
-import Data.Primitive (PrimArray)
+import Data.Primitive.UnliftedArray (PrimUnlifted,UnliftedArray,MutableUnliftedArray)
+import Data.Primitive (PrimArray,MutablePrimArray)
+import Control.Monad.ST (ST)
 import qualified GHC.Exts as E
 import qualified Data.Semigroup as SG
 import qualified Data.Map.Internal as I
@@ -53,6 +69,10 @@
 instance (Prim k, Show k, PrimUnlifted v, Show v) => Show (Map k v) where
   showsPrec p (Map s) = I.showsPrec p s
 
+-- | The empty diet map.
+empty :: Map k v
+empty = Map I.empty
+
 -- | /O(log n)/ Lookup the value at a key in the map.
 lookup :: (Prim k, Ord k, PrimUnlifted v) => k -> Map k v -> Maybe v
 lookup a (Map s) = I.lookup a s
@@ -99,4 +119,103 @@
 size :: PrimUnlifted v => Map k v -> Int
 size (Map m) = I.size m
 
+-- | /O(n)/ Map over the values in the map.
+map :: (Prim k, PrimUnlifted v, PrimUnlifted w)
+  => (v -> w)
+  -> Map k v
+  -> Map k w
+map f (Map m) = Map (I.map f m)
+
+-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.
+mapMaybe :: (Prim k, PrimUnlifted v, PrimUnlifted w)
+  => (v -> Maybe w)
+  -> Map k v
+  -> Map k w
+mapMaybe f (Map m) = Map (I.mapMaybe f m)
+
+-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.
+-- The predicate is given access to the key.
+mapMaybeWithKey :: (Prim k, PrimUnlifted v, PrimUnlifted w)
+  => (k -> v -> Maybe w)
+  -> Map k v
+  -> Map k w
+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m)
+
+-- | /O(n)/ Left monadic fold over the keys and values of the map. This fold
+-- is strict in the accumulator.
+foldlWithKeyM' :: (Monad m, Prim k, PrimUnlifted v)
+  => (b -> k -> v -> m b) -- ^ reduction
+  -> b -- ^ initial accumulator
+  -> Map k v -- ^ map
+  -> m b
+foldlWithKeyM' f b0 (Map m) = I.foldlWithKeyM' f b0 m
+
+-- | /O(n)/ Right monadic fold over the keys and values of the map. This fold
+-- is strict in the accumulator.
+foldrWithKeyM' :: (Monad m, Prim k, PrimUnlifted v)
+  => (k -> v -> b -> m b) -- ^ reduction
+  -> b -- ^ initial accumulator
+  -> Map k v -- ^ map
+  -> m b
+foldrWithKeyM' f b0 (Map m) = I.foldrWithKeyM' f b0 m
+
+-- | /O(n)/ Monadic left fold over the keys and values of the map with a strict
+-- monoidal accumulator. The monoidal accumulator is appended to the left
+-- after each reduction.
+foldlMapWithKeyM' :: (Monad m, Monoid b, Prim k, PrimUnlifted v)
+  => (k -> v -> m b) -- ^ reduction
+  -> Map k v -- ^ map
+  -> m b
+foldlMapWithKeyM' f (Map m) = I.foldlMapWithKeyM' f m
+
+-- | /O(n)/ Monadic right fold over the keys and values of the map with a strict
+-- monoidal accumulator. The monoidal accumulator is appended to the right
+-- after each reduction.
+foldrMapWithKeyM' :: (Monad m, Monoid b, Prim k, PrimUnlifted v)
+  => (k -> v -> m b) -- ^ reduction
+  -> Map k v -- ^ map
+  -> m b
+foldrMapWithKeyM' f (Map m) = I.foldrMapWithKeyM' f m
+
+-- | /O(n)/ Fold over the keys and values of the map with a strict monoidal
+-- accumulator. This function does not have left and right variants since
+-- the associativity required by a monoid instance means that both variants
+-- would always produce the same result.
+foldMapWithKey' :: (Monoid b, Prim k, PrimUnlifted v)
+  => (k -> v -> b) -- ^ reduction 
+  -> Map k v -- ^ map
+  -> b
+foldMapWithKey' f (Map m) = I.foldMapWithKey' f m
+
+-- | /O(n)/ Left fold over the keys and values with a strict accumulator.
+foldlWithKey' :: (Prim k, PrimUnlifted v)
+  => (b -> k -> v -> b) -- ^ reduction
+  -> b -- ^ initial accumulator
+  -> Map k v -- ^ map
+  -> b
+foldlWithKey' f b0 (Map m) = I.foldlWithKey' f b0 m
+
+-- | /O(n)/ Right fold over the keys and values with a strict accumulator.
+foldrWithKey' :: (Prim k, PrimUnlifted v)
+  => (k -> v -> b -> b) -- ^ reduction
+  -> b -- ^ initial accumulator
+  -> Map k v -- ^ map
+  -> b
+foldrWithKey' f b0 (Map m) = I.foldrWithKey' f b0 m
+
+-- | /O(n*log n)/ Zip an array of keys with an array of values. If they are
+-- not the same length, the longer one will be truncated to match the shorter
+-- one. This function sorts and deduplicates the array of keys, preserving the
+-- last value associated with each key. The argument arrays may not be
+-- reused after being passed to this function.
+--
+-- This is by far the fastest way to create a map, since the functions backing it
+-- are aggressively specialized. It internally uses a hybrid of mergesort and
+-- insertion sort provided by the @primitive-sort@ package. It generates much
+-- less garbage than any of the @fromList@ variants. 
+unsafeFreezeZip :: (Ord k, Prim k, PrimUnlifted v)
+  => MutablePrimArray s k
+  -> MutableUnliftedArray s v
+  -> ST s (Map k v)
+unsafeFreezeZip keys vals = fmap Map (I.unsafeFreezeZip keys vals)
 
diff --git a/src/Data/Map/Unlifted/Lifted.hs b/src/Data/Map/Unlifted/Lifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Map/Unlifted/Lifted.hs
@@ -0,0 +1,239 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Map.Unlifted.Lifted
+  ( Map(..)
+  , empty
+  , singleton
+  , lookup
+  , size
+  , map
+  , mapMaybe
+  , mapMaybeWithKey
+  , union
+    -- * Folds
+  , foldlWithKey'
+  , foldrWithKey'
+  , foldMapWithKey'
+    -- * Monadic Folds
+  , foldlWithKeyM'
+  , foldrWithKeyM'
+  , foldlMapWithKeyM'
+  , foldrMapWithKeyM'
+    -- * List Conversion
+  , fromList
+  , fromListAppend
+  , fromListN
+  , fromListAppendN
+  , fromSet
+    -- * Array Conversion
+  , unsafeFreezeZip
+  ) where
+
+import Prelude hiding (lookup,map)
+
+import Control.Monad.ST (ST)
+import Data.Semigroup (Semigroup)
+import Data.Primitive.UnliftedArray (PrimUnlifted,UnliftedArray,MutableUnliftedArray)
+import Data.Primitive (Array,MutableArray)
+import Data.Set.Unlifted.Internal (Set(..))
+import qualified GHC.Exts as E
+import qualified Data.Semigroup as SG
+import qualified Data.Map.Internal as I
+
+-- | A map from keys @k@ to values @v@. The key type must have a
+--   'PrimUnlifted' instance and the value type must have a 'Prim'
+--   instance.
+--
+--   The data constructor for this type should not be exported.
+--   I am working on this.
+newtype Map k v = Map (I.Map UnliftedArray Array k v)
+
+instance (PrimUnlifted k, Ord k, Semigroup v) => Semigroup (Map k v) where
+  Map x <> Map y = Map (I.append x y)
+
+instance (PrimUnlifted k, Ord k, Semigroup v) => Monoid (Map k v) where
+  mempty = Map I.empty
+  mappend = (SG.<>)
+  mconcat = Map . I.concat . E.coerce
+
+instance (PrimUnlifted k, Eq k, Eq v) => Eq (Map k v) where
+  Map x == Map y = I.equals x y
+
+instance (PrimUnlifted k, Ord k, Ord v) => Ord (Map k v) where
+  compare (Map x) (Map y) = I.compare x y
+
+instance (PrimUnlifted k, Ord k) => E.IsList (Map k v) where
+  type Item (Map k v) = (k,v)
+  fromListN n = Map . I.fromListN n
+  fromList = Map . I.fromList
+  toList (Map s) = I.toList s
+
+instance (PrimUnlifted k, Show k, Show v) => Show (Map k v) where
+  showsPrec p (Map s) = I.showsPrec p s
+
+-- | /O(log n)/ Lookup the value at a key in the map.
+lookup :: (PrimUnlifted k, Ord k) => k -> Map k v -> Maybe v
+lookup a (Map s) = I.lookup a s
+
+-- | The empty diet map.
+empty :: Map k v
+empty = Map I.empty
+
+-- | /O(1)/ Create a map with a single element.
+singleton :: PrimUnlifted k => k -> v -> Map k v
+singleton k v = Map (I.singleton k v)
+
+-- | /O(n*log n)/ Create a map from a list of key-value pairs.
+-- If the list contains more than one value for the same key,
+-- the last value is retained. If the keys in the argument are
+-- in nondescending order, this algorithm runs in /O(n)/ time instead.
+fromList :: (PrimUnlifted k, Ord k) => [(k,v)] -> Map k v
+fromList = Map . I.fromList
+
+-- | /O(n*log n)/ This function has the same behavior as 'fromList'
+-- regardless of whether or not the expected size is accurate. Additionally,
+-- negative sizes are handled correctly. The expected size is used as the
+-- size of the initially allocated buffer when building the 'Map'. If the
+-- keys in the argument are in nondescending order, this algorithm runs
+-- in /O(n)/ time.
+fromListN :: (PrimUnlifted k, Ord k)
+  => Int -- ^ expected size of resulting 'Map'
+  -> [(k,v)] -- ^ key-value pairs
+  -> Map k v
+fromListN n = Map . I.fromListN n
+
+-- | /O(n*log n)/ This function has the same behavior as 'fromList',
+-- but it combines values with the 'Semigroup' instances instead of
+-- choosing the last occurrence.
+fromListAppend :: (PrimUnlifted k, Ord k, Semigroup v) => [(k,v)] -> Map k v
+fromListAppend = Map . I.fromListAppend
+
+-- | /O(n)/ Build a map from a set. This function is uses the underlying
+-- array that backs the set as the array for the keys. It constructs the
+-- values by apply the given function to each key.
+fromSet :: PrimUnlifted k
+  => (k -> v)
+  -> Set k
+  -> Map k v
+fromSet f (Set s) = Map (I.fromSet f s)
+
+-- | /O(n*log n)/ This function has the same behavior as 'fromListN',
+-- but it combines values with the 'Semigroup' instances instead of
+-- choosing the last occurrence.
+fromListAppendN :: (PrimUnlifted k, Ord k, Semigroup v)
+  => Int -- ^ expected size of resulting 'Map'
+  -> [(k,v)] -- ^ key-value pairs
+  -> Map k v
+fromListAppendN n = Map . I.fromListAppendN n
+
+-- | /O(1)/ The number of elements in the map.
+size :: Map k v -> Int
+size (Map m) = I.size m
+
+-- | /O(n)/ Map over the values in the map.
+map :: PrimUnlifted k
+  => (v -> w)
+  -> Map k v
+  -> Map k w
+map f (Map m) = Map (I.map f m)
+
+-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.
+mapMaybe :: PrimUnlifted k
+  => (v -> Maybe w)
+  -> Map k v
+  -> Map k w
+mapMaybe f (Map m) = Map (I.mapMaybe f m)
+
+-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.
+-- The predicate is given access to the key.
+mapMaybeWithKey :: PrimUnlifted k
+  => (k -> v -> Maybe w)
+  -> Map k v
+  -> Map k w
+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m)
+
+-- | /O(n)/ Left monadic fold over the keys and values of the map. This fold
+-- is strict in the accumulator.
+foldlWithKeyM' :: (Monad m, PrimUnlifted k)
+  => (b -> k -> v -> m b) -- ^ reduction
+  -> b -- ^ initial accumulator
+  -> Map k v -- ^ map
+  -> m b
+foldlWithKeyM' f b0 (Map m) = I.foldlWithKeyM' f b0 m
+
+-- | /O(n)/ Right monadic fold over the keys and values of the map. This fold
+-- is strict in the accumulator.
+foldrWithKeyM' :: (Monad m, PrimUnlifted k)
+  => (k -> v -> b -> m b) -- ^ reduction
+  -> b -- ^ initial accumulator
+  -> Map k v -- ^ map
+  -> m b
+foldrWithKeyM' f b0 (Map m) = I.foldrWithKeyM' f b0 m
+
+-- | /O(n)/ Monadic left fold over the keys and values of the map with a strict
+-- monoidal accumulator. The monoidal accumulator is appended to the left
+-- after each reduction.
+foldlMapWithKeyM' :: (Monad m, Monoid b, PrimUnlifted k)
+  => (k -> v -> m b) -- ^ reduction
+  -> Map k v -- ^ map
+  -> m b
+foldlMapWithKeyM' f (Map m) = I.foldlMapWithKeyM' f m
+
+-- | /O(n)/ Monadic right fold over the keys and values of the map with a strict
+-- monoidal accumulator. The monoidal accumulator is appended to the right
+-- after each reduction.
+foldrMapWithKeyM' :: (Monad m, Monoid b, PrimUnlifted k)
+  => (k -> v -> m b) -- ^ reduction
+  -> Map k v -- ^ map
+  -> m b
+foldrMapWithKeyM' f (Map m) = I.foldrMapWithKeyM' f m
+
+-- | /O(n)/ Fold over the keys and values of the map with a strict monoidal
+-- accumulator. This function does not have left and right variants since
+-- the associativity required by a monoid instance means that both variants
+-- would always produce the same result.
+foldMapWithKey' :: (Monoid b, PrimUnlifted k)
+  => (k -> v -> b) -- ^ reduction 
+  -> Map k v -- ^ map
+  -> b
+foldMapWithKey' f (Map m) = I.foldMapWithKey' f m
+
+-- | /O(n)/ Left fold over the keys and values with a strict accumulator.
+foldlWithKey' :: PrimUnlifted k
+  => (b -> k -> v -> b) -- ^ reduction
+  -> b -- ^ initial accumulator
+  -> Map k v -- ^ map
+  -> b
+foldlWithKey' f b0 (Map m) = I.foldlWithKey' f b0 m
+
+-- | /O(n)/ Right fold over the keys and values with a strict accumulator.
+foldrWithKey' :: PrimUnlifted k
+  => (k -> v -> b -> b) -- ^ reduction
+  -> b -- ^ initial accumulator
+  -> Map k v -- ^ map
+  -> b
+foldrWithKey' f b0 (Map m) = I.foldrWithKey' f b0 m
+
+-- | /O(n*log n)/ Zip an array of keys with an array of values. If they are
+-- not the same length, the longer one will be truncated to match the shorter
+-- one. This function sorts and deduplicates the array of keys, preserving the
+-- last value associated with each key. The argument arrays may not be
+-- reused after being passed to this function.
+--
+-- This is by far the fastest way to create a map, since the functions backing it
+-- are aggressively specialized. It internally uses a hybrid of mergesort and
+-- insertion sort provided by the @primitive-sort@ package. It generates much
+-- less garbage than any of the @fromList@ variants. 
+unsafeFreezeZip :: (Ord k, PrimUnlifted k)
+  => MutableUnliftedArray s k
+  -> MutableArray s v
+  -> ST s (Map k v)
+unsafeFreezeZip keys vals = fmap Map (I.unsafeFreezeZip keys vals)
+
+-- | /O(n+m)/ The expression (@'union' t1 t2@) takes the left-biased union
+-- of @t1@ and @t2@. It prefers @t1@ when duplicate keys are encountered.
+union :: (Ord k, PrimUnlifted k) => Map k v -> Map k v -> Map k v
+union (Map a) (Map b) = Map (I.appendWith const a b)
+
diff --git a/src/Data/Map/Unlifted/Unboxed.hs b/src/Data/Map/Unlifted/Unboxed.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Map/Unlifted/Unboxed.hs
@@ -0,0 +1,231 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Map.Unlifted.Unboxed
+  ( Map
+  , empty
+  , singleton
+  , lookup
+  , size
+  , map
+  , mapMaybe
+  , mapMaybeWithKey
+    -- * Folds
+  , foldlWithKey'
+  , foldrWithKey'
+  , foldMapWithKey'
+    -- * Monadic Folds
+  , foldlWithKeyM'
+  , foldrWithKeyM'
+  , foldlMapWithKeyM'
+  , foldrMapWithKeyM'
+    -- * List Conversion
+  , fromList
+  , fromListAppend
+  , fromListN
+  , fromListAppendN
+  , fromSet
+    -- * Array Conversion
+  , unsafeFreezeZip
+  ) where
+
+import Prelude hiding (lookup,map)
+
+import Control.Monad.ST (ST)
+import Data.Semigroup (Semigroup)
+import Data.Primitive.Types (Prim)
+import Data.Primitive.UnliftedArray (PrimUnlifted,UnliftedArray,MutableUnliftedArray)
+import Data.Primitive.PrimArray (PrimArray,MutablePrimArray)
+import Data.Set.Unlifted.Internal (Set(..))
+import qualified GHC.Exts as E
+import qualified Data.Semigroup as SG
+import qualified Data.Map.Internal as I
+
+-- | A map from keys @k@ to values @v@. The key type must have a
+--   'PrimUnlifted' instance and the value type must have a 'Prim'
+--   instance.
+newtype Map k v = Map (I.Map UnliftedArray PrimArray k v)
+
+instance (PrimUnlifted k, Ord k, Prim v, Semigroup v) => Semigroup (Map k v) where
+  Map x <> Map y = Map (I.append x y)
+
+instance (PrimUnlifted k, Ord k, Prim v, Semigroup v) => Monoid (Map k v) where
+  mempty = Map I.empty
+  mappend = (SG.<>)
+  mconcat = Map . I.concat . E.coerce
+
+instance (PrimUnlifted k, Eq k, Prim v, Eq v) => Eq (Map k v) where
+  Map x == Map y = I.equals x y
+
+instance (PrimUnlifted k, Ord k, Prim v, Ord v) => Ord (Map k v) where
+  compare (Map x) (Map y) = I.compare x y
+
+instance (PrimUnlifted k, Ord k, Prim v) => E.IsList (Map k v) where
+  type Item (Map k v) = (k,v)
+  fromListN n = Map . I.fromListN n
+  fromList = Map . I.fromList
+  toList (Map s) = I.toList s
+
+instance (PrimUnlifted k, Show k, Prim v, Show v) => Show (Map k v) where
+  showsPrec p (Map s) = I.showsPrec p s
+
+-- | /O(log n)/ Lookup the value at a key in the map.
+lookup :: (PrimUnlifted k, Ord k, Prim v) => k -> Map k v -> Maybe v
+lookup a (Map s) = I.lookup a s
+
+-- | The empty diet map.
+empty :: Map k v
+empty = Map I.empty
+
+-- | /O(1)/ Create a map with a single element.
+singleton :: (PrimUnlifted k, Prim v) => k -> v -> Map k v
+singleton k v = Map (I.singleton k v)
+
+-- | /O(n*log n)/ Create a map from a list of key-value pairs.
+-- If the list contains more than one value for the same key,
+-- the last value is retained. If the keys in the argument are
+-- in nondescending order, this algorithm runs in /O(n)/ time instead.
+fromList :: (PrimUnlifted k, Ord k, Prim v) => [(k,v)] -> Map k v
+fromList = Map . I.fromList
+
+-- | /O(n*log n)/ This function has the same behavior as 'fromList'
+-- regardless of whether or not the expected size is accurate. Additionally,
+-- negative sizes are handled correctly. The expected size is used as the
+-- size of the initially allocated buffer when building the 'Map'. If the
+-- keys in the argument are in nondescending order, this algorithm runs
+-- in /O(n)/ time.
+fromListN :: (PrimUnlifted k, Ord k, Prim v)
+  => Int -- ^ expected size of resulting 'Map'
+  -> [(k,v)] -- ^ key-value pairs
+  -> Map k v
+fromListN n = Map . I.fromListN n
+
+-- | /O(n*log n)/ This function has the same behavior as 'fromList',
+-- but it combines values with the 'Semigroup' instances instead of
+-- choosing the last occurrence.
+fromListAppend :: (PrimUnlifted k, Ord k, Prim v, Semigroup v) => [(k,v)] -> Map k v
+fromListAppend = Map . I.fromListAppend
+
+-- | /O(n*log n)/ This function has the same behavior as 'fromListN',
+-- but it combines values with the 'Semigroup' instances instead of
+-- choosing the last occurrence.
+fromListAppendN :: (PrimUnlifted k, Ord k, Prim v, Semigroup v)
+  => Int -- ^ expected size of resulting 'Map'
+  -> [(k,v)] -- ^ key-value pairs
+  -> Map k v
+fromListAppendN n = Map . I.fromListAppendN n
+
+-- | /O(n)/ Build a map from a set. This function is uses the underlying
+-- array that backs the set as the array for the keys. It constructs the
+-- values by apply the given function to each key.
+fromSet :: (PrimUnlifted k, Prim v)
+  => (k -> v)
+  -> Set k
+  -> Map k v
+fromSet f (Set s) = Map (I.fromSet f s)
+
+-- | /O(1)/ The number of elements in the map.
+size :: Prim v => Map k v -> Int
+size (Map m) = I.size m
+
+-- | /O(n)/ Map over the values in the map.
+map :: (PrimUnlifted k, Prim v, Prim w)
+  => (v -> w)
+  -> Map k v
+  -> Map k w
+map f (Map m) = Map (I.map f m)
+
+-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.
+mapMaybe :: (PrimUnlifted k, Prim v, Prim w)
+  => (v -> Maybe w)
+  -> Map k v
+  -> Map k w
+mapMaybe f (Map m) = Map (I.mapMaybe f m)
+
+-- | /O(n)/ Drop elements for which the predicate returns 'Nothing'.
+-- The predicate is given access to the key.
+mapMaybeWithKey :: (PrimUnlifted k, Prim v, Prim w)
+  => (k -> v -> Maybe w)
+  -> Map k v
+  -> Map k w
+mapMaybeWithKey f (Map m) = Map (I.mapMaybeWithKey f m)
+
+-- | /O(n)/ Left monadic fold over the keys and values of the map. This fold
+-- is strict in the accumulator.
+foldlWithKeyM' :: (Monad m, PrimUnlifted k, Prim v)
+  => (b -> k -> v -> m b) -- ^ reduction
+  -> b -- ^ initial accumulator
+  -> Map k v -- ^ map
+  -> m b
+foldlWithKeyM' f b0 (Map m) = I.foldlWithKeyM' f b0 m
+
+-- | /O(n)/ Right monadic fold over the keys and values of the map. This fold
+-- is strict in the accumulator.
+foldrWithKeyM' :: (Monad m, PrimUnlifted k, Prim v)
+  => (k -> v -> b -> m b) -- ^ reduction
+  -> b -- ^ initial accumulator
+  -> Map k v -- ^ map
+  -> m b
+foldrWithKeyM' f b0 (Map m) = I.foldrWithKeyM' f b0 m
+
+-- | /O(n)/ Monadic left fold over the keys and values of the map with a strict
+-- monoidal accumulator. The monoidal accumulator is appended to the left
+-- after each reduction.
+foldlMapWithKeyM' :: (Monad m, Monoid b, PrimUnlifted k, Prim v)
+  => (k -> v -> m b) -- ^ reduction
+  -> Map k v -- ^ map
+  -> m b
+foldlMapWithKeyM' f (Map m) = I.foldlMapWithKeyM' f m
+
+-- | /O(n)/ Monadic right fold over the keys and values of the map with a strict
+-- monoidal accumulator. The monoidal accumulator is appended to the right
+-- after each reduction.
+foldrMapWithKeyM' :: (Monad m, Monoid b, PrimUnlifted k, Prim v)
+  => (k -> v -> m b) -- ^ reduction
+  -> Map k v -- ^ map
+  -> m b
+foldrMapWithKeyM' f (Map m) = I.foldrMapWithKeyM' f m
+
+-- | /O(n)/ Fold over the keys and values of the map with a strict monoidal
+-- accumulator. This function does not have left and right variants since
+-- the associativity required by a monoid instance means that both variants
+-- would always produce the same result.
+foldMapWithKey' :: (Monoid b, PrimUnlifted k, Prim v)
+  => (k -> v -> b) -- ^ reduction 
+  -> Map k v -- ^ map
+  -> b
+foldMapWithKey' f (Map m) = I.foldMapWithKey' f m
+
+-- | /O(n)/ Left fold over the keys and values with a strict accumulator.
+foldlWithKey' :: (PrimUnlifted k, Prim v)
+  => (b -> k -> v -> b) -- ^ reduction
+  -> b -- ^ initial accumulator
+  -> Map k v -- ^ map
+  -> b
+foldlWithKey' f b0 (Map m) = I.foldlWithKey' f b0 m
+
+-- | /O(n)/ Right fold over the keys and values with a strict accumulator.
+foldrWithKey' :: (PrimUnlifted k, Prim v)
+  => (k -> v -> b -> b) -- ^ reduction
+  -> b -- ^ initial accumulator
+  -> Map k v -- ^ map
+  -> b
+foldrWithKey' f b0 (Map m) = I.foldrWithKey' f b0 m
+
+-- | /O(n*log n)/ Zip an array of keys with an array of values. If they are
+-- not the same length, the longer one will be truncated to match the shorter
+-- one. This function sorts and deduplicates the array of keys, preserving the
+-- last value associated with each key. The argument arrays may not be
+-- reused after being passed to this function.
+--
+-- This is by far the fastest way to create a map, since the functions backing it
+-- are aggressively specialized. It internally uses a hybrid of mergesort and
+-- insertion sort provided by the @primitive-sort@ package. It generates much
+-- less garbage than any of the @fromList@ variants. 
+unsafeFreezeZip :: (Ord k, PrimUnlifted k, Prim v)
+  => MutableUnliftedArray s k
+  -> MutablePrimArray s v
+  -> ST s (Map k v)
+unsafeFreezeZip keys vals = fmap Map (I.unsafeFreezeZip keys vals)
+
diff --git a/src/Data/Set/Internal.hs b/src/Data/Set/Internal.hs
--- a/src/Data/Set/Internal.hs
+++ b/src/Data/Set/Internal.hs
@@ -10,8 +10,10 @@
 module Data.Set.Internal
   ( Set(..)
   , empty
+  , null
   , singleton
   , difference
+  , intersection
   , append
   , member
   , showsPrec
@@ -20,22 +22,29 @@
   , fromListN
   , fromList
   , toList
+  , toArray
   , size
   , concat
     -- * Folds
   , foldr
+  , foldMap
   , foldl'
   , foldr'
   , foldMap'
   , foldlM'
+  , liftHashWithSalt
+    -- * Traversals
+  , traverse_
+  , itraverse_
   ) where
 
-import Prelude hiding (compare,showsPrec,concat,foldr)
-import qualified Prelude as P
+import Prelude hiding (compare,showsPrec,concat,foldr,foldMap,null)
 
 import Control.Monad.ST (ST,runST)
+import Data.Hashable (Hashable)
 import Data.Primitive.UnliftedArray (PrimUnlifted(..))
 import Data.Primitive.Contiguous (Contiguous,Mutable,Element)
+import qualified Prelude as P
 import qualified Data.Primitive.Contiguous as A
 import qualified Data.Concatenation as C
 
@@ -48,6 +57,9 @@
 append :: (Contiguous arr, Element arr a, Ord a) => Set arr a -> Set arr a -> Set arr a
 append (Set x) (Set y) = Set (unionArr x y)
   
+null :: Contiguous arr => Set arr a -> Bool
+null (Set x) = A.null x
+
 empty :: Contiguous arr => Set arr a
 empty = Set A.empty
 
@@ -100,6 +112,33 @@
     !sz1 = size s1
     !sz2 = size s2
 
+intersection :: forall a arr. (Contiguous arr, Element arr a, Ord a)
+  => Set arr a
+  -> Set arr a
+  -> Set arr a
+intersection s1@(Set arr1) s2@(Set arr2)
+  | sz1 == 0 = empty
+  | sz2 == 0 = empty
+  | otherwise = runST $ do
+      dst <- A.new (min sz1 sz2)
+      let go !ix1 !ix2 !dstIx = if ix2 < sz2 && ix1 < sz1
+            then do
+              v1 <- A.indexM arr1 ix1
+              v2 <- A.indexM arr2 ix2
+              case P.compare v1 v2 of
+                EQ -> do
+                  A.write dst dstIx v1
+                  go (ix1 + 1) (ix2 + 1) (dstIx + 1)
+                LT -> go (ix1 + 1) ix2 dstIx
+                GT -> go ix1 (ix2 + 1) dstIx
+            else return dstIx
+      dstSz <- go 0 0 0
+      dstFrozen <- A.resize dst dstSz >>= A.unsafeFreeze
+      return (Set dstFrozen)
+  where
+    !sz1 = size s1
+    !sz2 = size s2
+
 fromAscList :: forall arr a. (Contiguous arr, Element arr a, Ord a)
   => Int -- initial size of buffer, must be 1 or higher
   -> a -- first element
@@ -140,6 +179,9 @@
 toList :: (Contiguous arr, Element arr a) => Set arr a -> [a]
 toList = foldr (:) []
 
+toArray :: Set arr a -> arr a
+toArray (Set a) = a
+
 member :: forall arr a. (Contiguous arr, Element arr a, Ord a) => a -> Set arr a -> Bool
 member a (Set arr) = go 0 (A.size arr - 1) where
   go :: Int -> Int -> Bool
@@ -227,6 +269,14 @@
 foldr f b0 (Set arr) = A.foldr f b0 arr
 {-# INLINEABLE foldr #-}
 
+-- | Monoidal fold over the elements in the set. This is lazy in the accumulator.
+foldMap :: (Contiguous arr, Element arr a, Monoid m)
+  => (a -> m)
+  -> Set arr a
+  -> m
+foldMap f (Set arr) = A.foldMap f arr
+{-# INLINEABLE foldMap #-}
+
 foldl' :: (Contiguous arr, Element arr a)
   => (b -> a -> b)
   -> b
@@ -257,3 +307,27 @@
   -> m b
 foldlM' f b0 (Set arr) = A.foldlM' f b0 arr
 {-# INLINEABLE foldlM' #-}
+
+traverse_ :: (Contiguous arr, Element arr a, Applicative m)
+  => (a -> m b)
+  -> Set arr a
+  -> m ()
+traverse_ f (Set arr) = A.traverse_ f arr
+{-# INLINEABLE traverse_ #-}
+
+itraverse_ :: (Contiguous arr, Element arr a, Applicative m)
+  => (Int -> a -> m b)
+  -> Set arr a
+  -> m ()
+itraverse_ f (Set arr) = A.itraverse_ f arr
+{-# INLINEABLE itraverse_ #-}
+
+liftHashWithSalt :: (Contiguous arr, Element arr a)
+  => (Int -> a -> Int)
+  -> Int -- ^ salt
+  -> Set arr a -- ^ set
+  -> Int
+liftHashWithSalt f s (Set arr) = A.liftHashWithSalt f s arr
+{-# INLINEABLE liftHashWithSalt #-}
+
+
diff --git a/src/Data/Set/Lifted.hs b/src/Data/Set/Lifted.hs
--- a/src/Data/Set/Lifted.hs
+++ b/src/Data/Set/Lifted.hs
@@ -6,12 +6,16 @@
 
 module Data.Set.Lifted
   ( Set
+  , empty
   , singleton
+  , null
   , member
   , size
   , difference
   , (\\)
-    -- * List Conversion
+  , intersection
+    -- * Conversion
+  , toArray
   , LI.toList
   , LI.fromList
     -- * Folds
@@ -19,11 +23,16 @@
   , LI.foldl'
   , LI.foldr'
   , foldMap'
+  , foldMap
+    -- * Traversals
+  , traverse_
+  , itraverse_
   ) where
 
-import Prelude hiding (foldr)
+import Prelude hiding (foldr,foldMap,null)
 import Data.Semigroup (Semigroup)
 import Data.Set.Lifted.Internal (Set(..))
+import Data.Primitive (Array)
 import qualified Data.Set.Internal as I
 import qualified Data.Set.Lifted.Internal as LI
 
@@ -31,10 +40,22 @@
 difference :: Ord a => Set a -> Set a -> Set a
 difference (Set x) (Set y) = Set (I.difference x y)
 
+-- | The intersection of two sets.
+intersection :: Ord a => Set a -> Set a -> Set a
+intersection (Set x) (Set y) = Set (I.intersection x y)
+
+-- | The empty set.
+empty :: Set a
+empty = Set I.empty
+
 -- | Infix operator for 'difference'.
 (\\) :: Ord a => Set a -> Set a -> Set a
 (\\) (Set x) (Set y) = Set (I.difference x y)
 
+-- | True if the set is empty
+null :: Set a -> Bool
+null (Set s) = I.null s
+
 -- | Test whether or not an element is present in a set.
 member :: Ord a => a -> Set a -> Bool
 member a (Set s) = I.member a s
@@ -54,3 +75,29 @@
   -> m
 foldMap' f (Set arr) = I.foldMap' f arr
 
+-- | Lazy monoidal fold over the elements in the set.
+foldMap :: Monoid m
+  => (a -> m)
+  -> Set a
+  -> m
+foldMap f (Set arr) = I.foldMap f arr
+
+-- | /O(1)/ Convert a set to an array. The elements are given in ascending
+-- order. This function is zero-cost.
+toArray :: Set a -> Array a
+toArray (Set s) = I.toArray s
+
+-- | Traverse a set, discarding the result.
+traverse_ :: Applicative m
+  => (a -> m b)
+  -> Set a
+  -> m ()
+traverse_ f (Set arr) = I.traverse_ f arr
+
+-- | Traverse a set with the indices, discarding the result.
+itraverse_ :: Applicative m
+  => (Int -> a -> m b)
+  -> Set a
+  -> m ()
+itraverse_ f (Set arr) = I.itraverse_ f arr
+{-# INLINEABLE itraverse_ #-}
diff --git a/src/Data/Set/Lifted/Internal.hs b/src/Data/Set/Lifted/Internal.hs
--- a/src/Data/Set/Lifted/Internal.hs
+++ b/src/Data/Set/Lifted/Internal.hs
@@ -17,11 +17,15 @@
 
 import Data.Primitive.UnliftedArray (PrimUnlifted(..))
 import Data.Functor.Classes (Eq1(liftEq),Show1(liftShowsPrec))
+import Data.Hashable (Hashable)
+import Data.Hashable.Lifted (Hashable1)
 import Data.Primitive (Array)
 import Data.Semigroup (Semigroup)
 import Text.Show (showListWith)
 
 import qualified Data.Foldable as F
+import qualified Data.Hashable as H
+import qualified Data.Hashable.Lifted as HL
 import qualified Data.Semigroup as SG
 import qualified Data.Set.Internal as I
 import qualified GHC.Exts as E
@@ -68,6 +72,12 @@
 instance Show1 Set where
   liftShowsPrec f _ p s = showParen (p > 10) $
    showString "fromList " . showListWith (f 0) (toList s)
+
+instance Hashable1 Set where
+  liftHashWithSalt f s (Set arr) = I.liftHashWithSalt f s arr
+
+instance Hashable a => Hashable (Set a) where
+  hashWithSalt = HL.hashWithSalt1
 
 -- | Convert a set to a list. The elements are given in ascending order.
 toList :: Set a -> [a]
diff --git a/src/Data/Set/Unboxed.hs b/src/Data/Set/Unboxed.hs
--- a/src/Data/Set/Unboxed.hs
+++ b/src/Data/Set/Unboxed.hs
@@ -6,71 +6,46 @@
 
 {-# OPTIONS_GHC -Wall #-}
 module Data.Set.Unboxed
-  ( Set
+  ( S.Set
+  , empty
   , singleton
+  , null
   , member
   , size
   , difference
   , (\\)
+  , intersection
     -- * List Conversion
-  , toList
-  , fromList
+  , S.toList
+  , S.fromList
     -- * Folds
   , foldr
+  , foldMap
   , foldl'
   , foldr'
   , foldMap'
+    -- * Traversals
+  , traverse_
+  , itraverse_
   ) where
 
-import Prelude hiding (foldr)
+import Prelude hiding (foldr,foldMap,null)
+import Data.Hashable (Hashable)
+import Data.Primitive.PrimArray (PrimArray)
 import Data.Primitive.Types (Prim)
 import Data.Primitive.UnliftedArray (PrimUnlifted(..))
-import Data.Primitive.PrimArray (PrimArray)
 import Data.Semigroup (Semigroup)
+import Data.Set.Unboxed.Internal (Set(..))
 import qualified Data.Foldable as F
+import qualified Data.Hashable as H
 import qualified Data.Semigroup as SG
 import qualified GHC.Exts as E
 import qualified Data.Set.Internal as I
-
--- | A set of elements.
-newtype Set a = Set (I.Set PrimArray a)
-
-instance PrimUnlifted (Set a) where
-  toArrayArray# (Set x) = toArrayArray# x
-  fromArrayArray# y = Set (fromArrayArray# y)
-
-instance (Prim a, Ord a) => Semigroup (Set a) where
-  Set x <> Set y = Set (I.append x y)
-  stimes = SG.stimesIdempotentMonoid
-  sconcat xs = Set (I.concat (E.coerce (F.toList xs)))
-
-instance (Prim a, Ord a) => Monoid (Set a) where
-  mempty = Set I.empty
-  mappend = (SG.<>)
-  mconcat xs = Set (I.concat (E.coerce xs))
-
-instance (Prim a, Eq a) => Eq (Set a) where
-  Set x == Set y = I.equals x y
-
-instance (Prim a, Ord a) => Ord (Set a) where
-  compare (Set x) (Set y) = I.compare x y
-
--- | The functions that convert a list to a 'Set' are asymptotically
--- better that using @'foldMap' 'singleton'@, with a cost of /O(n*log n)/
--- rather than /O(n^2)/. If the input list is sorted, even if duplicate
--- elements are present, the algorithm further improves to /O(n)/. The
--- fastest option available is calling 'fromListN' on a presorted list
--- and passing the correct size size of the resulting 'Set'. However, even
--- if an incorrect size is given to this function,
--- it will still correctly convert the list into a 'Set'.
-instance (Prim a, Ord a) => E.IsList (Set a) where
-  type Item (Set a) = a
-  fromListN n = Set . I.fromListN n
-  fromList = Set . I.fromList
-  toList = toList
+import qualified Data.Set.Unboxed.Internal as S
 
-instance (Prim a, Show a) => Show (Set a) where
-  showsPrec p (Set s) = I.showsPrec p s
+-- | The empty set.
+empty :: Set a
+empty = Set I.empty
 
 -- | The difference of two sets.
 difference :: (Ord a, Prim a) => Set a -> Set a -> Set a
@@ -79,22 +54,23 @@
 -- | Infix operator for 'difference'.
 (\\) :: (Ord a, Prim a) => Set a -> Set a -> Set a
 (\\) (Set x) (Set y) = Set (I.difference x y)
+
+-- | The intersection of two sets.
+intersection :: (Ord a, Prim a) => Set a -> Set a -> Set a
+intersection (Set x) (Set y) = Set (I.intersection x y)
+
 -- | Test whether or not an element is present in a set.
 member :: (Prim a, Ord a) => a -> Set a -> Bool
 member a (Set s) = I.member a s
 
+-- | /O(1)/ Is the set empty?
+null :: Set a -> Bool
+null (Set s) = I.null s
+
 -- | Construct a set with a single element.
 singleton :: Prim a => a -> Set a
 singleton = Set . I.singleton
 
--- | Convert a set to a list. The elements are given in ascending order.
-toList :: Prim a => Set a -> [a]
-toList (Set s) = I.toList s
-
--- | Convert a list to a set.
-fromList :: (Ord a, Prim a) => [a] -> Set a
-fromList xs = Set (I.fromList xs)
-
 -- | The number of elements in the set.
 size :: Prim a => Set a -> Int
 size (Set s) = I.size s
@@ -130,5 +106,25 @@
   -> m
 foldMap' f (Set arr) = I.foldMap' f arr
 
+-- | Lazy monoidal fold over the elements in the set.
+foldMap :: (Monoid m, Prim a)
+  => (a -> m)
+  -> Set a
+  -> m
+foldMap f (Set arr) = I.foldMap f arr
 
+-- | Traverse a set, discarding the result.
+traverse_ :: (Applicative m, Prim a)
+  => (a -> m b)
+  -> Set a
+  -> m ()
+traverse_ f (Set arr) = I.traverse_ f arr
+
+-- | Traverse a set with the indices, discarding the result.
+itraverse_ :: (Applicative m, Prim a)
+  => (Int -> a -> m b)
+  -> Set a
+  -> m ()
+itraverse_ f (Set arr) = I.itraverse_ f arr
+{-# INLINEABLE itraverse_ #-}
 
diff --git a/src/Data/Set/Unboxed/Internal.hs b/src/Data/Set/Unboxed/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Set/Unboxed/Internal.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Data.Set.Unboxed.Internal
+  ( Set(..)
+  , toList
+  , fromList
+  ) where
+
+import Prelude hiding (foldr)
+
+import Data.Hashable (Hashable)
+import Data.Primitive (Prim,PrimArray,Array,PrimUnlifted(..))
+import Data.Semigroup (Semigroup)
+import Text.Show (showListWith)
+
+import qualified Data.Foldable as F
+import qualified Data.Hashable as H
+import qualified Data.Semigroup as SG
+import qualified Data.Set.Internal as I
+import qualified GHC.Exts as E
+
+-- | A set of elements.
+newtype Set a = Set (I.Set PrimArray a)
+
+instance PrimUnlifted (Set a) where
+  toArrayArray# (Set x) = toArrayArray# x
+  fromArrayArray# y = Set (fromArrayArray# y)
+
+instance (Prim a, Ord a) => Semigroup (Set a) where
+  Set x <> Set y = Set (I.append x y)
+  stimes = SG.stimesIdempotentMonoid
+  sconcat xs = Set (I.concat (E.coerce (F.toList xs)))
+
+instance (Prim a, Ord a) => Monoid (Set a) where
+  mempty = Set I.empty
+  mappend = (SG.<>)
+  mconcat xs = Set (I.concat (E.coerce xs))
+
+instance (Prim a, Eq a) => Eq (Set a) where
+  Set x == Set y = I.equals x y
+
+instance (Prim a, Ord a) => Ord (Set a) where
+  compare (Set x) (Set y) = I.compare x y
+
+instance (Hashable a, Prim a) => Hashable (Set a) where
+  hashWithSalt s (Set arr) = I.liftHashWithSalt H.hashWithSalt s arr
+
+-- | The functions that convert a list to a 'Set' are asymptotically
+-- better that using @'foldMap' 'singleton'@, with a cost of /O(n*log n)/
+-- rather than /O(n^2)/. If the input list is sorted, even if duplicate
+-- elements are present, the algorithm further improves to /O(n)/. The
+-- fastest option available is calling 'fromListN' on a presorted list
+-- and passing the correct size size of the resulting 'Set'. However, even
+-- if an incorrect size is given to this function,
+-- it will still correctly convert the list into a 'Set'.
+instance (Prim a, Ord a) => E.IsList (Set a) where
+  type Item (Set a) = a
+  fromListN n = Set . I.fromListN n
+  fromList = Set . I.fromList
+  toList = toList
+
+instance (Prim a, Show a) => Show (Set a) where
+  showsPrec p (Set s) = I.showsPrec p s
+
+-- | Convert a set to a list. The elements are given in ascending order.
+toList :: Prim a => Set a -> [a]
+toList (Set s) = I.toList s
+
+-- | Convert a list to a set.
+fromList :: (Ord a, Prim a) => [a] -> Set a
+fromList xs = Set (I.fromList xs)
+
+
diff --git a/src/Data/Set/Unlifted.hs b/src/Data/Set/Unlifted.hs
--- a/src/Data/Set/Unlifted.hs
+++ b/src/Data/Set/Unlifted.hs
@@ -6,63 +6,49 @@
 
 {-# OPTIONS_GHC -O2 #-}
 module Data.Set.Unlifted
-  ( Set
+  ( S.Set
+  , empty
   , singleton
+  , null
   , member
   , size
+  , difference
+  , intersection
+    -- * Conversion
+  , toArray
+  , S.toList
+  , S.fromList
+    -- * Folds
+  , foldr
+  , foldMap
+  , foldl'
+  , foldr'
+  , foldMap'
+    -- * Traversals
+  , traverse_
+  , itraverse_
   ) where
 
+import Prelude hiding (foldr,foldMap,null)
+
 import Data.Primitive.UnliftedArray (UnliftedArray, PrimUnlifted(..))
 import Data.Semigroup (Semigroup)
-import qualified Data.Foldable as F
-import qualified Data.Semigroup as SG
-import qualified GHC.Exts as E
+import Data.Set.Unlifted.Internal (Set(..))
 import qualified Data.Set.Internal as I
-
--- | A set of elements.
-newtype Set a = Set (I.Set UnliftedArray a)
-
-instance PrimUnlifted (Set a) where
-  toArrayArray# (Set x) = toArrayArray# x
-  fromArrayArray# y = Set (fromArrayArray# y)
-
-instance (PrimUnlifted a, Ord a) => Semigroup (Set a) where
-  Set x <> Set y = Set (I.append x y)
-  stimes = SG.stimesIdempotentMonoid
-  sconcat xs = Set (I.concat (E.coerce (F.toList xs)))
-
-instance (PrimUnlifted a, Ord a) => Monoid (Set a) where
-  mempty = Set I.empty
-  mappend = (SG.<>)
-  mconcat xs = Set (I.concat (E.coerce xs))
-
-instance (PrimUnlifted a, Eq a) => Eq (Set a) where
-  Set x == Set y = I.equals x y
-
-instance (PrimUnlifted a, Ord a) => Ord (Set a) where
-  compare (Set x) (Set y) = I.compare x y
-
--- | The functions that convert a list to a 'Set' are asymptotically
--- better that using @'foldMap' 'singleton'@, with a cost of /O(n*log n)/
--- rather than /O(n^2)/. If the input list is sorted, even if duplicate
--- elements are present, the algorithm further improves to /O(n)/. The
--- fastest option available is calling 'fromListN' on a presorted list
--- and passing the correct size size of the resulting 'Set'. However, even
--- if an incorrect size is given to this function,
--- it will still correctly convert the list into a 'Set'.
-instance (PrimUnlifted a, Ord a) => E.IsList (Set a) where
-  type Item (Set a) = a
-  fromListN n = Set . I.fromListN n
-  fromList = Set . I.fromList
-  toList (Set s) = I.toList s
-
-instance (PrimUnlifted a, Show a) => Show (Set a) where
-  showsPrec p (Set s) = I.showsPrec p s
+import qualified Data.Set.Unlifted.Internal as S
 
 -- | Test for membership in the set.
 member :: (PrimUnlifted a, Ord a) => a -> Set a -> Bool
 member a (Set s) = I.member a s
 
+-- | The empty set.
+empty :: Set a
+empty = Set I.empty
+
+-- | True if the set is empty
+null :: Set a -> Bool
+null (Set s) = I.null s
+
 -- | Construct a set with a single element.
 singleton :: PrimUnlifted a => a -> Set a
 singleton = Set . I.singleton
@@ -71,4 +57,68 @@
 size :: PrimUnlifted a => Set a -> Int
 size (Set s) = I.size s
 
+-- | The difference of two sets.
+difference :: (PrimUnlifted a, Ord a) => Set a -> Set a -> Set a
+difference (Set x) (Set y) = Set (I.difference x y)
+
+-- | The intersection of two sets.
+intersection :: (Ord a, PrimUnlifted a) => Set a -> Set a -> Set a
+intersection (Set x) (Set y) = Set (I.intersection x y)
+
+-- | /O(1)/ Convert a set to an array. The elements are given in ascending
+-- order. This function is zero-cost.
+toArray :: Set a -> UnliftedArray a
+toArray (Set s) = I.toArray s
+
+-- | Right fold over the elements in the set. This is lazy in the accumulator.
+foldr :: PrimUnlifted a
+  => (a -> b -> b)
+  -> b
+  -> Set a
+  -> b
+foldr f b0 (Set s) = I.foldr f b0 s
+
+-- | Monoidal fold over the elements in the set. This is lazy in the accumulator.
+foldMap :: (PrimUnlifted a, Monoid m)
+  => (a -> m)
+  -> Set a
+  -> m
+foldMap f (Set s) = I.foldMap f s
+
+-- | Strict left fold over the elements in the set.
+foldl' :: PrimUnlifted a
+  => (b -> a -> b)
+  -> b
+  -> Set a
+  -> b
+foldl' f b0 (Set s) = I.foldl' f b0 s
+
+-- | Strict right fold over the elements in the set.
+foldr' :: PrimUnlifted a
+  => (a -> b -> b)
+  -> b
+  -> Set a
+  -> b
+foldr' f b0 (Set s) = I.foldr' f b0 s
+
+-- | Strict monoidal fold over the elements in the set.
+foldMap' :: (PrimUnlifted a, Monoid m)
+  => (a -> m)
+  -> Set a
+  -> m
+foldMap' f (Set arr) = I.foldMap' f arr
+
+-- | Traverse a set, discarding the result.
+traverse_ :: (Applicative m, PrimUnlifted a)
+  => (a -> m b)
+  -> Set a
+  -> m ()
+traverse_ f (Set arr) = I.traverse_ f arr
+
+-- | Traverse a set with the indices, discarding the result.
+itraverse_ :: (Applicative m, PrimUnlifted a)
+  => (Int -> a -> m b)
+  -> Set a
+  -> m ()
+itraverse_ f (Set arr) = I.itraverse_ f arr
 
diff --git a/src/Data/Set/Unlifted/Internal.hs b/src/Data/Set/Unlifted/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Set/Unlifted/Internal.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Data.Set.Unlifted.Internal
+  ( Set(..)
+  , toList
+  , fromList
+  ) where
+
+import Prelude hiding (foldr)
+
+import Data.Hashable (Hashable)
+import Data.Primitive.UnliftedArray (PrimUnlifted(..),UnliftedArray)
+import Data.Primitive (Array)
+import Data.Semigroup (Semigroup)
+import Text.Show (showListWith)
+
+import qualified Data.Foldable as F
+import qualified Data.Hashable as H
+import qualified Data.Semigroup as SG
+import qualified Data.Set.Internal as I
+import qualified GHC.Exts as E
+
+newtype Set a = Set { getSet :: I.Set UnliftedArray a }
+
+instance PrimUnlifted (Set a) where
+  toArrayArray# (Set x) = toArrayArray# x
+  fromArrayArray# y = Set (fromArrayArray# y)
+
+instance (Ord a, PrimUnlifted a) => Semigroup (Set a) where
+  Set x <> Set y = Set (I.append x y)
+  stimes = SG.stimesIdempotentMonoid
+  sconcat xs = Set (I.concat (E.coerce (F.toList xs)))
+
+instance (Hashable a, PrimUnlifted a) => Hashable (Set a) where
+  hashWithSalt s (Set arr) = I.liftHashWithSalt H.hashWithSalt s arr
+
+instance (PrimUnlifted a, Ord a) => Monoid (Set a) where
+  mempty = Set I.empty
+  mappend = (SG.<>)
+  mconcat xs = Set (I.concat (E.coerce xs))
+
+instance (PrimUnlifted a, Eq a) => Eq (Set a) where
+  Set x == Set y = I.equals x y
+
+instance (PrimUnlifted a, Ord a) => Ord (Set a) where
+  compare (Set x) (Set y) = I.compare x y
+
+-- | The functions that convert a list to a 'Set' are asymptotically
+-- better that using @'foldMap' 'singleton'@, with a cost of /O(n*log n)/
+-- rather than /O(n^2)/. If the input list is sorted, even if duplicate
+-- elements are present, the algorithm further improves to /O(n)/. The
+-- fastest option available is calling 'fromListN' on a presorted list
+-- and passing the correct size size of the resulting 'Set'. However, even
+-- if an incorrect size is given to this function,
+-- it will still correctly convert the list into a 'Set'.
+instance (PrimUnlifted a, Ord a) => E.IsList (Set a) where
+  type Item (Set a) = a
+  fromListN n = Set . I.fromListN n
+  fromList = Set . I.fromList
+  toList = toList
+
+instance (PrimUnlifted a, Show a) => Show (Set a) where
+  showsPrec p (Set s) = I.showsPrec p s
+
+-- | /O(n)/ Convert a set to a list. The elements are given in ascending order.
+toList :: PrimUnlifted a => Set a -> [a]
+toList (Set s) = I.toList s
+
+-- | /O(n*log n)/ Convert a list to a set.
+fromList :: (PrimUnlifted a, Ord a) => [a] -> Set a
+fromList = Set . I.fromList
+
diff --git a/test/Main.hs b/test/Main.hs
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -1,12 +1,19 @@
 {-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE UnboxedTuples #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE UnboxedTuples #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -15,11 +22,30 @@
 import Data.Word
 import Data.Proxy (Proxy(..))
 import Data.Int
+import Data.Functor.Const (Const(..))
+import Data.Kind (Type)
 
 import Test.Tasty (defaultMain,testGroup,TestTree)
+import Test.Tasty.HUnit (testCase,(@?=))
 import Test.QuickCheck (Arbitrary,Gen,(===),(==>))
+import Test.HUnit.Base (assertEqual)
+import Data.Bool (bool)
 import Data.List.NonEmpty (NonEmpty((:|)))
+import Data.Exists (ToSing(..),DependentPair(..),ShowForall(..),ShowForeach(..))
+import Data.Exists (WitnessedEquality(..),WitnessedOrdering(..),EqForall(..),OrdForall(..))
+import Data.Exists (EqForeach(..),OrdForeach(..),EqForallPoly(..),OrdForallPoly(..),Sing)
+import Data.Exists (PrimForall(..),ToJSONKeyForall(..),ToJSONKeyFunctionForall(..))
+import Data.Exists (ToJSONForeach(..),FromJSONKeyExists(..),Exists(..))
+import Data.Exists (FromJSONForeach(..))
 import Control.Monad (forM)
+import Data.Semigroup (Semigroup)
+import Unsafe.Coerce (unsafeCoerce)
+import Data.Dependent.Map.Class (Universally(..),ApplyUniversally(..))
+import Text.Read (readMaybe)
+import Data.Continuous.Set.Lifted (Inclusivity(..))
+import qualified Data.Aeson as AE
+import qualified Data.Aeson.Encoding as AEE
+import qualified Data.Text as T
 import qualified Test.Tasty.QuickCheck as TQC
 import qualified Test.QuickCheck as QC
 import qualified Test.QuickCheck.Classes as QCC
@@ -34,11 +60,14 @@
 import qualified Data.Set.Lifted as SL
 import qualified Data.Set.Unlifted as SUL
 import qualified Data.Map.Unboxed.Unboxed as MUU
-import qualified Data.Diet.Map.Unboxed.Lifted as DMUL
-import qualified Data.Diet.Map.Lifted.Lifted as DMLL
+import qualified Data.Diet.Map.Strict.Unboxed.Lifted as DMUL
+import qualified Data.Diet.Map.Strict.Lifted.Lifted as DMLL
 import qualified Data.Diet.Set.Lifted as DSL
+import qualified Data.Continuous.Set.Lifted as CSL
 import qualified Data.Diet.Unbounded.Set.Lifted as DUSL
-import qualified Data.Map.Subset.Lifted as MSL
+import qualified Data.Dependent.Map.Lifted.Lifted as DPMLL
+import qualified Data.Dependent.Map.Unboxed.Lifted as DPMUL
+import qualified Data.Map.Subset.Strict.Lifted as MSL
 
 main :: IO ()
 main = defaultMain $ testGroup "Data"
@@ -59,7 +88,12 @@
       , TQC.testProperty "foldr" (QCCL.foldrProp int32 SL.foldr)
       , TQC.testProperty "foldl'" (QCCL.foldlProp int16 SL.foldl')
       , TQC.testProperty "foldr'" (QCCL.foldrProp int32 SL.foldr')
+      , TQC.testProperty "foldMap" foldMapSetProp
+      , TQC.testProperty "foldMap'" foldMapStrictSetProp
       , TQC.testProperty "difference" differenceProp
+      , TQC.testProperty "intersection" intersectionProp
+      , TQC.testProperty "traverse_" traverseSetProp
+      , TQC.testProperty "itraverse_" itraverseSetProp
       ]
     , testGroup "Unlifted"
       [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SUL.Set (PrimArray Int16))))
@@ -81,9 +115,58 @@
         , TQC.testProperty "foldlWithKey'" (mapFoldAgreement MUU.foldlWithKey' M.foldlWithKey)
         , TQC.testProperty "foldrWithKey'" (mapFoldAgreement MUU.foldrWithKey' M.foldrWithKey)
         , TQC.testProperty "foldMapWithKey'" (mapFoldMonoidAgreement MUU.foldMapWithKey' M.foldMapWithKey)
+        , TQC.testProperty "mapMaybe" mapMaybeProp
         ]
       ]
     ]
+  , testGroup "Dependent"
+    [ testGroup "Map"
+      [ testGroup "Lifted"
+        [ testGroup "Lifted"
+          [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DPMLL.Map Key Value)))
+          , lawsToTest (QCC.ordLaws (Proxy :: Proxy (DPMLL.Map Key Value)))
+          , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DPMLL.Map Key Value)))
+          ]
+        ]
+      , testGroup "Unboxed"
+        [ testGroup "Lifted"
+          [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DPMUL.Map UnboxedKey Value)))
+          , lawsToTest (QCC.ordLaws (Proxy :: Proxy (DPMUL.Map UnboxedKey Value)))
+          , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DPMUL.Map UnboxedKey Value)))
+          , lawsToTest (QCC.jsonLaws (Proxy :: Proxy (DPMUL.Map UnboxedKey Value)))
+          ]
+        ]
+      ]
+    ]
+  , testGroup "Continuous"
+    [ testGroup "Set"
+      [ testGroup "Lifted"
+        [ testGroup "Unit" 
+          [ testCase "A" $ do
+              let s = CSL.singleton Nothing (Just (Inclusive,55 :: Integer))
+                      <>
+                      CSL.singleton (Just (Exclusive,200 :: Integer)) Nothing
+                  str = show s
+              assertEqual (str ++ " contains 50") (CSL.member 50 s) True
+              assertEqual (str ++ " contains 270") (CSL.member 270 s) True
+              assertEqual (str ++ " contains 55") (CSL.member 55 s) True
+              assertEqual (str ++ " does not contain 200") (CSL.member 200 s) False
+              assertEqual (str ++ " does not contain 56") (CSL.member 56 s) False
+          , testCase "B" $ do
+              let s = CSL.singleton Nothing (Just (Inclusive,14 :: Integer))
+                      <>
+                      CSL.singleton (Just (Exclusive,14 :: Integer)) Nothing
+              s @?= CSL.universe
+          , testCase "C" $ do
+              let s = CSL.singleton Nothing (Just (Exclusive,14 :: Integer))
+                      <>
+                      CSL.singleton (Just (Exclusive,14 :: Integer)) Nothing
+                  str = show s
+              assertEqual (str ++ " does not contain 14") (CSL.member 14 s) False
+          ]
+        ]
+      ]
+    ]
   , testGroup "Diet"
     [ testGroup "Unbounded"
       [ testGroup "Set"
@@ -101,6 +184,8 @@
         , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DSL.Set Word16)))
         , TQC.testProperty "member" (dietMemberProp @Word8 E.fromList DSL.member)
         , TQC.testProperty "difference" dietSetDifferenceProp
+        , TQC.testProperty "intersection" dietSetIntersectionProp
+        , TQC.testProperty "negate" dietSetNegateProp
         , TQC.testProperty "aboveInclusive" dietSetAboveProp
         , testGroup "belowInclusive"
           [ TQC.testProperty "basic" dietSetBelowProp
@@ -164,6 +249,18 @@
       ys' = dietSetToSet ys
    in DSL.difference xs ys === DSL.fromList (map (\x -> (x,x)) (S.toList (S.difference xs' ys')))
 
+dietSetIntersectionProp :: QC.Property
+dietSetIntersectionProp = QC.property $ \(xs :: DSL.Set Word8) (ys :: DSL.Set Word8) ->
+  let xs' = dietSetToSet xs
+      ys' = dietSetToSet ys
+   in DSL.intersection xs ys === DSL.fromList (map (\x -> (x,x)) (S.toList (S.intersection xs' ys')))
+
+dietSetNegateProp :: QC.Property
+dietSetNegateProp = QC.property $ \(xs :: DSL.Set Word8) ->
+  let xs' = dietSetToSet xs
+      expected = foldMap (\n -> bool (S.singleton n) mempty (S.member n xs')) [minBound..maxBound]
+   in DSL.negate xs === mconcat (map (\x -> DSL.singleton x x) (F.toList expected))
+
 dietSetAboveProp :: QC.Property
 dietSetAboveProp = QC.property $ \(y :: Word8) (ys :: DSL.Set Word8) ->
   let ys' = dietSetToSet ys
@@ -234,7 +331,7 @@
 -- in the diet set.
 dietSetToSet :: (Enum a, Ord a) => DSL.Set a -> S.Set a
 dietSetToSet = DSL.foldr
-  (\lo hi s -> S.fromList (enumFromTo lo hi) <> s)
+  (\lo hi s -> S.fromList (enumFromTo lo hi) SG.<> s)
   mempty
 
 differenceProp :: QC.Property
@@ -243,6 +340,39 @@
       ys' = SL.fromList (S.toList ys)
    in SL.toList (SL.difference xs' ys') === S.toList (S.difference xs ys)
 
+intersectionProp :: QC.Property
+intersectionProp = QC.property $ \(xs :: S.Set Word8) (ys :: S.Set Word8) ->
+  let xs' = SL.fromList (S.toList xs)
+      ys' = SL.fromList (S.toList ys)
+   in SL.toList (SL.intersection xs' ys') === S.toList (S.intersection xs ys)
+
+traverseSetProp :: QC.Property
+traverseSetProp = QC.property $ \(xs :: S.Set Word8) ->
+  let xs' = SL.fromList (S.toList xs)
+   in SL.traverse_ (Const . SG.Sum) xs' === F.traverse_ (Const . SG.Sum) xs
+
+foldMapSetProp :: QC.Property
+foldMapSetProp = QC.property $ \(xs :: S.Set Word8) ->
+  let xs' = SL.fromList (S.toList xs)
+   in SL.foldMap SG.Sum xs' === F.foldMap SG.Sum xs
+
+foldMapStrictSetProp :: QC.Property
+foldMapStrictSetProp = QC.property $ \(xs :: S.Set Word8) ->
+  let xs' = SL.fromList (S.toList xs)
+   in SL.foldMap' SG.Sum xs' === F.foldMap SG.Sum xs
+
+mapMaybeProp :: QC.Property
+mapMaybeProp = QC.property $ \(xs :: M.Map Word8 Word8) ->
+  let xs' = MUU.fromList (M.toList xs)
+      func x = if even x then Just (x * x) else Nothing
+   in MUU.toList (MUU.mapMaybe func xs') === M.toList (M.mapMaybe func xs)
+
+itraverseSetProp :: QC.Property
+itraverseSetProp = QC.property $ \(xs :: S.Set Int) ->
+  let xs' = SL.fromList (S.toList xs)
+      zs = zip (enumFrom (0 :: Int)) (S.toList xs)
+   in SL.itraverse_ (\ix x -> Const (SG.Sum (ix + x))) xs' === F.traverse_ (\(ix,x) -> Const (SG.Sum (ix + x))) zs
+
 mapFoldMonoidAgreement ::
      ((Int -> Int -> [Int]) -> MUU.Map Int Int -> [Int])
   -> ((Int -> Int -> [Int]) -> M.Map Int Int -> [Int])
@@ -290,7 +420,7 @@
 dietDoubletonProp = QC.property $ \(loA :: Word8) (hiA :: Word8) (valA :: Int) (loB :: Word8) (hiB :: Word8) (valB :: Int) ->
   (hiA >= loA && hiB >= loB)
   ==>
-  (simpleDoubletonToList loA hiA valA loB hiB valB === E.toList (DMLL.singleton loA hiA valA <> DMLL.singleton loB hiB valB))
+  (simpleDoubletonToList loA hiA valA loB hiB valB === E.toList (DMLL.singleton loA hiA valA SG.<> DMLL.singleton loB hiB valB))
 
 dietValidProp :: QC.Property
 dietValidProp = QC.property $ \(xs :: DMLL.Map Word8 Int) ->
@@ -465,4 +595,245 @@
   mappend = (SG.<>)
 
 deriving instance Arbitrary a => Arbitrary (SG.First a)
+
+data Universe
+  = UniverseInt
+  | UniverseOrdering
+  | UniverseBool
+  | UniverseChar
+
+data SingUniverse :: Universe -> Type where
+  SingUniverseInt :: SingUniverse 'UniverseInt
+  SingUniverseOrdering :: SingUniverse 'UniverseOrdering
+  SingUniverseBool :: SingUniverse 'UniverseBool
+  SingUniverseChar :: SingUniverse 'UniverseChar
+
+deriving instance Show (SingUniverse u)
+
+type instance Sing = SingUniverse
+
+type family Interpret (u :: Universe) :: Type where
+  Interpret 'UniverseInt = Int
+  Interpret 'UniverseOrdering = Ordering
+  Interpret 'UniverseBool = Bool
+  Interpret 'UniverseChar = Char
+
+newtype Value :: Universe -> Type where
+  Value :: Interpret u -> Value u
+
+instance EqForeach Value where
+  eqForeach SingUniverseInt (Value x) (Value y) = x == y
+  eqForeach SingUniverseOrdering (Value x) (Value y) = x == y
+  eqForeach SingUniverseBool (Value x) (Value y) = x == y
+  eqForeach SingUniverseChar (Value x) (Value y) = x == y
+
+instance OrdForeach Value where
+  compareForeach SingUniverseInt (Value x) (Value y) = compare x y
+  compareForeach SingUniverseOrdering (Value x) (Value y) = compare x y
+  compareForeach SingUniverseBool (Value x) (Value y) = compare x y
+  compareForeach SingUniverseChar (Value x) (Value y) = compare x y
+
+instance ShowForeach Value where
+  showsPrecForeach SingUniverseInt p (Value x) = showsPrec p x
+  showsPrecForeach SingUniverseBool p (Value x) = showsPrec p x
+  showsPrecForeach SingUniverseOrdering p (Value x) = showsPrec p x
+  showsPrecForeach SingUniverseChar p (Value x) = showsPrec p x
+
+-- This type interpret the lowest two bits of the Word8
+-- as the Universe value. Doing this is unsafe, but if the
+-- data constructor of a type like this is not exported, it
+-- is possible to build safe interfaces on top of this.
+newtype UnboxedKey u = UnboxedKey Word8
+  deriving (Show,Prim,Eq,Ord)
+
+unboxedIntKey :: Word8 -> UnboxedKey 'UniverseInt
+unboxedIntKey w = UnboxedKey (w * 4 + 0)
+
+unboxedBoolKey :: Word8 -> UnboxedKey 'UniverseBool
+unboxedBoolKey w = UnboxedKey (w * 4 + 1)
+
+unboxedOrderingKey :: Word8 -> UnboxedKey 'UniverseOrdering
+unboxedOrderingKey w = UnboxedKey (w * 4 + 2)
+
+unboxedCharKey :: Word8 -> UnboxedKey 'UniverseChar
+unboxedCharKey w = UnboxedKey (w * 4 + 3)
+
+instance ToJSONKeyForall UnboxedKey where
+  toJSONKeyForall = ToJSONKeyTextForall
+    (\(UnboxedKey n) -> T.pack (show n))
+    (\(UnboxedKey n) -> AEE.text (T.pack (show n)))
+
+instance FromJSONKeyExists UnboxedKey where
+  fromJSONKeyExists = AE.FromJSONKeyTextParser
+    (\t -> case readMaybe (T.unpack t) of
+      Nothing -> fail "Value, FromJSONKeyExists: bad value"
+      Just w -> return (Exists (UnboxedKey w))
+    )
+
+instance FromJSONForeach Value where
+  parseJSONForeach SingUniverseInt = fmap Value . AE.parseJSON 
+  parseJSONForeach SingUniverseBool = fmap Value . AE.parseJSON
+  parseJSONForeach SingUniverseOrdering = fmap Value . AE.parseJSON
+  parseJSONForeach SingUniverseChar = fmap Value . AE.parseJSON
+
+instance ToJSONForeach Value where
+  toJSONForeach SingUniverseInt (Value a) = AE.toJSON a
+  toJSONForeach SingUniverseBool (Value a) = AE.toJSON a
+  toJSONForeach SingUniverseOrdering (Value a) = AE.toJSON a
+  toJSONForeach SingUniverseChar (Value a) = AE.toJSON a
+
+instance ToSing UnboxedKey where
+  toSing (UnboxedKey w) = case mod w 4 of
+    0 -> unsafeCoerce SingUniverseInt
+    1 -> unsafeCoerce SingUniverseBool
+    2 -> unsafeCoerce SingUniverseOrdering
+    _ -> unsafeCoerce SingUniverseChar
+
+instance ShowForall UnboxedKey where
+  showsPrecForall = showsPrec
+
+instance EqForall UnboxedKey where
+  eqForall = (==)
+
+instance EqForallPoly UnboxedKey where
+  eqForallPoly (UnboxedKey a) (UnboxedKey b) = if a == b
+    then unsafeCoerce WitnessedEqualityEqual
+    else WitnessedEqualityUnequal
+
+instance OrdForall UnboxedKey where
+  compareForall = compare
+
+instance OrdForallPoly UnboxedKey where
+  compareForallPoly (UnboxedKey a) (UnboxedKey b) = case compare a b of
+    LT -> WitnessedOrderingLT
+    GT -> WitnessedOrderingGT
+    EQ -> unsafeCoerce WitnessedOrderingEQ
+
+data Key u = Key !Int !(SingUniverse u)
+  deriving (Show)
+
+instance ShowForall Key where
+  showsPrecForall = showsPrec
+
+instance ToSing Key where
+  toSing (Key _ s) = s
+
+instance EqForall Key where
+  eqForall (Key i1 _) (Key i2 _) = i1 == i2
+
+instance OrdForall Key where
+  compareForall (Key i1 _) (Key i2 _) = compare i1 i2
+
+instance EqForallPoly Key where
+  eqForallPoly (Key i1 s1) (Key i2 s2) = if i1 == i2
+    then case s1 of
+      SingUniverseInt -> case s2 of
+        SingUniverseInt -> WitnessedEqualityEqual
+        _ -> WitnessedEqualityUnequal
+      SingUniverseOrdering -> case s2 of
+        SingUniverseOrdering -> WitnessedEqualityEqual
+        _ -> WitnessedEqualityUnequal
+      SingUniverseBool -> case s2 of
+        SingUniverseBool -> WitnessedEqualityEqual
+        _ -> WitnessedEqualityUnequal
+      SingUniverseChar -> case s2 of
+        SingUniverseChar -> WitnessedEqualityEqual
+        _ -> WitnessedEqualityUnequal
+    else WitnessedEqualityUnequal
+
+instance EqForall SingUniverse where
+  eqForall _ _ = True
+
+instance OrdForall SingUniverse where
+  compareForall _ _ = EQ
+
+instance EqForallPoly SingUniverse where
+  eqForallPoly SingUniverseInt SingUniverseInt = WitnessedEqualityEqual
+  eqForallPoly SingUniverseInt _ = WitnessedEqualityUnequal
+  eqForallPoly SingUniverseBool SingUniverseBool = WitnessedEqualityEqual
+  eqForallPoly SingUniverseBool _ = WitnessedEqualityUnequal
+  eqForallPoly SingUniverseOrdering SingUniverseOrdering = WitnessedEqualityEqual
+  eqForallPoly SingUniverseOrdering _ = WitnessedEqualityUnequal
+  eqForallPoly SingUniverseChar SingUniverseChar = WitnessedEqualityEqual
+  eqForallPoly SingUniverseChar _ = WitnessedEqualityUnequal
+
+instance OrdForallPoly SingUniverse where
+  compareForallPoly SingUniverseInt SingUniverseInt      = WitnessedOrderingEQ
+  compareForallPoly SingUniverseInt SingUniverseOrdering = WitnessedOrderingLT
+  compareForallPoly SingUniverseInt SingUniverseBool     = WitnessedOrderingLT
+  compareForallPoly SingUniverseInt SingUniverseChar     = WitnessedOrderingLT
+  compareForallPoly SingUniverseOrdering SingUniverseInt      = WitnessedOrderingGT
+  compareForallPoly SingUniverseOrdering SingUniverseOrdering = WitnessedOrderingEQ
+  compareForallPoly SingUniverseOrdering SingUniverseBool     = WitnessedOrderingLT
+  compareForallPoly SingUniverseOrdering SingUniverseChar     = WitnessedOrderingLT
+  compareForallPoly SingUniverseBool SingUniverseInt      = WitnessedOrderingGT
+  compareForallPoly SingUniverseBool SingUniverseOrdering = WitnessedOrderingGT
+  compareForallPoly SingUniverseBool SingUniverseBool     = WitnessedOrderingEQ
+  compareForallPoly SingUniverseBool SingUniverseChar     = WitnessedOrderingLT
+  compareForallPoly SingUniverseChar SingUniverseInt      = WitnessedOrderingGT
+  compareForallPoly SingUniverseChar SingUniverseOrdering = WitnessedOrderingGT
+  compareForallPoly SingUniverseChar SingUniverseBool     = WitnessedOrderingGT
+  compareForallPoly SingUniverseChar SingUniverseChar     = WitnessedOrderingEQ
+
+instance OrdForallPoly Key where
+  compareForallPoly (Key i1 s1) (Key i2 s2) = case compare i1 i2 of
+    LT -> WitnessedOrderingLT
+    GT -> WitnessedOrderingGT
+    EQ -> compareForallPoly s1 s2
+
+class ArbitraryDependentPair k v where
+  arbitraryDependentPair :: Gen (DependentPair k v)
+
+instance ArbitraryDependentPair k v => Arbitrary (DependentPair k v) where
+  arbitrary = arbitraryDependentPair
+
+instance ArbitraryDependentPair Key Value where
+  arbitraryDependentPair = do
+    (i :: Int) <- QC.choose (0, 10)
+    QC.oneof
+      [ DependentPair (Key i SingUniverseInt) . Value <$> QC.arbitrary
+      , DependentPair (Key i SingUniverseBool) . Value <$> QC.arbitrary
+      , DependentPair (Key i SingUniverseChar) . Value <$> QC.arbitrary
+      , DependentPair (Key i SingUniverseOrdering) . Value <$> QC.arbitrary
+      ]
+
+instance ArbitraryDependentPair UnboxedKey Value where
+  arbitraryDependentPair = do
+    (i :: Word8) <- QC.choose (0, 10)
+    QC.oneof
+      [ DependentPair (unboxedIntKey i) . Value <$> QC.arbitrary
+      , DependentPair (unboxedBoolKey i) . Value <$> QC.arbitrary
+      , DependentPair (unboxedCharKey i) . Value <$> QC.arbitrary
+      , DependentPair (unboxedOrderingKey i) . Value <$> QC.arbitrary
+      ]
+    
+instance (ArbitraryDependentPair k v, OrdForallPoly k) => Arbitrary (DPMLL.Map k v) where
+  arbitrary = do
+    len <- QC.choose (0,35)
+    DPMLL.fromList <$> QC.vectorOf len arbitraryDependentPair
+
+instance (ArbitraryDependentPair k v, OrdForallPoly k, Universally k Prim, ApplyUniversally k Prim) => Arbitrary (DPMUL.Map k v) where
+  arbitrary = do
+    len <- QC.choose (0,35)
+    DPMUL.fromList <$> QC.vectorOf len arbitraryDependentPair
+
+instance Universally UnboxedKey Prim where
+  universally _ _ _ x = x
+
+instance ApplyUniversally UnboxedKey Prim where
+  applyUniversallyLifted _ _ _ x = x
+  applyUniversallyUnlifted _ _ _ x = x
+
+-- very unsafe instance
+instance PrimForall UnboxedKey where
+  sizeOfForall# _ = sizeOf# (undefined :: UnboxedKey a)
+  alignmentForall# _ = alignment# (undefined :: UnboxedKey a)
+  indexByteArrayForall# = indexByteArray#
+  readByteArrayForall# = readByteArray#
+  writeByteArrayForall# = writeByteArray#
+  setByteArrayForall# = setByteArray#
+  readOffAddrForall# = readOffAddr#
+  writeOffAddrForall# = writeOffAddr#
+  indexOffAddrForall# = indexOffAddr#
+  setOffAddrForall# = setOffAddr#