diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,3 @@
+# Changelog for primitive-containers
+
+## Unreleased changes
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Andrew Martin (c) 2018
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Andrew Martin nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,1 @@
+# primitive-containers
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/benchmark-gauge/Main.hs b/benchmark-gauge/Main.hs
new file mode 100644
--- /dev/null
+++ b/benchmark-gauge/Main.hs
@@ -0,0 +1,135 @@
+{-# LANGUAGE BangPatterns #-}
+
+{-# OPTIONS_GHC -O2 #-}
+
+import Gauge.Main
+import System.Random (randoms,mkStdGen)
+import Data.Foldable (foldMap)
+import Data.Maybe (fromMaybe)
+import Data.Bool (bool)
+import qualified GHC.Exts as E
+import qualified Data.Set.Unboxed as DSU
+import qualified Data.Set.Lifted as DSL
+import qualified Data.Map.Unboxed.Unboxed as DMUU
+import qualified Data.Map.Lifted.Lifted as DMLL
+import qualified Data.Map.Strict as M
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Set as S
+
+main :: IO ()
+main = defaultMain
+  [ bgroup "Map"
+    [ bgroup "lookup" 
+      [ bench "primitive-unboxed-unboxed" $ whnf lookupAllUnboxed bigUnboxedMap
+      , bench "containers-map" $ whnf lookupAllContainers bigContainersMap
+      , bench "containers-intmap" $ whnf lookupAllIntContainers bigContainersIntMap
+      ]
+    , bgroup "fold"
+      [ bench "primitive-unboxed-unboxed" $ whnf (DMUU.foldlWithKey' reduction 0) bigUnboxedMap
+      , bench "primitive-lifted-lifted" $ whnf (DMLL.foldlWithKey' reduction 0) bigLiftedMap
+      , bench "containers-map" $ whnf (M.foldlWithKey' reduction 0) bigContainersMap
+      ]
+    ]
+  , bgroup "Set"
+    [ bgroup "lookup" 
+      [ bench "primitive-unboxed" $ whnf lookupAllSetUnboxed bigUnboxedSet
+      , bench "primitive-lifted" $ whnf lookupAllSetLifted bigLiftedSet
+      ]
+    , bgroup "fold"
+      [ bench "primitive-unboxed" $ whnf (DSU.foldl' (+) 0) bigUnboxedSet
+      , bench "containers-set" $ whnf (S.foldl' (+) 0) bigContainersSet
+      ]
+    , bgroup "concat"
+      [ bgroup "fold"
+        [ bench "20" $ whnf (foldMap DSU.singleton) randomArray20
+        , bench "200" $ whnf (foldMap DSU.singleton) randomArray200
+        , bench "2000" $ whnf (foldMap DSU.singleton) randomArray2000
+        ]
+      , bgroup "fromList"
+        [ bench "20" $ whnf (E.fromList :: [Word] -> DSU.Set Word) randomArray20
+        , bench "200" $ whnf (E.fromList :: [Word] -> DSU.Set Word) randomArray200
+        , bench "2000" $ whnf (E.fromList :: [Word] -> DSU.Set Word) randomArray2000
+        ]
+      , bgroup "fromAscList"
+        [ bench "20" $ whnf (E.fromList :: [Word] -> DSU.Set Word) ascArray20
+        , bench "200" $ whnf (E.fromList :: [Word] -> DSU.Set Word) ascArray200
+        , bench "2000" $ whnf (E.fromList :: [Word] -> DSU.Set Word) ascArray2000
+        ]
+      ]
+    ]
+  ]
+
+reduction :: Int -> Int -> Int -> Int
+reduction x y z = x + y + z
+
+bigNumber :: Int
+bigNumber = 100000
+
+bigContainersSet :: S.Set Int
+bigContainersSet = E.fromList (map (\x -> x `mod` (bigNumber * 2)) (take bigNumber (randoms (mkStdGen 75843))))
+
+bigUnboxedSet :: DSU.Set Int
+bigUnboxedSet = E.fromList (map (\x -> x `mod` (bigNumber * 2)) (take bigNumber (randoms (mkStdGen 75843))))
+
+bigLiftedSet :: DSL.Set Int
+bigLiftedSet = E.fromList (map (\x -> x `mod` (bigNumber * 2)) (take bigNumber (randoms (mkStdGen 75843))))
+
+bigUnboxedMap :: DMUU.Map Int Int
+bigUnboxedMap = E.fromList (map (\x -> (x `mod` (bigNumber * 2),x)) (take bigNumber (randoms (mkStdGen 75843))))
+
+bigLiftedMap :: DMLL.Map Int Int
+bigLiftedMap = E.fromList (map (\x -> (x `mod` (bigNumber * 2),x)) (take bigNumber (randoms (mkStdGen 75843))))
+
+bigContainersMap :: M.Map Int Int
+bigContainersMap = M.fromList (map (\x -> (x `mod` (bigNumber * 2),x)) (take bigNumber (randoms (mkStdGen 75843))))
+
+bigContainersIntMap :: IM.IntMap Int
+bigContainersIntMap = IM.fromList (map (\x -> (x `mod` (bigNumber * 2),x)) (take bigNumber (randoms (mkStdGen 75843))))
+
+lookupAllUnboxed :: DMUU.Map Int Int -> Int
+lookupAllUnboxed m = go 0 0 where
+  go !acc !n = if n < bigNumber
+    then go (acc + fromMaybe 0 (DMUU.lookup n m)) (n + 1)
+    else acc
+
+lookupAllSetUnboxed :: DSU.Set Int -> Int
+lookupAllSetUnboxed m = go 0 0 where
+  go !acc !n = if n < bigNumber
+    then go (acc + bool 2 3 (DSU.member n m)) (n + 1)
+    else acc
+
+lookupAllSetLifted :: DSL.Set Int -> Int
+lookupAllSetLifted m = go 0 0 where
+  go !acc !n = if n < bigNumber
+    then go (acc + bool 2 3 (DSL.member n m)) (n + 1)
+    else acc
+
+lookupAllContainers :: M.Map Int Int -> Int
+lookupAllContainers m = go 0 0 where
+  go !acc !n = if n < bigNumber
+    then go (acc + fromMaybe 0 (M.lookup n m)) (n + 1)
+    else acc
+
+lookupAllIntContainers :: IM.IntMap Int -> Int
+lookupAllIntContainers m = go 0 0 where
+  go !acc !n = if n < bigNumber
+    then go (acc + fromMaybe 0 (IM.lookup n m)) (n + 1)
+    else acc
+
+ascArray20 :: [Word]
+ascArray20 = take 20 (enumFrom 0)
+
+ascArray200 :: [Word]
+ascArray200 = take 200 (enumFrom 0)
+
+ascArray2000 :: [Word]
+ascArray2000 = take 2000 (enumFrom 0)
+
+randomArray20 :: [Word]
+randomArray20 = take 20 (randoms (mkStdGen 75843))
+
+randomArray200 :: [Word]
+randomArray200 = take 200 (randoms (mkStdGen 75843))
+
+randomArray2000 :: [Word]
+randomArray2000 = take 2000 (randoms (mkStdGen 75843))
diff --git a/primitive-containers.cabal b/primitive-containers.cabal
new file mode 100644
--- /dev/null
+++ b/primitive-containers.cabal
@@ -0,0 +1,88 @@
+name: primitive-containers
+version: 0.2.0
+description: Please see the README on Github at <https://github.com/andrewthad/primitive-containers>
+homepage: https://github.com/andrewthad/primitive-containers
+bug-reports: https://github.com/andrewthad/primitive-containers/issues
+author: Andrew Martin
+maintainer: andrew.thaddeus@gmail.com
+copyright: 2018 Andrew Martin
+license: BSD3
+license-file: LICENSE
+build-type: Simple
+cabal-version: >= 2.0
+
+extra-source-files:
+    ChangeLog.md
+    README.md
+
+source-repository head
+  type: git
+  location: https://github.com/andrewthad/primitive-containers
+
+library
+  hs-source-dirs:
+      src
+  build-depends:
+      base >=4.9 && <5
+    , primitive >= 0.6.4
+    , primitive-sort >= 0.1 && < 0.2
+    , contiguous >= 0.2 && < 0.3
+  exposed-modules:
+    Data.Diet.Map.Lifted.Lifted
+    Data.Diet.Map.Unboxed.Lifted
+    Data.Diet.Set
+    Data.Diet.Set.Lifted
+    Data.Diet.Set.Unboxed
+    Data.Diet.Unbounded.Set.Lifted
+    Data.Map.Lifted.Lifted
+    Data.Map.Unboxed.Lifted
+    Data.Map.Unboxed.Unboxed
+    Data.Map.Unboxed.Unlifted
+    Data.Set.Lifted
+    Data.Set.Unboxed
+    Data.Set.Unlifted
+    Data.Map.Subset.Lifted
+  other-modules:
+    Data.Concatenation
+    Data.Diet.Map.Internal
+    Data.Diet.Set.Internal
+    Data.Diet.Unbounded.Set.Internal
+    Data.Map.Internal
+    Data.Map.Subset.Internal
+    Data.Set.Internal
+    Data.Set.Lifted.Internal
+  ghc-options: -O2 -Wall
+  default-language: Haskell2010
+
+test-suite test
+  type: exitcode-stdio-1.0
+  hs-source-dirs: test
+  main-is: Main.hs
+  build-depends:
+      base
+    , QuickCheck
+    , containers
+    , primitive
+    , primitive-containers
+    , quickcheck-classes >= 0.4.12
+    , tasty
+    , tasty-quickcheck
+  ghc-options: -Wall -O2
+  default-language: Haskell2010
+
+benchmark gauge
+  default-language: Haskell2010
+  hs-source-dirs:
+    benchmark-gauge
+  main-is: Main.hs
+  type: exitcode-stdio-1.0
+  ghc-options: -Wall -O2
+  build-depends:
+      base >= 4.8 && < 4.12
+    , primitive
+    , primitive-containers
+    , ghc-prim
+    , gauge
+    , random
+    , containers
+
diff --git a/src/Data/Concatenation.hs b/src/Data/Concatenation.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Concatenation.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Data.Concatenation
+  ( concatSized
+  ) where
+
+import qualified Data.List as L
+
+concatSized :: forall m.
+     (m -> Int) -- size function 
+  -> m
+  -> (m -> m -> m)
+  -> [m]
+  -> m
+concatSized size empty combine = go [] where
+  go :: [m] -> [m] -> m
+  go !stack [] = L.foldl' combine empty (L.reverse stack)
+  go !stack (x : xs) = if size x > 0
+    then go (pushStack x stack) xs
+    else go stack xs
+  pushStack :: m -> [m] -> [m]
+  pushStack x [] = [x]
+  pushStack x (s : ss) = if size x >= size s
+    then pushStack (combine s x) ss
+    else x : s : ss
+
diff --git a/src/Data/Diet/Map/Internal.hs b/src/Data/Diet/Map/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Diet/Map/Internal.hs
@@ -0,0 +1,395 @@
+{-# 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
new file mode 100644
--- /dev/null
+++ b/src/Data/Diet/Map/Lifted/Lifted.hs
@@ -0,0 +1,77 @@
+{-# 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/Unboxed/Lifted.hs b/src/Data/Diet/Map/Unboxed/Lifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Diet/Map/Unboxed/Lifted.hs
@@ -0,0 +1,79 @@
+{-# 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.hs b/src/Data/Diet/Set.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Diet/Set.hs
@@ -0,0 +1,27 @@
+{-|
+
+The modules in this hierarchy implement sets of nonoverlapping,
+nonadjacent intervals. In the literature, one such implementation of
+these is known as
+<http://web.engr.oregonstate.edu/~erwig/diet/ Discrete Interval Encoding Trees>
+(DIETs). This implementation is discussed in
+<http://web.engr.oregonstate.edu/~erwig/papers/Diet_JFP98.pdf Diets for Fat Sets>,
+Martin Erwig. Journal of Functional Programming, Vol. 8, No. 6, 627-632, 1998.
+In this package, we use the term diet set to refer to not just that one
+implementation but to any set of nonoverlapping, nonadjacent intervals.
+
+These are not the same as interval sets. An interval set preserves
+the original intervals that the user inserted into the set. A diet set
+will coalesce adjacent or overlapping ranges. For example:
+
+>>> ⦃[2,6]⦄ ⋄ ⦃[1,3]⦄ ⋄ ⦃[8,11]⦄ ⋄ ⦃[12,12]⦄ 
+⦃[1,6],[8,12]⦄
+
+The implementation in this packages is optimized for reads. Building
+a diet set is expensive since the array-backed implementation cannot
+do any sharing when it creates a new data structure. However, testing
+for membership is @O(log n)@. 
+
+-}
+
+module Data.Diet.Set () where
diff --git a/src/Data/Diet/Set/Internal.hs b/src/Data/Diet/Set/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Diet/Set/Internal.hs
@@ -0,0 +1,550 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{-# OPTIONS_GHC -O2 -Wall #-}
+module Data.Diet.Set.Internal
+  ( Set
+  , empty
+  , singleton
+  , append
+  , member
+  , concat
+  , equals
+  , showsPrec
+  , difference
+  , foldr
+  , size
+    -- unsafe indexing
+  , locate
+  , slice
+  , indexLower
+  , indexUpper
+    -- splitting
+  , aboveExclusive
+  , aboveInclusive
+  , belowInclusive
+  , belowExclusive
+  , betweenInclusive
+    -- list conversion
+  , fromListN
+  , fromList
+  , toList
+  ) where
+
+import Prelude hiding (lookup,showsPrec,concat,map,foldr)
+
+import Control.Monad.ST (ST,runST)
+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
+
+newtype Set arr a = Set (arr a)
+
+empty :: Contiguous arr => Set arr a
+empty = Set I.empty
+
+equals :: (Contiguous arr, Element arr a, Eq a) => Set arr a -> Set arr a -> Bool
+equals (Set x) (Set y) = I.equals x y
+
+fromListN :: (Contiguous arr, Element arr a, Ord a, Enum a) => Int -> [(a,a)] -> Set arr a
+fromListN _ xs = concat (P.map (uncurry singleton) xs)
+
+fromList :: (Contiguous arr, Element arr a, Ord a, Enum a) => [(a,a)] -> Set arr a
+fromList = fromListN 1
+
+concat :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)
+  => [Set arr a]
+  -> Set arr a
+concat = C.concatSized size empty append
+
+singleton :: forall arr a. (Contiguous arr, Element arr a, Ord a)
+  => a -- ^ lower inclusive bound
+  -> a -- ^ upper inclusive bound
+  -> Set arr a
+singleton !lo !hi = if lo <= hi
+  then uncheckedSingleton lo hi
+  else empty
+
+-- precondition: lo must be less than or equal to hi
+uncheckedSingleton :: forall arr a. (Contiguous arr, Element arr a, Ord a)
+  => a -- ^ lower inclusive bound
+  -> a -- ^ upper inclusive bound
+  -> Set arr a
+uncheckedSingleton lo hi = runST $ do
+  !(arr :: Mutable arr s a) <- I.new 2
+  I.write arr 0 lo
+  I.write arr 1 hi
+  r <- I.unsafeFreeze arr
+  return (Set r)
+
+member :: forall arr a. (Contiguous arr, Element arr a, Ord a)
+  => a
+  -> Set arr a
+  -> Bool
+member a (Set arr) = go 0 ((div (I.size arr) 2) - 1) where
+  go :: Int -> Int -> Bool
+  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)
+         in a >= valLo && a <= valHi
+      else False
+    else
+      let !mid = div (end + start + 1) 2
+          !valLo = I.index arr (2 * mid)
+       in case P.compare a valLo of
+            LT -> go start (mid - 1)
+            EQ -> True
+            GT -> go mid end
+{-# INLINEABLE member #-}
+
+-- This may segfault if given something out of bounds
+indexLower :: (Contiguous arr, Element arr a)
+  => Int
+  -> Set arr a
+  -> a 
+indexLower ix (Set arr) = I.index arr (ix * 2)
+
+-- This may segfault if given something out of bounds
+indexUpper :: (Contiguous arr, Element arr a)
+  => Int
+  -> Set arr a
+  -> a 
+indexUpper ix (Set arr) = I.index arr (ix * 2 + 1)
+
+-- This may segfault if given bad indices. You are allow to give
+-- a high index that is one less than the low index though.
+slice :: (Contiguous arr, Element arr a)
+  => Int -- inclusive low index
+  -> Int -- inclusive high index
+  -> Set arr a
+  -> Set arr a
+slice loIx hiIx (Set arr) = Set (I.clone arr (loIx * 2) ((hiIx - loIx + 1) * 2))
+
+-- This is exported for use in Unbounded Diet Sets, but it should
+-- be considered an internal function since it provided an index
+-- into the set.
+-- Right means that the needle was found. The index provided is the
+-- index of the range that contains it [0,n). Left means that the needle
+-- was not contained by any of the ranges. The index provided is
+-- the index of the range to its right [0,n]
+locate :: forall arr a. (Contiguous arr, Element arr a, Ord a)
+  => a
+  -> Set arr a
+  -> Either Int Int
+locate a (Set arr) = go 0 ((div (I.size arr) 2) - 1) where
+  go :: Int -> Int -> Either Int Int
+  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)
+         in if (a >= valLo)
+              then if a <= valHi
+                then Right start
+                else Left (start + 1)
+              else Left start 
+      else Left 0
+    else
+      let !mid = div (end + start + 1) 2
+          !valLo = I.index arr (2 * mid)
+       in case P.compare a valLo of
+            LT -> go start (mid - 1)
+            EQ -> Right mid
+            GT -> go mid end
+
+betweenInclusive :: forall arr a. (Contiguous arr, Element arr a, Ord a)
+  => a -- ^ inclusive lower bound
+  -> a -- ^ inclusive upper bound
+  -> Set arr a
+  -> Set arr a
+betweenInclusive lo hi (Set arr)
+  | hi < lo = empty
+  | I.size arr > 0 && I.index arr 0 >= lo && I.index arr (I.size arr - 1) <= hi = Set arr
+  | otherwise = case locate lo (Set arr) of
+      Left ixLo -> case locate hi (Set arr) of
+        Left ixHi -> Set (I.clone arr (ixLo * 2) ((ixHi - ixLo) * 2))
+        Right ixHi -> runST $ do
+          let len = ixHi - ixLo + 1
+          res <- I.new (len * 2)
+          rightLo <- I.indexM arr (ixHi * 2)
+          I.copy res 0 arr (ixLo * 2) (len * 2 - 2)
+          I.write res (len * 2 - 2) rightLo
+          I.write res (len * 2 - 1) hi
+          r <- I.unsafeFreeze res
+          return (Set r)
+      Right ixLo -> case locate hi (Set arr) of
+        Left ixHi -> runST $ do
+          let len = ixHi - ixLo
+          (res :: Mutable arr s a) <- I.new (len * 2)
+          leftHi <- I.indexM arr (ixLo * 2 + 1)
+          I.write res 0 lo
+          I.write res 1 leftHi
+          I.copy res 2 arr (ixLo * 2 + 2) (len * 2 - 2)
+          r <- I.unsafeFreeze res
+          return (Set r)
+        Right ixHi -> if ixLo == ixHi
+          then uncheckedSingleton lo hi
+          else runST $ do
+            let len = ixHi - ixLo + 1
+            (res :: Mutable arr s a) <- I.new (len * 2)
+            leftHi <- I.indexM arr (ixLo * 2 + 1)
+            I.write res 0 lo
+            I.write res 1 leftHi
+            I.copy res 2 arr (ixLo * 2 + 2) (len * 2 - 4)
+            rightLo <- I.indexM arr (ixHi * 2)
+            I.write res (len * 2 - 2) rightLo
+            I.write res (len * 2 - 1) hi
+            r <- I.unsafeFreeze res
+            return (Set r)
+           
+
+aboveInclusive :: forall arr a. (Contiguous arr, Element arr a, Ord a)
+  => a -- ^ inclusive lower bound
+  -> Set arr a
+  -> Set arr a
+aboveInclusive x (Set arr) = case locate x (Set arr) of
+  Left ix -> if ix == 0
+    then Set arr
+    else Set (I.clone arr (ix * 2) (I.size arr - ix * 2))
+  Right ix ->
+    let lo = I.index arr (ix * 2)
+        hi = I.index arr (ix * 2 + 1)
+     in if lo == x
+          then if ix == 0
+            then Set arr
+            else Set (I.clone arr (ix * 2) (I.size arr - ix * 2))
+          else runST $ do
+            (result :: Mutable arr s a) <- I.new (I.size arr - ix * 2)
+            I.write result 0 x
+            I.write result 1 hi
+            I.copy result 2 arr ((ix + 1) * 2) (I.size arr - ix * 2 - 2)
+            r <- I.unsafeFreeze result
+            return (Set r)
+
+aboveExclusive :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)
+  => a -- ^ exclusive lower bound
+  -> Set arr a
+  -> Set arr a
+aboveExclusive x (Set arr) = case locate x (Set arr) of
+  Left ix -> if ix == 0
+    then Set arr
+    else Set (I.clone arr (ix * 2) (I.size arr - ix * 2))
+  Right ix ->
+    let hi = I.index arr (ix * 2 + 1)
+     in if hi == x
+          then Set (I.clone arr ((ix + 1) * 2) (I.size arr - (ix + 1) * 2))
+          else runST $ do
+            (result :: Mutable arr s a) <- I.new (I.size arr - ix * 2)
+            I.write result 0 (succ x)
+            I.write result 1 hi
+            I.copy result 2 arr ((ix + 1) * 2) (I.size arr - ix * 2 - 2)
+            r <- I.unsafeFreeze result
+            return (Set r)
+
+
+belowInclusive :: forall arr a. (Contiguous arr, Element arr a, Ord a)
+  => a -- ^ inclusive upper bound
+  -> Set arr a
+  -> Set arr a
+belowInclusive x (Set arr) = case locate x (Set arr) of
+  Left ix -> if ix * 2 == I.size arr
+    then Set arr
+    else Set (I.clone arr 0 (ix * 2))
+  Right ix ->
+    let lo = I.index arr (ix * 2)
+        hi = I.index arr (ix * 2 + 1)
+     in if hi == x
+          then if ix * 2 == I.size arr - 2
+            then Set arr
+            else Set (I.clone arr 0 ((ix + 1) * 2))
+          else runST $ do
+            result <- I.new ((ix + 1) * 2)
+            I.copy result 0 arr 0 (ix * 2)
+            I.write result (ix * 2) lo
+            I.write result (ix * 2 + 1) x
+            r <- I.unsafeFreeze result
+            return (Set r)
+
+belowExclusive :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)
+  => a -- ^ exclusive upper bound
+  -> Set arr a
+  -> Set arr a
+belowExclusive x (Set arr) = case locate x (Set arr) of
+  Left ix -> if ix * 2 == I.size arr
+    then Set arr
+    else Set (I.clone arr 0 (ix * 2))
+  Right ix ->
+    let lo = I.index arr (ix * 2)
+     in if lo == x
+          then Set (I.clone arr 0 (ix * 2))
+          else runST $ do
+            result <- I.new ((ix + 1) * 2)
+            I.copy result 0 arr 0 (ix * 2)
+            I.write result (ix * 2) lo
+            I.write result (ix * 2 + 1) (pred x)
+            r <- I.unsafeFreeze result
+            return (Set r)
+
+append :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)
+  => Set arr a
+  -> Set arr a
+  -> Set arr a
+append (Set keysA) (Set keysB)
+  | szA < 1 = Set keysB
+  | szB < 1 = Set keysA
+  | otherwise = runST action
+  where
+  !szA = div (I.size keysA) 2
+  !szB = div (I.size keysB) 2
+  action :: forall s. ST s (Set arr a)
+  action = do
+    !(keysDst :: Mutable arr s a) <- I.new (max szA szB * 8)
+    let writeKeyRange :: Int -> a -> a -> ST s ()
+        writeKeyRange !ix !lo !hi = do
+          I.write keysDst (2 * ix) lo
+          I.write keysDst (2 * ix + 1) hi
+        writeDstHiKey :: Int -> a -> ST s ()
+        writeDstHiKey !ix !hi = I.write keysDst (2 * ix + 1) hi
+        readDstHiKey :: Int -> ST s a
+        readDstHiKey !ix = I.read keysDst (2 * ix + 1)
+        indexLoKeyA :: Int -> a
+        indexLoKeyA !ix = I.index keysA (ix * 2)
+        indexLoKeyB :: Int -> a
+        indexLoKeyB !ix = I.index keysB (ix * 2)
+        indexHiKeyA :: Int -> a
+        indexHiKeyA !ix = I.index keysA (ix * 2 + 1)
+        indexHiKeyB :: Int -> a
+        indexHiKeyB !ix = I.index keysB (ix * 2 + 1)
+    -- In the go functon, ixDst is always at least one. Similarly,
+    -- all key arguments are always greater than minBound.
+    let go :: Int -> a -> a -> Int -> a -> a -> Int -> ST s Int
+        go !ixA !loA !hiA !ixB !loB !hiB !ixDst = do
+          prevHi <- readDstHiKey (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
+                then do
+                  writeDstHiKey (ixDst - 1) upper
+                  return ixDst
+                else do
+                  writeKeyRange ixDst loA upper
+                  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' ixB loB hiB ixDst'
+                else copyB ixB loB hiB ixDst'
+            GT -> do
+              let (upper,ixB') = if hiB < loA
+                    then (hiB,ixB + 1)
+                    else (pred loA,ixB)
+              ixDst' <- if pred loB == prevHi
+                then do
+                  writeDstHiKey (ixDst - 1) upper
+                  return ixDst
+                else do
+                  writeKeyRange ixDst loB upper
+                  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 ixB' loB' hiB' ixDst'
+                else copyA ixA loA hiA ixDst'
+            EQ -> do
+              case compare hiA hiB of
+                LT -> do
+                  ixDst' <- if pred loA == prevHi
+                    then do
+                      writeDstHiKey (ixDst - 1) hiA
+                      return ixDst
+                    else do
+                      writeKeyRange ixDst loA hiA
+                      return (ixDst + 1)
+                  let ixA' = ixA + 1
+                      loB' = succ hiA
+                  if ixA' < szA
+                    then go ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') ixB loB' hiB ixDst'
+                    else copyB ixB loB' hiB ixDst'
+                GT -> do
+                  ixDst' <- if pred loB == prevHi
+                    then do
+                      writeDstHiKey (ixDst - 1) hiB
+                      return ixDst
+                    else do
+                      writeKeyRange ixDst loB hiB
+                      return (ixDst + 1)
+                  let ixB' = ixB + 1
+                      loA' = succ hiB
+                  if ixB' < szB
+                    then go ixA loA' hiA ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') ixDst'
+                    else copyA ixA loA' hiA ixDst'
+                EQ -> do
+                  ixDst' <- if pred loB == prevHi
+                    then do
+                      writeDstHiKey (ixDst - 1) hiB
+                      return ixDst
+                    else do
+                      writeKeyRange ixDst loB hiB
+                      return (ixDst + 1)
+                  let ixA' = ixA + 1
+                      ixB' = ixB + 1
+                  if ixA' < szA
+                    then if ixB' < szB
+                      then go ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') ixDst'
+                      else copyA ixA' (indexLoKeyA ixA') (indexHiKeyA ixA') ixDst'
+                    else if ixB' < szB
+                      then copyB ixB' (indexLoKeyB ixB') (indexHiKeyB ixB') ixDst'
+                      else return ixDst'
+        copyB :: Int -> a -> a -> Int -> ST s Int
+        copyB !ixB !loB !hiB !ixDst = do
+          prevHi <- readDstHiKey (ixDst - 1) 
+          ixDst' <- if pred loB == prevHi
+            then do
+              writeDstHiKey (ixDst - 1) hiB
+              return ixDst
+            else do
+              writeKeyRange ixDst loB hiB
+              return (ixDst + 1)
+          let ixB' = ixB + 1
+              remaining = szB - ixB'
+          I.copy keysDst (ixDst' * 2) keysB (ixB' * 2) (remaining * 2)
+          return (ixDst' + remaining)
+        copyA :: Int -> a -> a -> Int -> ST s Int
+        copyA !ixA !loA !hiA !ixDst = do
+          prevHi <- readDstHiKey (ixDst - 1) 
+          ixDst' <- if pred loA == prevHi
+            then do
+              writeDstHiKey (ixDst - 1) hiA
+              return ixDst
+            else do
+              writeKeyRange ixDst loA hiA
+              return (ixDst + 1)
+          let ixA' = ixA + 1
+              remaining = szA - ixA'
+          I.copy keysDst (ixDst' * 2) keysA (ixA' * 2) (remaining * 2)
+          return (ixDst' + remaining)
+    let !loA0 = indexLoKeyA 0
+        !loB0 = indexLoKeyB 0
+        !hiA0 = indexHiKeyA 0
+        !hiB0 = indexHiKeyB 0
+    total <- case compare loA0 loB0 of
+      LT -> if hiA0 < loB0
+        then do
+          writeKeyRange 0 loA0 hiA0
+          if 1 < szA
+            then go 1 (indexLoKeyA 1) (indexHiKeyA 1) 0 loB0 hiB0 1
+            else copyB 0 loB0 hiB0 1
+        else do
+          -- here we know that hiA > loA
+          let !upperA = pred loB0
+          writeKeyRange 0 loA0 upperA
+          go 0 loB0 hiA0 0 loB0 hiB0 1
+      EQ -> case compare hiA0 hiB0 of
+        LT -> do
+          writeKeyRange 0 loA0 hiA0
+          if 1 < szA
+            then go 1 (indexLoKeyA 1) (indexHiKeyA 1) 0 (succ hiA0) hiB0 1
+            else copyB 0 (succ hiA0) hiB0 1
+        GT -> do
+          writeKeyRange 0 loB0 hiB0
+          if 1 < szB
+            then go 0 (succ hiB0) hiA0 1 (indexLoKeyB 1) (indexHiKeyB 1) 1
+            else copyA 0 (succ hiB0) hiA0 1
+        EQ -> do
+          writeKeyRange 0 loA0 hiA0
+          if 1 < szA
+            then if 1 < szB
+              then go 1 (indexLoKeyA 1) (indexHiKeyA 1) 1 (indexLoKeyB 1) (indexHiKeyB 1) 1
+              else copyA 1 (indexLoKeyA 1) (indexHiKeyA 1) 1
+            else if 1 < szB
+              then copyB 1 (indexLoKeyB 1) (indexHiKeyB 1) 1
+              else return 1
+      GT -> if hiB0 < loA0
+        then do
+          writeKeyRange 0 loB0 hiB0
+          if 1 < szB
+            then go 0 loA0 hiA0 1 (indexLoKeyB 1) (indexHiKeyB 1) 1
+            else copyA 0 loA0 hiA0 1
+        else do
+          let !upperB = pred loA0
+          writeKeyRange 0 loB0 upperB
+          go 0 loA0 hiA0 0 loA0 hiB0 1
+    !keysFinal <- I.resize keysDst (total * 2)
+    fmap Set (I.unsafeFreeze keysFinal)
+
+difference :: forall a arr. (Contiguous arr, Element arr a, Ord a, Enum a)
+  => Set arr a
+  -> Set arr a
+  -> Set arr a
+difference setA@(Set arrA) setB@(Set arrB)
+  | szA == 0 = empty
+  | szB == 0 = setA
+  | otherwise =
+      let inners :: Int -> [Set arr a]
+          inners !ix = if ix < szB - 1
+            then
+              let inner = betweenInclusive
+                    (succ (I.index arrB (2 * ix + 1)))
+                    (pred (I.index arrB (2 * ix + 2)))
+                    (Set arrA)
+               in inner : inners (ix + 1) 
+            else []
+          lowestA = I.index arrA 0
+          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)]
+            else []
+          highFragment = if highestA > highestB
+            then [aboveInclusive (succ 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
+
+size :: (Contiguous arr, Element arr a) => Set arr a -> Int
+size (Set arr) = quot (I.size arr) 2
+
+toList :: (Contiguous arr, Element arr a) => Set arr a -> [(a,a)]
+toList = foldr (\lo hi xs -> (lo,hi) : xs) []
+
+foldr :: (Contiguous arr, Element arr a) => (a -> a -> b -> b) -> b -> Set arr a -> b
+foldr f z (Set arr) =
+  let !sz = div (I.size arr) 2
+      go !i
+        | i == sz = z
+        | otherwise =
+            let !lo = I.index arr (i * 2)
+                !hi = I.index arr (i * 2 + 1)
+             in f lo hi (go (i + 1))
+   in go 0
+{-# INLINABLE foldr #-}
+
+showsPrec :: (Contiguous arr, Element arr a, Show a)
+  => Int
+  -> Set arr a
+  -> ShowS
+showsPrec p xs = showParen (p > 10) $
+  showString "fromList " . shows (toList xs)
+
diff --git a/src/Data/Diet/Set/Lifted.hs b/src/Data/Diet/Set/Lifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Diet/Set/Lifted.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# OPTIONS_GHC -O2 #-}
+module Data.Diet.Set.Lifted
+  ( Set
+  , singleton
+  , member
+  , difference
+    -- * Split
+  , aboveInclusive
+  , belowInclusive
+  , betweenInclusive
+    -- * Folds
+  , foldr
+    -- * List Conversion
+  , fromList
+  , fromListN
+  ) where
+
+import Prelude hiding (lookup,map,foldr)
+
+import Data.Semigroup (Semigroup)
+import Data.Primitive (Array)
+import qualified GHC.Exts as E
+import qualified Data.Semigroup as SG
+import qualified Data.Diet.Set.Internal as I
+
+newtype Set a = Set (I.Set Array a)
+
+-- | /O(1)/ Create a diet set with a single element.
+singleton :: Ord a
+  => a -- ^ inclusive lower bound
+  -> a -- ^ inclusive 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 diet set.
+member :: Ord a => a -> Set a -> Bool
+member a (Set s) = I.member a 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 => Ord (Set a) where
+  compare (Set xs) (Set ys) = compare (I.toList xs) (I.toList ys)
+
+instance (Ord a, Enum 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.<>)
+  mconcat = Set . I.concat . E.coerce
+
+instance (Ord a, Enum a) => E.IsList (Set a) where
+  type Item (Set a) = (a,a)
+  fromListN n = Set . I.fromListN n
+  fromList = Set . I.fromList
+  toList (Set s) = I.toList s
+
+fromList :: (Ord a, Enum a) => [(a,a)] -> Set a
+fromList = Set . I.fromList
+
+fromListN :: (Ord a, Enum a)
+  => Int -- ^ expected size of resulting diet 'Set'
+  -> [(a,a)] -- ^ key-value pairs
+  -> Set a
+fromListN n = Set . I.fromListN n
+
+-- | /O(n + m*log n)/ Subtract the subtrahend of size @m@ from the
+-- minuend of size @n@. It should be possible to improve the improve
+-- the performance of this to /O(n + m)/. Anyone interested in doing
+-- this should open a PR.
+difference :: (Ord a, Enum a)
+  => Set a -- ^ minuend
+  -> Set a -- ^ subtrahend
+  -> Set a
+difference (Set x) (Set y) = Set (I.difference x y)
+
+foldr :: (a -> a -> b -> b) -> b -> Set a -> b
+foldr f z (Set arr) = I.foldr f z arr
+
+-- | /O(n)/ The subset where all elements are greater than
+-- or equal to the given value. 
+aboveInclusive :: (Ord a)
+  => a -- ^ inclusive lower bound
+  -> Set a
+  -> Set a
+aboveInclusive x (Set s) = Set (I.aboveInclusive x s)
+
+-- | /O(n)/ The subset where all elements are less than
+-- or equal to the given value. 
+belowInclusive :: (Ord a)
+  => a -- ^ inclusive upper bound
+  -> Set a
+  -> Set a
+belowInclusive x (Set s) = Set (I.belowInclusive x s)
+
+-- | /O(n)/ The subset where all elements are greater than
+-- or equal to the lower bound and less than or equal to
+-- the upper bound.
+betweenInclusive :: (Ord a)
+  => a -- ^ inclusive lower bound
+  -> a -- ^ inclusive upper bound
+  -> Set a
+  -> Set a
+betweenInclusive x y (Set s) = Set (I.betweenInclusive x y s)
+
diff --git a/src/Data/Diet/Set/Unboxed.hs b/src/Data/Diet/Set/Unboxed.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Diet/Set/Unboxed.hs
@@ -0,0 +1,120 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# OPTIONS_GHC -O2 #-}
+module Data.Diet.Set.Unboxed
+  ( Set
+  , singleton
+  , member
+  , difference
+    -- * Split
+  , aboveInclusive
+  , belowInclusive
+  , betweenInclusive
+    -- * Folds
+  , foldr
+    -- * List Conversion
+  , toList
+  , fromList
+  , fromListN
+  ) where
+
+import Prelude hiding (lookup,map,foldr)
+
+import Data.Semigroup (Semigroup)
+import Data.Functor.Classes (Show2(..))
+import Data.Primitive.Types (Prim)
+import Data.Primitive.PrimArray (PrimArray)
+import qualified GHC.Exts as E
+import qualified Data.Semigroup as SG
+import qualified Data.Diet.Set.Internal as I
+
+newtype Set a = Set (I.Set PrimArray a)
+
+-- | /O(1)/ Create a diet set with a single element.
+singleton :: (Ord a, Prim a)
+  => a -- ^ inclusive lower bound
+  -> a -- ^ inclusive upper bound
+  -> Set a
+singleton lo hi = Set (I.singleton lo hi)
+
+-- | /O(log n)/ Lookup the value at a key in the map.
+member :: (Ord a, Prim a) => a -> Set a -> Bool
+member a (Set s) = I.member a s
+
+instance (Show a, Prim a) => Show (Set a) where
+  showsPrec p (Set s) = I.showsPrec p s
+
+instance (Eq a, Prim a) => Eq (Set a) where
+  Set x == Set y = I.equals x y
+
+instance (Ord a, Prim a) => Ord (Set a) where
+  compare (Set xs) (Set ys) = compare (I.toList xs) (I.toList ys)
+
+instance (Ord a, Enum a, Prim a) => Semigroup (Set a) where
+  Set x <> Set y = Set (I.append x y)
+
+instance (Ord a, Enum a, Prim a) => Monoid (Set a) where
+  mempty = Set I.empty
+  mappend = (SG.<>)
+  mconcat = Set . I.concat . E.coerce
+
+instance (Ord a, Enum a, Prim a) => E.IsList (Set a) where
+  type Item (Set a) = (a,a)
+  fromListN n = Set . I.fromListN n
+  fromList = Set . I.fromList
+  toList (Set s) = I.toList s
+
+toList :: Prim a => Set a -> [(a,a)]
+toList (Set x) = I.toList x
+
+fromList :: (Ord a, Enum a, Prim a) => [(a,a)] -> Set a
+fromList = Set . I.fromList
+
+fromListN :: (Ord a, Enum a, Prim a)
+  => Int -- ^ expected size of resulting diet 'Set'
+  -> [(a,a)] -- ^ key-value pairs
+  -> Set a
+fromListN n = Set . I.fromListN n
+
+-- | /O(n + m*log n)/ Subtract the subtrahend of size @m@ from the
+-- minuend of size @n@. It should be possible to improve the improve
+-- the performance of this to /O(n + m)/. Anyone interested in doing
+-- this should open a PR.
+difference :: (Ord a, Enum a, Prim a)
+  => Set a -- ^ minuend
+  -> Set a -- ^ subtrahend
+  -> Set a
+difference (Set x) (Set y) = Set (I.difference x y)
+
+foldr :: Prim a => (a -> a -> b -> b) -> b -> Set a -> b
+foldr f z (Set arr) = I.foldr f z arr
+
+-- | /O(n)/ The subset where all elements are greater than
+-- or equal to the given value. 
+aboveInclusive :: (Ord a, Prim a)
+  => a -- ^ inclusive lower bound
+  -> Set a
+  -> Set a
+aboveInclusive x (Set s) = Set (I.aboveInclusive x s)
+
+-- | /O(n)/ The subset where all elements are less than
+-- or equal to the given value. 
+belowInclusive :: (Ord a, Prim a)
+  => a -- ^ inclusive upper bound
+  -> Set a
+  -> Set a
+belowInclusive x (Set s) = Set (I.belowInclusive x s)
+
+-- | /O(n)/ The subset where all elements are greater than
+-- or equal to the lower bound and less than or equal to
+-- the upper bound.
+betweenInclusive :: (Ord a, Prim a)
+  => a -- ^ inclusive lower bound
+  -> a -- ^ inclusive upper bound
+  -> Set a
+  -> Set a
+betweenInclusive x y (Set s) = Set (I.betweenInclusive x y s)
+
diff --git a/src/Data/Diet/Unbounded/Set/Internal.hs b/src/Data/Diet/Unbounded/Set/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Diet/Unbounded/Set/Internal.hs
@@ -0,0 +1,254 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{-# OPTIONS_GHC -Wall #-}
+
+module Data.Diet.Unbounded.Set.Internal
+  ( Set
+  , empty
+  , singleton
+  , append
+  , member
+  , equals
+  , showsPrec
+  ) where
+
+import Prelude hiding (showsPrec)
+
+import Data.Primitive.Contiguous (Contiguous,Element,Mutable)
+
+import qualified Data.Diet.Set.Internal as S
+import qualified Data.Primitive.Contiguous as I
+
+-- todo: switch to using an unboxed sum instead of
+-- Maybe once GHC 8.4.3 becomes prevalent.
+--
+-- If the first Maybe is Just, then everything from negative
+-- infinity (whatever that may mean for the type at hand) up
+-- to the value is included in the set. It works similarly
+-- for the second Maybe and positive infinity. Internally,
+-- we must uphold the invariant that the range up from negative
+-- infinity and the one up to positive infinity do not overlap
+-- with the diet set in the middle and that they are not
+-- adjacent to it (according to the Enum instance).
+--
+-- The second data constructor, SetAll, means that all values
+-- of type @a@ are included in the Set. We do actually need
+-- a separate data constructor for this since there is no
+-- way to communicate it with the first one.
+data Set arr a
+  = SetSome !(Maybe a) !(S.Set arr a) !(Maybe a)
+  | SetAll
+
+empty :: Contiguous arr => Set arr a
+empty = SetSome Nothing S.empty Nothing
+
+equals :: (Contiguous arr, Element arr a, Eq a) => Set arr a -> Set arr a -> Bool
+equals SetAll SetAll = True
+equals SetAll (SetSome _ _ _) = False
+equals (SetSome _ _ _) SetAll = False
+equals (SetSome a b c) (SetSome x y z) = a == x && c == z && S.equals b y
+
+singleton :: (Contiguous arr, Element arr a, Ord a)
+  => Maybe a -- ^ lower inclusive bound, @Nothing@ means @-∞@
+  -> Maybe a -- ^ upper inclusive bound, @Nothing@ means @+∞@
+  -> Set arr a
+singleton Nothing Nothing = SetAll
+singleton Nothing (Just hi) = SetSome (Just hi) S.empty Nothing
+singleton (Just lo) Nothing = SetSome Nothing S.empty (Just lo)
+singleton (Just lo) (Just hi) = SetSome Nothing (S.singleton lo hi) Nothing
+
+append :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)
+  => Set arr a
+  -> Set arr a
+  -> Set arr a
+append SetAll _ = SetAll
+append (SetSome _ _ _) SetAll = SetAll
+append (SetSome Nothing a Nothing) (SetSome Nothing b Nothing) =
+  SetSome Nothing (S.append a b) Nothing
+append (SetSome (Just infHiA) a Nothing) (SetSome Nothing b Nothing) =
+  let (infHi, trimmedB) = establishInfinityHi infHiA b
+   in SetSome (Just infHi) (S.append a trimmedB) Nothing
+append (SetSome Nothing a Nothing) (SetSome (Just infHiB) b Nothing) =
+  let (infHi, trimmedA) = establishInfinityHi infHiB a
+   in SetSome (Just infHi) (S.append trimmedA b) Nothing
+append (SetSome (Just infHiA) a Nothing) (SetSome (Just infHiB) b Nothing) =
+  case compare infHiA infHiB of
+    EQ -> SetSome (Just infHiA) (S.append a b) Nothing
+    LT -> 
+      let (infHi, trimmedA) = establishInfinityHi infHiB a
+       in SetSome (Just infHi) (S.append trimmedA b) Nothing
+    GT -> 
+      let (infHi, trimmedB) = establishInfinityHi infHiA b
+       in SetSome (Just infHi) (S.append a trimmedB) Nothing
+append (SetSome Nothing a (Just infLoA)) (SetSome Nothing b Nothing) =
+  let (infLo, trimmedB) = establishInfinityLo infLoA b
+   in SetSome Nothing (S.append a trimmedB) (Just infLo)
+append (SetSome Nothing a Nothing) (SetSome Nothing b (Just infLoB)) =
+  let (infLo, trimmedA) = establishInfinityLo infLoB a
+   in SetSome Nothing (S.append trimmedA b) (Just infLo)
+append (SetSome Nothing a (Just infLoA)) (SetSome Nothing b (Just infLoB)) =
+  case compare infLoA infLoB of
+    EQ -> SetSome Nothing (S.append a b) (Just infLoB)
+    LT -> 
+      let (infLo, trimmedB) = establishInfinityLo infLoA b
+       in SetSome Nothing (S.append a trimmedB) (Just infLo)
+    GT -> 
+      let (infLo, trimmedA) = establishInfinityLo infLoB a
+       in SetSome Nothing (S.append trimmedA b) (Just infLo)
+append (SetSome (Just infHiA) a (Just infLoA)) (SetSome Nothing b Nothing) =
+  case establishInfinityBoth infHiA infLoA b of
+    Nothing -> SetAll
+    Just (infHi,infLo,trimmedB) -> SetSome (Just infHi) (S.append a trimmedB) (Just infLo)
+append (SetSome Nothing a Nothing) (SetSome (Just infHiB) b (Just infLoB)) =
+  case establishInfinityBoth infHiB infLoB a of
+    Nothing -> SetAll
+    Just (infHi,infLo,trimmedA) -> SetSome (Just infHi) (S.append trimmedA b) (Just infLo)
+append (SetSome (Just infHiA) a (Just infLoA)) (SetSome (Just infHiB) b (Just infLoB)) =
+  generalAppend (max infHiA infHiB) (min infLoA infLoB) a b
+append (SetSome Nothing a (Just infLoA)) (SetSome (Just infHiB) b (Just infLoB)) =
+  generalAppend infHiB (min infLoA infLoB) a b
+append (SetSome (Just infHiA) a (Just infLoA)) (SetSome Nothing b (Just infLoB)) =
+  generalAppend infHiA (min infLoA infLoB) a b
+append (SetSome (Just infHiA) a Nothing) (SetSome (Just infHiB) b (Just infLoB)) =
+  generalAppend (max infHiA infHiB) infLoB a b
+append (SetSome (Just infHiA) a (Just infLoA)) (SetSome (Just infHiB) b Nothing) =
+  generalAppend (max infHiA infHiB) infLoA a b
+append (SetSome Nothing a (Just infLoA)) (SetSome (Just infHiB) b Nothing) =
+  generalAppend infHiB infLoA a b
+append (SetSome (Just infHiA) a Nothing) (SetSome Nothing b (Just infLoB)) =
+  generalAppend infHiA infLoB a b
+
+generalAppend :: (Contiguous arr, Ord a, Enum a, Element arr a)
+  => a -> a -> S.Set arr a -> S.Set arr a -> Set arr a
+generalAppend infHiX infLoX a b =
+  case establishInfinityBoth infHiX infLoX (S.append a b) of
+    Nothing -> SetAll
+    Just (infHi,infLo,trimmed) -> SetSome (Just infHi) trimmed (Just infLo)
+
+-- This takes an value @a@ which is the upper bound of (-∞,a] range.
+-- It also takes a diet set. It removes everything from the set
+-- that is contained by the up-from-negative-infinity range, and
+-- it also removes a range adjacent to @a@. If a range adjacent to
+-- @a@ was removed, then the returned value will be the upper bound
+-- of the removed adjacent range.
+establishInfinityHi :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)
+  => a -- upper bound from negative infinity
+  -> S.Set arr a -- diet set
+  -> (a, S.Set arr a) -- new upper bound, trimmed diet set
+establishInfinityHi a s = case locateAdjacentAbove a s of
+  Right ix ->
+    let upper = S.indexUpper ix s
+     in (upper,S.slice (ix + 1) (S.size s - 1) s)
+  Left ix -> (a,S.slice ix (S.size s - 1) s)
+
+establishInfinityLo :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)
+  => a -- lower bound from positive infinity
+  -> S.Set arr a -- diet set
+  -> (a, S.Set arr a) -- new lower bound, trimmed diet set
+establishInfinityLo a s = case locateAdjacentBelow a s of
+  Right ix ->
+    let lower = S.indexLower ix s
+     in (lower,S.slice 0 (ix - 1) s)
+  Left ix -> (a, S.slice 0 ix s)
+
+-- this is a tweaked version of locate. If the element
+-- isn't found in the diet set, it looks at its predecessor
+-- to see if it is present so that we can collapse a maximal
+-- number of ranges. Left gives the index of the range to
+-- the left of (meaning: less than) the element.
+--
+-- Right: [0,n-1]
+-- Left: [-1,n-1]
+locateAdjacentBelow :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)
+  => a -- lower bound from positive infinity
+  -> S.Set arr a -- diet set
+  -> Either Int Int
+locateAdjacentBelow a s = case S.locate a s of
+  Right ix -> Right ix
+  Left ix -> if ix == 0
+    then Left (-1)
+    else if S.indexUpper (ix - 1) s == pred a
+      then Right (ix - 1)
+      else Left (ix - 1)
+
+-- this is a tweaked version of locate. If the element
+-- isn't found in the diet set, it looks at its successor
+-- to see if it is present so that we can collapse a maximal
+-- number of ranges. Left gives the index of the range to
+-- the right of (meaning: greater than) the element.
+--
+-- Right: [0,n-1]
+-- Left: [0,n]
+locateAdjacentAbove :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)
+  => a -- upper bound from negative infinity
+  -> S.Set arr a -- diet set
+  -> Either Int Int
+locateAdjacentAbove a s = case S.locate a s of
+  Right ix -> Right ix
+  Left ix -> if ix == S.size s
+    then Left ix
+    else if S.indexLower ix s == succ a
+      then Right ix
+      else Left ix
+
+establishInfinityBoth :: forall arr a. (Contiguous arr, Element arr a, Ord a, Enum a)
+  => a -- upper bound from negative infinity
+  -> a -- lower bound from positive infinity
+  -> S.Set arr a -- diet set
+  -> Maybe (a, a, S.Set arr a) -- new upper bound, new lower bound, trimmed diet set
+establishInfinityBoth negInfHi posInfLo s = if posInfLo <= negInfHi
+  then Nothing
+  else case locateAdjacentAbove negInfHi s of
+    Left loIx -> case locateAdjacentBelow posInfLo s of
+      Left hiIx -> Just (negInfHi,posInfLo,S.slice loIx hiIx s)
+      Right hiIx -> Just (negInfHi,S.indexLower hiIx s,S.slice loIx (hiIx - 1) s)
+    Right loIx -> case locateAdjacentBelow posInfLo s of
+      Left hiIx -> Just (S.indexUpper loIx s,posInfLo,S.slice (loIx + 1) hiIx s)
+      Right hiIx -> if hiIx <= loIx
+        then Nothing
+        else Just (S.indexUpper loIx s, S.indexLower hiIx s, S.slice (loIx + 1) (hiIx - 1) s)
+  
+member :: forall arr a. (Contiguous arr, Element arr a, Ord a)
+  => a
+  -> Set arr a
+  -> Bool
+member _ SetAll = True
+member x (SetSome negInfHi s posInfLo) =
+     maybe False (\hi -> hi >= x) negInfHi
+  || maybe False (\lo -> lo <= x) posInfLo
+  || S.member x s
+{-# INLINEABLE member #-}
+
+showsPrec :: (Contiguous arr, Element arr a, Show a)
+  => Int
+  -> Set arr a
+  -> ShowS
+showsPrec _ SetAll = showString "[(-∞,+∞)]"
+showsPrec p (SetSome negInfHi s posInfLo) = showParen (p > 10) $
+  showString "fromList " . showListInf shows negInfHi (S.toList s) posInfLo
+
+showListInf :: (a -> ShowS) -> Maybe a -> [(a,a)] -> Maybe a -> ShowS
+showListInf showx mnegInfHi [] mposInfLo s = case mnegInfHi of
+  Nothing -> case mposInfLo of
+    Nothing -> "[]" ++ s
+    Just posInfLo -> '[' : showPosInfLo showx posInfLo (']' : s)
+  Just negInfHi -> case mposInfLo of
+    Nothing -> '[' : showNegInfHi showx negInfHi (']' : s)
+    Just posInfLo -> '[' : showNegInfHi showx negInfHi (',' : showPosInfLo showx posInfLo (']' : s))
+showListInf showx mnegInfHi ((a0,b0):xs) mposInfLo s =
+  '[' : maybe id (\negInfHi s' -> showNegInfHi showx negInfHi (',' : s')) mnegInfHi ('(' : showx a0 (',' : showx b0 (')' : showl xs)))
+  where
+    showl [] = maybe id (\posInfLo -> showChar ',' . showPosInfLo showx posInfLo) mposInfLo (']' : s)
+    showl ((a,b):ys) = ',' : '(' : showx a (',' : showx b (')' : showl ys))
+
+showNegInfHi :: (a -> ShowS) -> a -> ShowS
+showNegInfHi showx x s = "(-∞," ++ showx x (")" ++ s)
+
+showPosInfLo :: (a -> ShowS) -> a -> ShowS
+showPosInfLo showx x s = '(' : (showx x (",+∞)" ++ s))
+
diff --git a/src/Data/Diet/Unbounded/Set/Lifted.hs b/src/Data/Diet/Unbounded/Set/Lifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Diet/Unbounded/Set/Lifted.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# OPTIONS_GHC -O2 #-}
+module Data.Diet.Unbounded.Set.Lifted
+  ( Set
+  , singleton
+  , member
+  ) where
+
+import Data.Semigroup (Semigroup)
+import Data.Primitive (Array)
+import qualified GHC.Exts as E
+import qualified Data.Semigroup as SG
+import qualified Data.Diet.Unbounded.Set.Internal as I
+
+newtype Set a = Set (I.Set Array a)
+
+instance Eq a => Eq (Set a) where
+  Set x == Set y = I.equals x y
+
+instance (Ord a, Enum 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.<>)
+
+instance Show a => Show (Set a) where
+  showsPrec p (Set s) = I.showsPrec p s
+
+-- | /O(1)/ Create an unbounded diet set with a single element.
+singleton :: Ord a
+  => Maybe a -- ^ lower inclusive bound, @Nothing@ means @-∞@
+  -> Maybe a -- ^ upper inclusive bound, @Nothing@ means @+∞@
+  -> Set a
+singleton lo hi = Set (I.singleton lo hi)
+
+-- | /O(log n)/ Returns @True@ if the element is a member of the diet set.
+member :: Ord a => a -> Set a -> Bool
+member a (Set s) = I.member a s
+
+
+
diff --git a/src/Data/Map/Internal.hs b/src/Data/Map/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Map/Internal.hs
@@ -0,0 +1,414 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+{-# OPTIONS_GHC -O2 -Wall #-}
+module Data.Map.Internal
+  ( Map
+  , empty
+  , singleton
+  , map
+  , mapMaybe
+    -- * Folds
+  , foldlWithKey'
+  , foldrWithKey'
+  , foldMapWithKey'
+    -- * Monadic Folds
+  , foldlWithKeyM'
+  , foldrWithKeyM'
+  , foldlMapWithKeyM'
+  , foldrMapWithKeyM'
+    -- * Functions
+  , append
+  , lookup
+  , showsPrec
+  , equals
+  , compare
+  , toList
+  , concat
+  , size
+    -- * List Conversion
+  , fromListN
+  , fromList
+  , fromListAppend
+  , fromListAppendN
+    -- * Array Conversion
+  , unsafeFreezeZip
+  ) where
+
+import Prelude hiding (compare,showsPrec,lookup,map,concat)
+
+import Control.Applicative (liftA2)
+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 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
+
+-- TODO: Do some sneakiness with UnliftedRep
+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
+
+singleton :: (Contiguous karr, Element karr k, Contiguous varr, Element varr v) => k -> v -> Map karr varr k v
+singleton k v = Map
+  ( runST $ do
+      arr <- I.new 1
+      I.write arr 0 k
+      I.unsafeFreeze arr
+  )
+  ( runST $ do
+      arr <- I.new 1
+      I.write arr 0 v
+      I.unsafeFreeze arr
+  )
+
+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
+
+compare :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v, Ord v) => Map karr varr k v -> Map karr varr k v -> Ordering
+compare m1 m2 = P.compare (toList m1) (toList m2)
+
+fromListWithN :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => (v -> v -> v) -> Int -> [(k,v)] -> Map karr varr k v
+fromListWithN combine n xs =
+  case xs of
+    [] -> empty
+    (k,v) : ys ->
+      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)
+
+fromList :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) => [(k,v)] -> Map karr varr k v
+fromList = fromListN 1
+
+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.<>)
+
+fromListAppend :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v, Semigroup v) => [(k,v)] -> Map karr varr k v
+fromListAppend = fromListAppendN 1
+
+fromAscListWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)
+  => (v -> v -> v)
+  -> Int -- initial size of buffer, must be 1 or higher
+  -> k -- first key
+  -> v -- first value
+  -> [(k,v)] -- elements
+  -> ([(k,v)], Map karr varr k v)
+fromAscListWith combine !n !k0 !v0 xs0 = runST $ do
+  keys0 <- I.new n
+  vals0 <- I.new n
+  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
+        then do
+          arrKeys <- I.unsafeFreeze keys
+          arrVals <- I.unsafeFreeze vals
+          return ([],Map arrKeys arrVals)
+        else do
+          keys' <- I.resize keys 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
+        then case P.compare k old of
+          GT -> do
+            I.write keys ix k
+            I.write vals ix v
+            go (ix + 1) k sz keys vals xs
+          EQ -> do
+            !oldVal <- I.read vals (ix - 1)
+            let !newVal = combine oldVal v
+            I.write vals (ix - 1) newVal
+            go ix k sz keys vals xs
+          LT -> do
+            keys' <- I.resize keys 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'
+          vals' <- I.resize vals sz'
+          go ix old sz' keys' vals' ((k,v) : xs)
+  go 1 k0 n keys0 vals0 xs0
+
+
+map :: (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)
+
+-- | /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
+mapMaybe 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
+          a <- I.indexM vs ixSrc
+          case f a of
+            Nothing -> go (ixSrc + 1) ixDst
+            Just !b -> do
+              I.write varr ixDst b
+              I.write karr ixDst =<< I.indexM ks ixSrc
+              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)
+
+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) =
+  let !sz = I.size vals
+      go !i
+        | i == sz = z
+        | otherwise =
+            let !k = I.index keys i
+                !v = I.index vals i
+             in 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.<>)
+
+concatWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)
+  => (v -> v -> v)
+  -> [Map karr varr k v]
+  -> 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) =
+  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
+append (Map ksA vsA) (Map ksB vsB) =
+  case unionArrWith (SG.<>) ksA vsA ksB vsB of
+    (k,v) -> Map k v
+  
+unionArrWith :: forall karr varr k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr 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 $ do
+      let !szA = I.size valsA
+          !szB = I.size valsB
+      !(keysDst :: Mutable karr s k) <- I.new (szA + szB)
+      !(valsDst :: Mutable varr s v) <- I.new (szA + szB)
+      let go !ixA !ixB !ixDst = if ixA < szA
+            then if ixB < szB
+              then do
+                let !keyA = I.index keysA ixA
+                    !keyB = I.index keysB 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
+                    I.write valsDst ixDst r
+                    go (ixA + 1) (ixB + 1) (ixDst + 1)
+                  LT -> do
+                    I.write keysDst ixDst keyA
+                    I.write valsDst ixDst valA
+                    go (ixA + 1) ixB (ixDst + 1)
+                  GT -> do
+                    I.write keysDst ixDst keyB
+                    I.write valsDst ixDst valB
+                    go ixA (ixB + 1) (ixDst + 1)
+              else do
+                I.copy keysDst ixDst keysA ixA (szA - ixA)
+                I.copy valsDst ixDst valsA ixA (szA - ixA)
+                return (ixDst + (szA - ixA))
+            else if ixB < szB
+              then do
+                I.copy keysDst ixDst keysB ixB (szB - ixB)
+                I.copy valsDst ixDst valsB ixB (szB - ixB)
+                return (ixDst + (szB - ixB))
+              else return ixDst
+      !total <- go 0 0 0
+      !keysFinal <- I.resize keysDst total
+      !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 a (Map arr vals) = go 0 (I.size vals - 1) where
+  go :: Int -> Int -> Maybe v
+  go !start !end = if end < start
+    then Nothing
+    else
+      let !mid = div (end + start) 2
+          !(# v #) = I.index# arr mid
+       in case P.compare a v of
+            LT -> go start (mid - 1)
+            EQ -> case I.index# vals mid of
+              (# r #) -> Just r
+            GT -> go (mid + 1) end
+{-# INLINEABLE lookup #-}
+
+size :: (Contiguous varr, Element varr v) => Map karr varr k v -> Int
+size (Map _ arr) = I.size arr
+
+-- | 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.
+unsafeFreezeZip :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)
+  => Mutable karr s k
+  -> Mutable varr s v
+  -> ST s (Map karr varr k v)
+unsafeFreezeZip keys0 vals0 = do
+  (keys1,vals1) <- sortUniqueTaggedMutable keys0 vals0
+  keys2 <- I.unsafeFreeze keys1
+  vals2 <- I.unsafeFreeze vals1
+  return (Map keys2 vals2)
+{-# INLINEABLE unsafeFreezeZip #-}
+
+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
+  -> Map karr varr k v
+  -> m b
+foldlWithKeyM' f b0 (Map ks vs) = go 0 b0
+  where
+  !len = I.size vs
+  go :: Int -> b -> m b
+  go !ix !acc = if ix < len
+    then
+      let (# k #) = I.index# ks ix
+          (# v #) = I.index# vs ix
+       in f acc k v >>= go (ix + 1)
+    else return acc
+{-# INLINEABLE foldlWithKeyM' #-}
+
+foldrWithKeyM' :: forall karr varr k v m b. (Monad m, Contiguous karr, Element karr k, Contiguous varr, Element varr v)
+  => (k -> v -> b -> m b)
+  -> b
+  -> Map karr varr k v
+  -> m b
+foldrWithKeyM' f b0 (Map ks vs) = go (I.size vs - 1) b0
+  where
+  go :: Int -> b -> m b
+  go !ix !acc = if ix >= 0
+    then
+      let (# k #) = I.index# ks ix
+          (# v #) = I.index# vs ix
+       in f k v acc >>= go (ix - 1)
+    else return acc
+{-# INLINEABLE foldrWithKeyM' #-}
+
+foldlMapWithKeyM' :: 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
+  -> m b
+foldlMapWithKeyM' f (Map ks vs) = go 0 mempty
+  where
+  !len = I.size vs
+  go :: Int -> b -> m b
+  go !ix !accl = if ix < len
+    then
+      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' #-}
+
+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
+  -> m b
+foldrMapWithKeyM' f (Map ks vs) = go (I.size vs - 1) mempty
+  where
+  go :: Int -> b -> m b
+  go !ix !accr = if ix >= 0
+    then
+      let (# k #) = I.index# ks ix
+          (# v #) = I.index# vs ix
+       in do
+         accl <- f k v
+         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)
+  -> Map karr varr k v
+  -> b
+foldMapWithKey' f (Map ks vs) = go 0 mempty
+  where
+  !len = I.size vs
+  go :: Int -> b -> b
+  go !ix !accl = if ix < len
+    then 
+      let (# k #) = I.index# ks ix
+          (# v #) = I.index# vs ix
+       in go (ix + 1) (mappend accl (f k v))
+    else accl
+{-# INLINEABLE foldMapWithKey' #-}
+
+foldlWithKey' :: forall karr varr k v b. (Contiguous karr, Element karr k, Contiguous varr, Element varr v)
+  => (b -> k -> v -> b) 
+  -> b
+  -> Map karr varr k v
+  -> b
+foldlWithKey' f b0 (Map ks vs) = go 0 b0
+  where
+  !len = I.size vs
+  go :: Int -> b -> b
+  go !ix !acc = if ix < len
+    then 
+      let (# k #) = I.index# ks ix
+          (# v #) = I.index# vs ix
+       in go (ix + 1) (f acc k v)
+    else acc
+{-# INLINEABLE foldlWithKey' #-}
+
+foldrWithKey' :: forall karr varr k v b. (Contiguous karr, Element karr k, Contiguous varr, Element varr v)
+  => (k -> v -> b -> b)
+  -> b
+  -> Map karr varr k v
+  -> b
+foldrWithKey' f b0 (Map ks vs) = go (I.size vs - 1) b0
+  where
+  go :: Int -> b -> b
+  go !ix !acc = if ix >= 0
+    then
+      let (# k #) = I.index# ks ix
+          (# v #) = I.index# vs ix
+       in go (ix - 1) (f k v acc)
+    else acc
+{-# INLINEABLE foldrWithKey' #-}
+
diff --git a/src/Data/Map/Lifted/Lifted.hs b/src/Data/Map/Lifted/Lifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Map/Lifted/Lifted.hs
@@ -0,0 +1,185 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# OPTIONS_GHC -O2 -Wall #-}
+module Data.Map.Lifted.Lifted
+  ( Map
+  , singleton
+  , lookup
+  , size
+  , map
+  , mapMaybe
+    -- * Folds
+  , foldlWithKey'
+  , foldrWithKey'
+  , foldMapWithKey'
+    -- * Monadic Folds
+  , foldlWithKeyM'
+  , foldrWithKeyM'
+  , foldlMapWithKeyM'
+  , foldrMapWithKeyM'
+    -- * List Conversion
+  , fromList
+  , fromListAppend
+  , fromListN
+  , fromListAppendN
+  ) where
+
+import Prelude hiding (lookup,map)
+
+import Data.Semigroup (Semigroup)
+import Data.Primitive.Array (Array)
+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 and the value
+--   type must both have 'Prim' instances.
+newtype Map k v = Map (I.Map Array Array k v)
+
+instance (Ord k, Semigroup v) => Semigroup (Map k v) where
+  Map x <> Map y = Map (I.append x y)
+
+instance (Ord k, Semigroup v) => Monoid (Map k v) where
+  mempty = Map I.empty
+  mappend = (SG.<>)
+  mconcat = Map . I.concat . E.coerce
+
+instance (Eq k, Eq v) => Eq (Map k v) where
+  Map x == Map y = I.equals x y
+
+instance (Ord k, Ord v) => Ord (Map k v) where
+  compare (Map x) (Map y) = I.compare x y
+
+instance 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 (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 :: Ord k => k -> Map k v -> Maybe v
+lookup a (Map s) = I.lookup a s
+
+-- | /O(1)/ Create a map with a single element.
+singleton :: 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 :: 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 :: 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 :: (Ord k, 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 :: (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 ::
+     (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 ::
+     (v -> Maybe w)
+  -> Map k v
+  -> Map k w
+mapMaybe f (Map m) = Map (I.mapMaybe 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
+  => (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
+  => (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)
+  => (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)
+  => (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
+  => (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' ::
+     (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' ::
+     (k -> v -> b -> b) -- ^ reduction
+  -> b -- ^ initial accumulator
+  -> Map k v -- ^ map
+  -> b
+foldrWithKey' f b0 (Map m) = I.foldrWithKey' f b0 m
diff --git a/src/Data/Map/Subset/Internal.hs b/src/Data/Map/Subset/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Map/Subset/Internal.hs
@@ -0,0 +1,170 @@
+{-# 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/Lifted.hs b/src/Data/Map/Subset/Lifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Map/Subset/Lifted.hs
@@ -0,0 +1,39 @@
+{-# 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/Unboxed/Lifted.hs b/src/Data/Map/Unboxed/Lifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Map/Unboxed/Lifted.hs
@@ -0,0 +1,191 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# OPTIONS_GHC -O2 #-}
+module Data.Map.Unboxed.Lifted
+  ( Map
+  , singleton
+  , lookup
+  , size
+  , map
+  , mapMaybe
+    -- * Folds
+  , foldMapWithKey'
+    -- * Monadic Folds
+  , foldlWithKeyM'
+  , foldrWithKeyM'
+  , foldlMapWithKeyM'
+  , foldrMapWithKeyM'
+    -- * List Conversion
+  , fromList
+  , fromListAppend
+  , fromListN
+  , fromListAppendN
+    -- * 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 (PrimArray,Array,MutablePrimArray,MutableArray)
+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
+--   'Prim' instance and the value type is unconstrained.
+newtype Map k v = Map (I.Map PrimArray Array k v)
+
+-- | This fails the functor laws since fmap is strict.
+instance Prim k => Functor (Map k) where
+  fmap = map
+
+instance (Prim k, Ord k, Semigroup v) => Semigroup (Map k v) where
+  Map x <> Map y = Map (I.append x y)
+
+instance (Prim k, Ord k, Semigroup v) => Monoid (Map k v) where
+  mempty = Map I.empty
+  mappend = (SG.<>)
+  mconcat = Map . I.concat . E.coerce
+
+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, Ord v) => Ord (Map k v) where
+  compare (Map x) (Map y) = I.compare x y
+
+instance (Prim 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 (Prim 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 :: (Prim k, Ord k) => k -> Map k v -> Maybe v
+lookup a (Map s) = I.lookup a s
+
+-- | /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*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 :: (Prim 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 :: (Prim 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 :: (Prim k, Ord k, 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 :: (Prim 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 :: Prim 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 :: Prim k
+  => (v -> Maybe w)
+  -> Map k v
+  -> Map k w
+mapMaybe f (Map m) = Map (I.mapMaybe 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)
+  => (b -> k -> v -> m b)
+  -> b
+  -> Map k v
+  -> 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)
+  => (k -> v -> b -> m b)
+  -> b
+  -> Map k v
+  -> 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)
+  => (k -> v -> m b)
+  -> Map k v
+  -> 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)
+  => (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)
+  => (k -> v -> b)
+  -> Map k v
+  -> b
+foldMapWithKey' f (Map m) = I.foldMapWithKey' f 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)
+  => MutablePrimArray s k
+  -> MutableArray s v
+  -> ST s (Map k v)
+unsafeFreezeZip keys vals = fmap Map (I.unsafeFreezeZip keys vals)
diff --git a/src/Data/Map/Unboxed/Unboxed.hs b/src/Data/Map/Unboxed/Unboxed.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Map/Unboxed/Unboxed.hs
@@ -0,0 +1,206 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# OPTIONS_GHC -O2 -Wall #-}
+module Data.Map.Unboxed.Unboxed
+  ( Map
+  , singleton
+  , lookup
+  , size
+  , map
+  , mapMaybe
+    -- * Folds
+  , foldlWithKey'
+  , foldrWithKey'
+  , foldMapWithKey'
+    -- * Monadic Folds
+  , foldlWithKeyM'
+  , foldrWithKeyM'
+  , foldlMapWithKeyM'
+  , foldrMapWithKeyM'
+    -- * List Conversion
+  , fromList
+  , fromListAppend
+  , fromListN
+  , fromListAppendN
+    -- * 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.PrimArray (PrimArray,MutablePrimArray)
+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 and the value
+--   type must both have 'Prim' instances.
+newtype Map k v = Map (I.Map PrimArray PrimArray k v)
+
+instance (Prim k, Ord k, Prim v, Semigroup v) => Semigroup (Map k v) where
+  Map x <> Map y = Map (I.append x y)
+
+instance (Prim 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 (Prim k, Eq k, Prim v, Eq v) => Eq (Map k v) where
+  Map x == Map y = I.equals x y
+
+instance (Prim k, Ord k, Prim v, Ord v) => Ord (Map k v) where
+  compare (Map x) (Map y) = I.compare x y
+
+instance (Prim 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 (Prim 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 :: (Prim k, Ord k, Prim v) => k -> Map k v -> Maybe v
+lookup a (Map s) = I.lookup a s
+
+-- | /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*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 :: (Prim 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 :: (Prim 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 :: (Prim 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 :: (Prim 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(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 :: (Prim 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 :: (Prim 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)/ 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)
+  => (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, 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, Prim 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, Prim 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, Prim 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' :: (Prim 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' :: (Prim 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, Prim k, Prim v)
+  => MutablePrimArray s k
+  -> MutablePrimArray s v
+  -> ST s (Map k v)
+unsafeFreezeZip keys vals = fmap Map (I.unsafeFreezeZip keys vals)
+
diff --git a/src/Data/Map/Unboxed/Unlifted.hs b/src/Data/Map/Unboxed/Unlifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Map/Unboxed/Unlifted.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# OPTIONS_GHC -O2 #-}
+module Data.Map.Unboxed.Unlifted
+  ( Map
+  , singleton
+  , lookup
+  , size
+    -- * List Conversion
+  , fromList
+  , fromListAppend
+  , fromListN
+  , fromListAppendN
+  ) where
+
+import Prelude hiding (lookup)
+
+import Data.Semigroup (Semigroup)
+import Data.Primitive.Types (Prim)
+import Data.Primitive.UnliftedArray (PrimUnlifted,UnliftedArray)
+import Data.Primitive (PrimArray)
+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 and the value
+--   type must both have 'Prim' instances.
+newtype Map k v = Map (I.Map PrimArray UnliftedArray k v)
+
+instance (Prim k, Ord k, PrimUnlifted v, Semigroup v) => Semigroup (Map k v) where
+  Map x <> Map y = Map (I.append x y)
+
+instance (Prim k, Ord k, PrimUnlifted v, Semigroup v) => Monoid (Map k v) where
+  mempty = Map I.empty
+  mappend = (SG.<>)
+  mconcat = Map . I.concat . E.coerce
+
+instance (Prim k, Eq k, PrimUnlifted v, Eq v) => Eq (Map k v) where
+  Map x == Map y = I.equals x y
+
+instance (Prim k, Ord k, PrimUnlifted v, Ord v) => Ord (Map k v) where
+  compare (Map x) (Map y) = I.compare x y
+
+instance (Prim k, Ord k, PrimUnlifted 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 (Prim k, Show k, PrimUnlifted 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 :: (Prim k, Ord k, PrimUnlifted v) => k -> Map k v -> Maybe v
+lookup a (Map s) = I.lookup a s
+
+-- | /O(1)/ Create a map with a single element.
+singleton :: (Prim k, PrimUnlifted 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 :: (Prim k, Ord k, PrimUnlifted 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 :: (Prim k, Ord k, PrimUnlifted 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 :: (Prim k, Ord k, PrimUnlifted 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 :: (Prim k, Ord k, PrimUnlifted v, 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 :: PrimUnlifted v => Map k v -> Int
+size (Map m) = I.size m
+
+
diff --git a/src/Data/Set/Internal.hs b/src/Data/Set/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Set/Internal.hs
@@ -0,0 +1,259 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -Wall #-}
+module Data.Set.Internal
+  ( Set(..)
+  , empty
+  , singleton
+  , difference
+  , append
+  , member
+  , showsPrec
+  , equals
+  , compare
+  , fromListN
+  , fromList
+  , toList
+  , size
+  , concat
+    -- * Folds
+  , foldr
+  , foldl'
+  , foldr'
+  , foldMap'
+  , foldlM'
+  ) where
+
+import Prelude hiding (compare,showsPrec,concat,foldr)
+import qualified Prelude as P
+
+import Control.Monad.ST (ST,runST)
+import Data.Primitive.UnliftedArray (PrimUnlifted(..))
+import Data.Primitive.Contiguous (Contiguous,Mutable,Element)
+import qualified Data.Primitive.Contiguous as A
+import qualified Data.Concatenation as C
+
+newtype Set arr a = Set (arr a)
+
+instance Contiguous arr => PrimUnlifted (Set arr a) where
+  toArrayArray# (Set a) = A.unlift a
+  fromArrayArray# a = Set (A.lift a)
+
+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)
+  
+empty :: Contiguous arr => Set arr a
+empty = Set A.empty
+
+equals :: (Contiguous arr, Element arr a, Eq a) => Set arr a -> Set arr a -> Bool
+equals (Set x) (Set y) = A.equals x y
+
+compare :: (Contiguous arr, Element arr a, Ord a) => Set arr a -> Set arr a -> Ordering
+compare (Set x) (Set y) = compareArr x y
+
+fromListN :: (Contiguous arr, Element arr a, Ord a) => Int -> [a] -> Set arr a
+fromListN n xs = -- fromList xs
+  case xs of
+    [] -> empty
+    y : ys ->
+      let (leftovers, result) = fromAscList (max 1 n) y ys
+       in concat (result : P.map singleton leftovers)
+
+fromList :: (Contiguous arr, Element arr a, Ord a) => [a] -> Set arr a
+fromList = fromListN 1
+
+difference :: forall a arr. (Contiguous arr, Element arr a, Ord a)
+  => Set arr a
+  -> Set arr a
+  -> Set arr a
+difference s1@(Set arr1) s2@(Set arr2)
+  | sz1 == 0 = empty
+  | sz2 == 0 = s1
+  | otherwise = runST $ do
+      dst <- A.new sz1
+      let go !ix1 !ix2 !dstIx = if ix2 < sz2
+            then if ix1 < sz1
+              then do
+                v1 <- A.indexM arr1 ix1
+                v2 <- A.indexM arr2 ix2
+                case P.compare v1 v2 of
+                  EQ -> go (ix1 + 1) (ix2 + 1) dstIx
+                  LT -> do
+                    A.write dst dstIx v1
+                    go (ix1 + 1) ix2 (dstIx + 1)
+                  GT -> go ix1 (ix2 + 1) dstIx
+              else return dstIx
+            else do
+              let !remaining = sz1 - ix1
+              A.copy dst dstIx arr1 ix1 remaining
+              return (dstIx + remaining)
+      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
+  -> [a] -- elements
+  -> ([a], Set arr a)
+fromAscList !n x0 xs0 = runST $ do
+  marr0 <- A.new n
+  A.write marr0 0 x0
+  let go :: forall s. Int -> a -> Int -> Mutable arr s a -> [a] -> ST s ([a], Set arr a)
+      go !ix !_ !sz !marr [] = if ix == sz
+        then do
+          arr <- A.unsafeFreeze marr
+          return ([],Set arr)
+        else do
+          marr' <- A.resize marr ix
+          arr <- A.unsafeFreeze marr'
+          return ([],Set arr)
+      go !ix !old !sz !marr (x : xs) = if ix < sz
+        then case P.compare x old of
+          GT -> do
+            A.write marr ix x
+            go (ix + 1) x sz marr xs
+          EQ -> go ix x sz marr xs
+          LT -> do
+            marr' <- A.resize marr ix
+            arr <- A.unsafeFreeze marr'
+            return (x : xs,Set arr)
+        else do
+          let sz' = sz * 2
+          marr' <- A.resize marr sz'
+          go ix old sz' marr' (x : xs)
+  go 1 x0 n marr0 xs0
+
+showsPrec :: (Contiguous arr, Element arr a, Show a) => Int -> Set arr a -> ShowS
+showsPrec p xs = showParen (p > 10) $
+  showString "fromList " . shows (toList xs)
+
+toList :: (Contiguous arr, Element arr a) => Set arr a -> [a]
+toList = foldr (:) []
+
+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
+  go !start !end = if end < start
+    then False
+    else
+      let !mid = div (end + start) 2
+          !v = A.index arr mid
+       in case P.compare a v of
+            LT -> go start (mid - 1)
+            EQ -> True
+            GT -> go (mid + 1) end
+{-# INLINEABLE member #-}
+
+concat :: forall arr a. (Contiguous arr, Element arr a, Ord a) => [Set arr a] -> Set arr a
+concat = C.concatSized size empty append
+
+compareArr :: (Contiguous arr, Element arr a, Ord a)
+  => arr a
+  -> arr a
+  -> Ordering
+compareArr arrA arrB = go 0 where
+  go :: Int -> Ordering
+  go !ix = if ix < A.size arrA
+    then if ix < A.size arrB
+      then mappend (P.compare (A.index arrA ix) (A.index arrB ix)) (go (ix + 1))
+      else GT
+    else if ix < A.size arrB
+      then LT
+      else EQ
+
+singleton :: (Contiguous arr, Element arr a) => a -> Set arr a
+singleton a = Set $ runST $ do
+  arr <- A.new 1
+  A.write arr 0 a
+  A.unsafeFreeze arr
+
+unionArr :: forall arr a. (Contiguous arr, Element arr a, Ord a)
+  => arr a -- array x
+  -> arr a -- array y
+  -> arr a
+unionArr arrA arrB
+  | szA < 1 = arrB
+  | szB < 1 = arrA
+  | otherwise = runST $ do
+      !(arrDst :: Mutable arr s a)  <- A.new (szA + szB)
+      let go !ixA !ixB !ixDst = if ixA < szA
+            then if ixB < szB
+              then do
+                let !a = A.index arrA ixA
+                    !b = A.index arrB ixB
+                case P.compare a b of
+                  EQ -> do
+                    A.write arrDst ixDst a
+                    go (ixA + 1) (ixB + 1) (ixDst + 1)
+                  LT -> do
+                    A.write arrDst ixDst a
+                    go (ixA + 1) ixB (ixDst + 1)
+                  GT -> do
+                    A.write arrDst ixDst b
+                    go ixA (ixB + 1) (ixDst + 1)
+              else do
+                A.copy arrDst ixDst arrA ixA (szA - ixA)
+                return (ixDst + (szA - ixA))
+            else if ixB < szB
+              then do
+                A.copy arrDst ixDst arrB ixB (szB - ixB)
+                return (ixDst + (szB - ixB))
+              else return ixDst
+      total <- go 0 0 0
+      arrFinal <- A.resize arrDst total
+      A.unsafeFreeze arrFinal
+  where
+  !szA = A.size arrA
+  !szB = A.size arrB
+
+size :: (Contiguous arr, Element arr a) => Set arr a -> Int
+size (Set arr) = A.size arr
+
+foldr :: (Contiguous arr, Element arr a)
+  => (a -> b -> b)
+  -> b
+  -> Set arr a
+  -> b
+foldr f b0 (Set arr) = A.foldr f b0 arr
+{-# INLINEABLE foldr #-}
+
+foldl' :: (Contiguous arr, Element arr a)
+  => (b -> a -> b)
+  -> b
+  -> Set arr a
+  -> b
+foldl' f b0 (Set arr) = A.foldl' f b0 arr
+{-# INLINEABLE foldl' #-}
+
+foldr' :: (Contiguous arr, Element arr a)
+  => (a -> b -> b)
+  -> b
+  -> Set arr a
+  -> b
+foldr' f b0 (Set arr) = A.foldr' f b0 arr
+{-# INLINEABLE foldr' #-}
+
+foldMap' :: (Contiguous arr, Element arr a, Monoid m)
+  => (a -> m)
+  -> Set arr a
+  -> m
+foldMap' f (Set arr) = A.foldMap' f arr
+{-# INLINEABLE foldMap' #-}
+
+foldlM' :: (Contiguous arr, Element arr a, Monad m)
+  => (b -> a -> m b)
+  -> b
+  -> Set arr a
+  -> m b
+foldlM' f b0 (Set arr) = A.foldlM' f b0 arr
+{-# INLINEABLE foldlM' #-}
diff --git a/src/Data/Set/Lifted.hs b/src/Data/Set/Lifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Set/Lifted.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Data.Set.Lifted
+  ( Set
+  , singleton
+  , member
+  , size
+  , difference
+  , (\\)
+    -- * List Conversion
+  , LI.toList
+  , LI.fromList
+    -- * Folds
+  , LI.foldr
+  , LI.foldl'
+  , LI.foldr'
+  , foldMap'
+  ) where
+
+import Prelude hiding (foldr)
+import Data.Semigroup (Semigroup)
+import Data.Set.Lifted.Internal (Set(..))
+import qualified Data.Set.Internal as I
+import qualified Data.Set.Lifted.Internal as LI
+
+-- | The difference of two sets.
+difference :: Ord a => Set a -> Set a -> Set a
+difference (Set x) (Set y) = Set (I.difference x y)
+
+-- | Infix operator for 'difference'.
+(\\) :: Ord a => Set a -> Set a -> Set a
+(\\) (Set x) (Set y) = Set (I.difference x y)
+
+-- | 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
+
+-- | Construct a set with a single element.
+singleton :: a -> Set a
+singleton = Set . I.singleton
+
+-- | The number of elements in the set.
+size :: Set a -> Int
+size (Set s) = I.size s
+
+-- | Strict monoidal fold over the elements in the set.
+foldMap' :: Monoid m
+  => (a -> m)
+  -> Set a
+  -> m
+foldMap' f (Set arr) = I.foldMap' f arr
+
diff --git a/src/Data/Set/Lifted/Internal.hs b/src/Data/Set/Lifted/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Set/Lifted/Internal.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Data.Set.Lifted.Internal
+  ( Set(..)
+  , toList
+  , fromList
+  , foldr
+  , foldl'
+  , foldr'
+  ) where
+
+import Prelude hiding (foldr)
+
+import Data.Primitive.UnliftedArray (PrimUnlifted(..))
+import Data.Functor.Classes (Eq1(liftEq),Show1(liftShowsPrec))
+import Data.Primitive (Array)
+import Data.Semigroup (Semigroup)
+import Text.Show (showListWith)
+
+import qualified Data.Foldable as F
+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 Array a }
+
+instance F.Foldable Set where
+  foldr = foldr
+  foldl' = foldl'
+  foldr' = foldr'
+
+instance PrimUnlifted (Set a) where
+  toArrayArray# (Set x) = toArrayArray# x
+  fromArrayArray# y = Set (fromArrayArray# y)
+
+instance 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 Ord a => Monoid (Set a) where
+  mempty = Set I.empty
+  mappend = (SG.<>)
+  mconcat xs = Set (I.concat (E.coerce xs))
+
+instance Eq a => Eq (Set a) where
+  Set x == Set y = I.equals x y
+
+instance Eq1 Set where
+  liftEq f a b = liftEq f (toList a) (toList b)
+
+instance Ord a => Ord (Set a) where
+  compare (Set x) (Set y) = I.compare x y
+
+instance 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 Show a => Show (Set a) where
+  showsPrec p (Set s) = I.showsPrec p s
+
+instance Show1 Set where
+  liftShowsPrec f _ p s = showParen (p > 10) $
+   showString "fromList " . showListWith (f 0) (toList s)
+
+-- | Convert a set to a list. The elements are given in ascending order.
+toList :: Set a -> [a]
+toList (Set s) = I.toList s
+
+-- | Convert a list to a set.
+fromList :: Ord a => [a] -> Set a
+fromList = Set . I.fromList
+
+-- | Right fold over the elements in the set. This is lazy in the accumulator.
+foldr :: 
+     (a -> b -> b)
+  -> b
+  -> Set a
+  -> b
+foldr f b0 (Set s) = I.foldr f b0 s
+
+-- | Strict left fold over the elements in the set.
+foldl' :: 
+     (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' :: 
+     (a -> b -> b)
+  -> b
+  -> Set a
+  -> b
+foldr' f b0 (Set s) = I.foldr' f b0 s
diff --git a/src/Data/Set/Unboxed.hs b/src/Data/Set/Unboxed.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Set/Unboxed.hs
@@ -0,0 +1,134 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# OPTIONS_GHC -Wall #-}
+module Data.Set.Unboxed
+  ( Set
+  , singleton
+  , member
+  , size
+  , difference
+  , (\\)
+    -- * List Conversion
+  , toList
+  , fromList
+    -- * Folds
+  , foldr
+  , foldl'
+  , foldr'
+  , foldMap'
+  ) where
+
+import Prelude hiding (foldr)
+import Data.Primitive.Types (Prim)
+import Data.Primitive.UnliftedArray (PrimUnlifted(..))
+import Data.Primitive.PrimArray (PrimArray)
+import Data.Semigroup (Semigroup)
+import qualified Data.Foldable as F
+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
+
+instance (Prim a, Show a) => Show (Set a) where
+  showsPrec p (Set s) = I.showsPrec p s
+
+-- | The difference of two sets.
+difference :: (Ord a, Prim a) => Set a -> Set a -> Set a
+difference (Set x) (Set y) = Set (I.difference x y)
+
+-- | Infix operator for 'difference'.
+(\\) :: (Ord a, Prim a) => Set a -> Set a -> Set a
+(\\) (Set x) (Set y) = Set (I.difference 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
+
+-- | 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
+
+-- | Right fold over the elements in the set. This is lazy in the accumulator.
+foldr :: Prim a
+  => (a -> b -> b)
+  -> b
+  -> Set a
+  -> b
+foldr f b0 (Set s) = I.foldr f b0 s
+
+-- | Strict left fold over the elements in the set.
+foldl' :: Prim 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' :: Prim 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' :: (Monoid m, Prim a)
+  => (a -> m)
+  -> Set a
+  -> m
+foldMap' f (Set arr) = I.foldMap' f arr
+
+
+
diff --git a/src/Data/Set/Unlifted.hs b/src/Data/Set/Unlifted.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Set/Unlifted.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# OPTIONS_GHC -O2 #-}
+module Data.Set.Unlifted
+  ( Set
+  , singleton
+  , member
+  , size
+  ) where
+
+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 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
+
+-- | Test for membership in the set.
+member :: (PrimUnlifted a, Ord a) => a -> Set a -> Bool
+member a (Set s) = I.member a s
+
+-- | Construct a set with a single element.
+singleton :: PrimUnlifted a => a -> Set a
+singleton = Set . I.singleton
+
+-- | The number of elements in the set.
+size :: PrimUnlifted a => Set a -> Int
+size (Set s) = I.size s
+
+
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,468 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+import Data.Primitive
+import Data.Primitive.UnliftedArray (PrimUnlifted)
+import Data.Word
+import Data.Proxy (Proxy(..))
+import Data.Int
+
+import Test.Tasty (defaultMain,testGroup,TestTree)
+import Test.QuickCheck (Arbitrary,Gen,(===),(==>))
+import Data.List.NonEmpty (NonEmpty((:|)))
+import Control.Monad (forM)
+import qualified Test.Tasty.QuickCheck as TQC
+import qualified Test.QuickCheck as QC
+import qualified Test.QuickCheck.Classes as QCC
+import qualified Data.Semigroup as SG
+import qualified Data.Map as M
+import qualified Data.Set as S
+import qualified Data.Foldable as F
+import qualified GHC.Exts as E
+import qualified Test.QuickCheck.Classes.IsList as QCCL
+
+import qualified Data.Set.Unboxed as SU
+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.Set.Lifted as DSL
+import qualified Data.Diet.Unbounded.Set.Lifted as DUSL
+import qualified Data.Map.Subset.Lifted as MSL
+
+main :: IO ()
+main = defaultMain $ testGroup "Data"
+  [ testGroup "Set"
+    [ testGroup "Unboxed"
+      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SU.Set Int16)))
+      , lawsToTest (QCC.ordLaws (Proxy :: Proxy (SU.Set Int16)))
+      , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (SU.Set Int16)))
+      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SU.Set Int16)))
+      , TQC.testProperty "member" (memberProp @Int16 E.fromList SU.member)
+      ]
+    , testGroup "Lifted"
+      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SL.Set Integer)))
+      , lawsToTest (QCC.ordLaws (Proxy :: Proxy (SL.Set Integer)))
+      , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (SL.Set Integer)))
+      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SL.Set Integer)))
+      , TQC.testProperty "member" (memberProp @Integer E.fromList SL.member)
+      , 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 "difference" differenceProp
+      ]
+    , testGroup "Unlifted"
+      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SUL.Set (PrimArray Int16))))
+      , lawsToTest (QCC.ordLaws (Proxy :: Proxy (SUL.Set (PrimArray Int16))))
+      , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (SUL.Set (PrimArray Int16))))
+      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SUL.Set (PrimArray Int16))))
+      , TQC.testProperty "member" (memberProp @(PrimArray Int16) E.fromList SUL.member)
+      ]
+    ]
+  , testGroup "Map"
+    [ testGroup "Unboxed"
+      [ testGroup "Unboxed"
+        [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (MUU.Map Word32 Int)))
+        , lawsToTest (QCC.ordLaws (Proxy :: Proxy (MUU.Map Word32 Int)))
+        , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (MUU.Map Word32 Word)))
+        , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (MUU.Map Word32 Int)))
+        , lawsToTest (QCC.isListLaws (Proxy :: Proxy (MUU.Map Word32 Int)))
+        , TQC.testProperty "lookup" (lookupProp @Word32 @Int E.fromList MUU.lookup)
+        , TQC.testProperty "foldlWithKey'" (mapFoldAgreement MUU.foldlWithKey' M.foldlWithKey)
+        , TQC.testProperty "foldrWithKey'" (mapFoldAgreement MUU.foldrWithKey' M.foldrWithKey)
+        , TQC.testProperty "foldMapWithKey'" (mapFoldMonoidAgreement MUU.foldMapWithKey' M.foldMapWithKey)
+        ]
+      ]
+    ]
+  , testGroup "Diet"
+    [ testGroup "Unbounded"
+      [ testGroup "Set"
+        [ testGroup "Lifted"
+          [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DUSL.Set Word8)))
+          , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DUSL.Set Word8)))
+          ]
+        ]
+      ]
+    , testGroup "Set"
+      [ testGroup "Lifted"
+        [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DSL.Set Word16)))
+        , lawsToTest (QCC.ordLaws (Proxy :: Proxy (DSL.Set Word16)))
+        , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DSL.Set Word16)))
+        , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DSL.Set Word16)))
+        , TQC.testProperty "member" (dietMemberProp @Word8 E.fromList DSL.member)
+        , TQC.testProperty "difference" dietSetDifferenceProp
+        , TQC.testProperty "aboveInclusive" dietSetAboveProp
+        , testGroup "belowInclusive"
+          [ TQC.testProperty "basic" dietSetBelowProp
+          , TQC.testProperty "lowest" dietSetBelowLowestProp
+          , TQC.testProperty "highest" dietSetBelowHighestProp
+          ]
+        , testGroup "betweenInclusive"
+          [ TQC.testProperty "basic" dietSetBetweenProp
+          , TQC.testProperty "border" dietSetBetweenBorderProp
+          , TQC.testProperty "inside" dietSetBetweenBorderNearProp
+          ]
+        ]
+      ]
+    , testGroup "Map"
+      [ testGroup "Subset"
+        [ testGroup "Lifted"
+          [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (MSL.Map Integer (SG.Sum Integer))))
+          , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (MSL.Map Integer (SG.First Integer))))
+          , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (MSL.Map Integer (SG.Sum Integer))))
+          , TQC.testProperty "lookup" subsetMapLookupProp
+          ]
+        ]
+      , testGroup "Lifted"
+        [ testGroup "Lifted"
+          [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DMLL.Map Word8 Integer)))
+          , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (DMLL.Map Word8 Word)))
+          , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DMLL.Map Word8 Int)))
+          , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DMLL.Map Word8 Integer)))
+          , TQC.testProperty "lookup" (dietLookupPropA @Word8 @Int E.fromList DMLL.lookup)
+          , TQC.testProperty "doubleton" dietDoubletonProp
+          , TQC.testProperty "valid" dietValidProp
+          ]
+        ]
+      , testGroup "Unboxed"
+        [ testGroup "Lifted"
+          [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (DMUL.Map Word8 Integer)))
+          , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (DMUL.Map Word8 Word)))
+          , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DMUL.Map Word8 Int)))
+          , lawsToTest (QCC.isListLaws (Proxy :: Proxy (DMUL.Map Word8 Integer)))
+          , TQC.testProperty "lookup" (dietLookupPropA @Word32 @Int E.fromList DMUL.lookup)
+          ]
+        ]
+      ]
+    ]
+  ]
+
+int16 :: Proxy Int16
+int16 = Proxy
+
+int32 :: Proxy Int32
+int32 = Proxy
+
+subsetMapLookupProp :: QC.Property
+subsetMapLookupProp = QC.property $ \(xs :: MSL.Map Integer Integer) ->
+  let xs' = MSL.toList xs
+   in all (\(k,v) -> MSL.lookup k xs == Just v) xs' === True
+
+dietSetDifferenceProp :: QC.Property
+dietSetDifferenceProp = QC.property $ \(xs :: DSL.Set Word8) (ys :: DSL.Set Word8) ->
+  let xs' = dietSetToSet xs
+      ys' = dietSetToSet ys
+   in DSL.difference xs ys === DSL.fromList (map (\x -> (x,x)) (S.toList (S.difference xs' ys')))
+
+dietSetAboveProp :: QC.Property
+dietSetAboveProp = QC.property $ \(y :: Word8) (ys :: DSL.Set Word8) ->
+  let ys' = dietSetToSet ys
+      (_,isMember,c) = S.splitMember y ys'
+      r = if isMember then S.insert y c else c
+   in DSL.aboveInclusive y ys === DSL.fromList (map (\x -> (x,x)) (S.toList r))
+
+dietSetBelowProp :: QC.Property
+dietSetBelowProp = QC.property $ \(y :: Word8) (ys :: DSL.Set Word8) ->
+  let ys' = dietSetToSet ys
+      (c,isMember,_) = S.splitMember y ys'
+      r = if isMember then S.insert y c else c
+   in DSL.belowInclusive y ys === DSL.fromList (map (\x -> (x,x)) (S.toList r))
+
+dietSetBelowLowestProp :: QC.Property
+dietSetBelowLowestProp = QC.property $ \(ys :: DSL.Set Word8) ->
+  let ys' = dietSetToSet ys
+   in case S.lookupMin ys' of
+        Nothing -> QC.property QC.Discard
+        Just y -> 
+          let (c,isMember,_) = S.splitMember y ys'
+              r = if isMember then S.insert y c else c
+           in QC.property (DSL.belowInclusive y ys === DSL.fromList (map (\x -> (x,x)) (S.toList r)))
+
+dietSetBelowHighestProp :: QC.Property
+dietSetBelowHighestProp = QC.property $ \(ys :: DSL.Set Word8) ->
+  let ys' = dietSetToSet ys
+   in case S.lookupMax ys' of
+        Nothing -> QC.property QC.Discard
+        Just y -> 
+          let (c,isMember,_) = S.splitMember y ys'
+              r = if isMember then S.insert y c else c
+           in QC.property (DSL.belowInclusive y ys === DSL.fromList (map (\x -> (x,x)) (S.toList r)))
+
+dietSetBetweenProp :: QC.Property
+dietSetBetweenProp = QC.property $ \(x :: Word8) (y :: Word8) (ys :: DSL.Set Word8) ->
+  (x <= y)
+  ==> 
+  ( let ys' = dietSetToSet ys
+        r = S.filter (\e -> e >= x && e <= y) ys'
+     in DSL.betweenInclusive x y ys === DSL.fromList (map (\z -> (z,z)) (S.toList r))
+  )
+
+dietSetBetweenBorderProp :: QC.Property
+dietSetBetweenBorderProp = QC.property $ \(ys :: DSL.Set Word8) ->
+  let ys' = dietSetToSet ys
+   in case S.lookupMax ys' of
+        Nothing -> QC.property QC.Discard
+        Just hi -> case S.lookupMin ys' of
+          Nothing -> QC.property QC.Discard
+          Just lo -> 
+            let r = S.filter (\e -> e >= lo && e <= hi) ys'
+             in DSL.betweenInclusive lo hi ys === DSL.fromList (map (\z -> (z,z)) (S.toList r))
+
+dietSetBetweenBorderNearProp :: QC.Property
+dietSetBetweenBorderNearProp = QC.property $ \(ys :: DSL.Set Word8) ->
+  let ys' = dietSetToSet ys
+   in ( S.size ys' > 1
+        ==>
+        ( let hi = pred (S.findMax ys')
+              lo = succ (S.findMin ys')
+              r = S.filter (\e -> e >= lo && e <= hi) ys'
+           in DSL.betweenInclusive lo hi ys === DSL.fromList (map (\z -> (z,z)) (S.toList r))
+        )
+      )
+
+-- This enumerates all of the element contained by all ranges
+-- 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)
+  mempty
+
+differenceProp :: QC.Property
+differenceProp = 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.difference xs' ys') === S.toList (S.difference xs ys)
+
+mapFoldMonoidAgreement ::
+     ((Int -> Int -> [Int]) -> MUU.Map Int Int -> [Int])
+  -> ((Int -> Int -> [Int]) -> M.Map Int Int -> [Int])
+  -> QC.Property
+mapFoldMonoidAgreement foldPrim foldContainer = QC.property $ \(xs :: [(Int,Int)]) ->
+  let p = E.fromList xs
+      c = E.fromList xs
+      func x y = [x + y]
+   in foldPrim func p === foldContainer func c
+
+mapFoldAgreement ::
+     ((Int -> Int -> Int -> Int) -> Int -> MUU.Map Int Int -> Int)
+  -> ((Int -> Int -> Int -> Int) -> Int -> M.Map Int Int -> Int)
+  -> QC.Property
+mapFoldAgreement foldPrim foldContainer = QC.property $ \(xs :: [(Int,Int)]) ->
+  let p = E.fromList xs
+      c = E.fromList xs
+      -- we just need the function to be non-commutative
+      func x y z = y - (2 * x) - (3 * z)
+   in foldPrim func 42 p === foldContainer func 42 c
+
+memberProp :: forall a t. (Arbitrary a, Show a) => ([a] -> t a) -> (a -> t a -> Bool) -> QC.Property
+memberProp containerFromList containerMember = QC.property $ \(xs :: [a]) ->
+  let c = containerFromList xs
+   in all (\x -> containerMember x c) xs === True
+
+lookupProp :: forall k v t. (Arbitrary k, Show k, Ord k, Arbitrary v, Show v, Eq v) => ([(k,v)] -> t k v) -> (k -> t k v -> Maybe v) -> QC.Property
+lookupProp containerFromList containerLookup = QC.property $ \(xs :: [(k,v)]) ->
+  let ys = M.fromList xs
+      c = containerFromList xs
+   in all (\(x,_) -> containerLookup x c == M.lookup x ys) xs === True
+
+dietMemberProp :: forall a t. (Arbitrary a, Show a, Ord a, Arbitrary a, Show (t a)) => ([(a,a)] -> t a) -> (a -> t a -> Bool) -> QC.Property
+dietMemberProp containerFromList containerLookup = QC.property $ \(xs :: [a]) ->
+  let c = containerFromList (map (\a -> (a,a)) xs)
+   in QC.counterexample ("original list: " ++ show xs ++ "; diet set: " ++ show c) (all (\x -> containerLookup x c == True) xs === True)
+
+dietLookupPropA :: forall k v t. (Arbitrary k, Show k, Ord k, Arbitrary v, Show v, Eq v, Show (t k v)) => ([(k,k,v)] -> t k v) -> (k -> t k v -> Maybe v) -> QC.Property
+dietLookupPropA containerFromList containerLookup = QC.property $ \(xs :: [(k,v)]) ->
+  let ys = M.fromList xs
+      c = containerFromList (map (\(k,v) -> (k,k,v)) xs)
+   in QC.counterexample ("original list: " ++ show xs ++ "; diet map: " ++ show c) (all (\(x,_) -> containerLookup x c == M.lookup x ys) xs === True)
+
+dietDoubletonProp :: QC.Property
+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))
+
+dietValidProp :: QC.Property
+dietValidProp = QC.property $ \(xs :: DMLL.Map Word8 Int) ->
+  True === validDietTriples (E.toList xs)
+
+simpleDoubletonToList :: (Ord k, Enum k, Semigroup v, Eq v) => k -> k -> v -> k -> k -> v -> [(k,k,v)]
+simpleDoubletonToList key1A key2A valA key1B key2B valB =
+  let loA = min key1A key2A
+      hiA = max key1A key2A
+      loB = min key1B key2B
+      hiB = max key1B key2B
+   in deduplicate $ case compare loA loB of
+        LT -> case compare hiA loB of
+          LT -> [(loA,hiA,valA),(loB,hiB,valB)]
+          EQ -> case compare hiA hiB of
+            LT -> [(loA,pred loB,valA),(loB,hiA,valA SG.<> valB),(succ hiA,hiB,valB)]
+            EQ -> [(loA,pred loB,valA),(loB,hiA,valA SG.<> valB)]
+            GT -> error "simpleDoubletonToList: invariant violated"
+          GT -> case compare hiA hiB of
+            LT -> [(loA,pred loB,valA),(loB,hiA,valA SG.<> valB),(succ hiA,hiB,valB)]
+            EQ -> [(loA,pred loB,valA),(loB,hiA,valA SG.<> valB)]
+            GT -> [(loA,pred loB,valA),(loB,hiB,valA SG.<> valB),(succ hiB,hiA,valA)]
+        EQ -> case compare hiA hiB of
+          LT -> [(loA,hiA,valA SG.<> valB),(succ hiA, hiB, valB)]
+          GT -> [(loB,hiB,valA SG.<> valB),(succ hiB, hiA, valA)]
+          EQ -> [(loA,hiA,valA SG.<> valB)]
+        GT -> case compare hiB loA of
+          LT -> [(loB,hiB,valB),(loA,hiA,valA)]
+          EQ -> case compare hiB hiA of
+            LT -> [(loB,pred loA,valB),(loA,hiB,valA SG.<> valB),(succ hiB,hiA,valA)]
+            EQ -> [(loB,pred loA,valB),(loA,hiB,valA SG.<> valB)]
+            GT -> error "simpleDoubletonToList: invariant violated"
+          GT -> case compare hiB hiA of
+            LT -> [(loB,pred loA,valB),(loA,hiB,valA SG.<> valB),(succ hiB,hiA,valA)]
+            EQ -> [(loB,pred loA,valB),(loA,hiB,valA SG.<> valB)]
+            GT -> [(loB,pred loA,valB),(loA,hiA,valA SG.<> valB),(succ hiA,hiB,valB)]
+
+validDietTriples :: (Enum k,Eq k,Eq v) => [(k,k,v)] -> Bool
+validDietTriples xs = deduplicate xs == xs
+
+deduplicate :: (Enum k,Eq k, Eq v) => [(k,k,v)] -> [(k,k,v)]
+deduplicate [] = []
+deduplicate (x : xs) = F.toList (deduplicateNonEmpty (x :| xs))
+
+deduplicateNonEmpty :: (Enum k, Eq k, Eq v) => NonEmpty (k,k,v) -> NonEmpty (k,k,v)
+deduplicateNonEmpty ((lo,hi,v) :| xs) = case xs of
+  y : ys -> case deduplicateNonEmpty (y :| ys) of
+    (lo',hi',v') :| xs' -> if v == v' && pred lo' == hi
+      then (lo,hi',v) :| xs'
+      else (lo,hi,v) :| ((lo',hi',v') : xs')
+  [] -> (lo,hi,v) :| []
+
+lawsToTest :: QCC.Laws -> TestTree
+lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs)
+
+instance (Arbitrary a, Prim a) => Arbitrary (PrimArray a) where
+  arbitrary = fmap E.fromList QC.arbitrary
+
+instance (Arbitrary a, Prim a, Ord a) => Arbitrary (SU.Set a) where
+  arbitrary = fmap E.fromList QC.arbitrary
+
+instance (Arbitrary a, PrimUnlifted a, Ord a) => Arbitrary (SUL.Set a) where
+  arbitrary = fmap E.fromList QC.arbitrary
+
+instance (Arbitrary a, Ord a) => Arbitrary (SL.Set a) where
+  arbitrary = fmap E.fromList QC.arbitrary
+
+instance (Arbitrary k, Prim k, Ord k, Arbitrary v, Prim v) => Arbitrary (MUU.Map k v) where
+  arbitrary = fmap E.fromList QC.arbitrary
+
+instance (Arbitrary k, Ord k, Enum k, Bounded k, Arbitrary v, Semigroup v, Eq v) => Arbitrary (DMLL.Map k v) where
+  arbitrary = DMLL.fromListAppend <$> QC.vectorOf 10 arbitraryOrderedPairValue
+  shrink x = map E.fromList (QC.shrink (E.toList x))
+    
+instance (Arbitrary k, Ord k, Arbitrary v, Eq v, Semigroup v) => Arbitrary (MSL.Map k v) where
+  arbitrary = do
+    len <- QC.choose (0,4)
+    xs <- QC.vectorOf len $ do
+      n <- QC.choose (0,3)
+      ys <- QC.vector n
+      v <- QC.arbitrary
+      return (SL.fromList ys, v)
+    return (MSL.fromList xs)
+  shrink x =
+    [ MSL.fromList (drop 1 y)
+    ]
+    where y = MSL.toList x
+
+instance (Arbitrary k, Prim k, Ord k, Enum k, Bounded k, Arbitrary v, Semigroup v, Eq v) => Arbitrary (DMUL.Map k v) where
+  arbitrary = do
+    sz <- QC.choose (0,10)
+    k <- QC.arbitrary
+    xs <- increasingOrderedPairsHelper sz k
+    ys <- forM xs $ \(lo,hi) -> do
+      v <- QC.arbitrary
+      return (lo,hi,v)
+    return (DMUL.fromListAppend ys)
+  shrink x = map E.fromList (QC.shrink (E.toList x))
+    
+instance (Arbitrary a, Ord a, Enum a, Bounded a) => Arbitrary (DSL.Set a) where
+  arbitrary = DSL.fromList <$> QC.vectorOf 7 arbitraryOrderedPair
+  shrink x = map E.fromList (QC.shrink (E.toList x))
+
+instance (Arbitrary a, Ord a, Enum a, Bounded a) => Arbitrary (DUSL.Set a) where
+  arbitrary = do
+    sz <- QC.choose (0,7)
+    k <- QC.arbitrary
+    foldMap (\(lo,hi) -> DUSL.singleton (Just lo) (Just hi)) <$> increasingOrderedPairsHelper sz k
+    
+increasingOrderedPairsHelper :: (Ord k, Enum k, Bounded k) => Int -> k -> Gen [(k,k)]
+increasingOrderedPairsHelper n k = if n > 0
+  then case atLeastTwoGreaterThan k of
+    Nothing -> return []
+    Just vals -> do
+      lo <- QC.elements vals
+      hi <- QC.elements (equalToOrGreaterThan lo)
+      xs <- increasingOrderedPairsHelper (n - 1) hi
+      return ((lo,hi) : xs)
+  else return []
+
+equalToOrGreaterThan :: (Ord a, Bounded a, Enum a) => a -> [a]
+equalToOrGreaterThan a0 =
+  let a1 = if a0 < maxBound then succ a0 else a0
+      a2 = if a1 < maxBound then succ a1 else a1
+      a3 = if a2 < maxBound then succ a2 else a2
+   in [a0,a1,a2,a3]
+
+atLeastTwoGreaterThan :: (Enum a, Bounded a, Ord a) => a -> Maybe [a]
+atLeastTwoGreaterThan a0 = do
+  if a0 < maxBound
+    then
+      let a1 = succ a0
+       in if a1 < maxBound
+            then
+              let a2 = succ a1
+                  a3 = if a2 < maxBound then succ a2 else a2
+                  a4 = if a3 < maxBound then succ a3 else a3
+               in Just [a2,a3,a4]
+            else Nothing
+    else Nothing
+
+arbitraryOrderedPair :: (Ord k, Enum k, Bounded k, Arbitrary k) => Gen (k,k)
+arbitraryOrderedPair = do
+  a0 <- QC.arbitrary
+  let a1 = if a0 < maxBound then succ a0 else a0
+      a2 = if a1 < maxBound then succ a1 else a1
+      a3 = if a2 < maxBound then succ a2 else a2
+  a' <- QC.elements [a0,a1,a2,a3]
+  return (a0,a')
+
+arbitraryOrderedPairValue :: (Ord k, Enum k, Bounded k, Arbitrary k, Arbitrary v) => Gen (k,k,v)
+arbitraryOrderedPairValue = do
+  (lo,hi) <- arbitraryOrderedPair
+  v <- QC.arbitrary
+  return (lo,hi,v)
+
+instance SG.Semigroup Word where
+  w <> _ = w
+
+instance SG.Semigroup Int where
+  (<>) = (+)
+
+instance Monoid Int where
+  mempty = 0
+  mappend = (SG.<>)
+  
+instance SG.Semigroup Integer where
+  (<>) = (+)
+
+instance Monoid Integer where
+  mempty = 0
+  mappend = (SG.<>)
+
+deriving instance Arbitrary a => Arbitrary (SG.First a)
+