diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,1 +1,13 @@
 # disjoint-containers
+
+`disjoint-containers` has two new data structures: `DisjointSet` and `DisjointMap`
+
+`DisjointSet`:
+
+Disjoint-sets are a set of elements 
+with equivalence relations defined between elements, i.e. 
+two elements may be members of the same equivalence set.
+
+`DisjointMap`:
+
+Maps with disjoint sets as the key.
diff --git a/disjoint-containers.cabal b/disjoint-containers.cabal
--- a/disjoint-containers.cabal
+++ b/disjoint-containers.cabal
@@ -1,5 +1,5 @@
 name: disjoint-containers
-version: 0.2.3
+version: 0.2.4
 synopsis: Disjoint containers
 description: Disjoint containers
 homepage: https://github.com/andrewthad/disjoint-containers#readme
@@ -19,10 +19,10 @@
     Data.DisjointSet
     Data.DisjointMap
   build-depends:
-      base >= 4.7 && < 5
+      base >= 4.11.1 && < 5
     , transformers >= 0.5 && < 0.6
-    , containers >= 0.5 && < 0.6
-    , aeson >= 0.11 && < 1.3
+    , containers >= 0.5 && < 0.7
+    , aeson >= 0.11 && < 1.5
   default-language: Haskell2010
 
 test-suite test
@@ -33,8 +33,12 @@
       base
     , disjoint-containers
     , containers
-    , QuickCheck
-    , quickcheck-classes >= 0.1 && < 0.3
+    , QuickCheck >= 2.11
+    , quickcheck-classes >= 0.4.14.1
+    , tasty
+    , tasty-quickcheck
+    , enum-types
+    , quickcheck-enum-instances
     , aeson
     , semigroups
   default-language: Haskell2010
diff --git a/src/Data/DisjointMap.hs b/src/Data/DisjointMap.hs
--- a/src/Data/DisjointMap.hs
+++ b/src/Data/DisjointMap.hs
@@ -29,6 +29,7 @@
   , singletons
   , insert
   , union
+  , unionWeakly
     -- * Query
   , lookup
   , lookup'
@@ -36,6 +37,8 @@
   , representative'
     -- * Conversion
   , toLists
+  , toSets
+  , fromSets
   , pretty
   , prettyList
   , foldlWithKeys'
@@ -60,6 +63,7 @@
 import qualified Data.Map.Strict as M
 import qualified Data.Set as S
 import qualified GHC.OldList as L
+import qualified Data.Foldable as F
 
 -- | A map having disjoints sets of @k@ as keys and
 --   @v@ as values.
@@ -74,10 +78,11 @@
   deriving (Functor,Foldable,Traversable)
 
 instance (Ord k, Monoid v) => Monoid (DisjointMap k v) where
-  mappend = append
   mempty = empty
 
-instance (Ord k, Monoid v) => SG.Semigroup (DisjointMap k v) where
+-- | This only satisfies the associativity law when the 'Monoid'
+--   instance for @v@ is commutative.
+instance (Ord k, Semigroup v) => SG.Semigroup (DisjointMap k v) where
   (<>) = append
 
 -- technically, it should be possible to weaken the Ord constraint on v to
@@ -151,7 +156,7 @@
 
 {-|
 Create an equivalence relation between x and y. If either x or y
-are not already is the disjoint set, they are first created
+are not already in the disjoint set, they are first created
 as singletons with a value that is 'mempty'.
 -}
 union :: (Ord k, Monoid v) => k -> k -> DisjointMap k v -> DisjointMap k v
@@ -174,6 +179,50 @@
     EQ -> let p' = M.insert repx repy p
               r' = M.delete repx $! M.insert repy (Ranked (ranky + 1) keys val) r
           in  DisjointMap p' r'
+{-|
+Create an equivalence relation between x and y. If both x and y
+are missing, do not create either of them. Otherwise, they will
+both exist in the map.
+-}
+unionWeakly :: (Ord k, Semigroup v) => k -> k -> DisjointMap k v -> DisjointMap k v
+unionWeakly !x !y set = flip execState set $ runMaybeT $ do
+  mx <- lift $ state $ lookupCompress x
+  my <- lift $ state $ lookupCompress y
+  case mx of
+    Nothing -> case my of
+      Nothing -> pure ()
+      Just repy -> do
+        DisjointMap p r <- lift get
+        lift $ put $
+          let p' = M.insert x repy p
+              Ranked ranky keys val = fromMaybe (error "Data.DisjointMap.unionWeakly") (M.lookup repy r)
+              r' = M.insert repy (Ranked ranky (S.insert x keys) val) r
+           in DisjointMap p' r'
+    Just repx -> case my of
+      Nothing -> do
+        DisjointMap p r <- lift get
+        lift $ put $
+          let p' = M.insert y repx p
+              Ranked rankx keys val = fromMaybe (error "Data.DisjointMap.unionWeakly") (M.lookup repx r)
+              r' = M.insert repx (Ranked rankx (S.insert y keys) val) r
+           in DisjointMap p' r'
+      Just repy -> do
+        guard $ repx /= repy
+        DisjointMap p r <- lift get
+        let Ranked rankx keysx valx = r M.! repx
+        let Ranked ranky keysy valy = r M.! repy
+        let val = valx <> valy
+        let keys = mappend keysx keysy
+        lift $ put $! case compare rankx ranky of
+          LT -> let p' = M.insert repx repy p
+                    r' = M.delete repx $! M.insert repy (Ranked ranky keys val) r
+                in  DisjointMap p' r'
+          GT -> let p' = M.insert repy repx p
+                    r' = M.delete repy $! M.insert repx (Ranked rankx keys val) r
+                in  DisjointMap p' r'
+          EQ -> let p' = M.insert repx repy p
+                    r' = M.delete repx $! M.insert repy (Ranked (ranky + 1) keys val) r
+                in  DisjointMap p' r'
 
 {-|
 Find the set representative for this input. This function
@@ -184,14 +233,18 @@
 
 {-| Insert a key-value pair into the disjoint map. If the key
     is is already present in another set, combine the value
-    monoidally with the value belonging to it.
+    monoidally with the value belonging to it. The new value
+    is on the left side of the append, and the old value is
+    on the right.
     Otherwise, this creates a singleton set as a new key and
     associates it with the value.
 -}
-insert :: (Ord k, Monoid v) => k -> v -> DisjointMap k v -> DisjointMap k v
+insert :: (Ord k, Semigroup v) => k -> v -> DisjointMap k v -> DisjointMap k v
 insert !x = insertInternal x (S.singleton x)
 
-insertInternal :: (Ord k, Monoid v) => k -> Set k -> v -> DisjointMap k v -> DisjointMap k v
+-- Precondition: Nothing in ks already exists in the disjoint map.
+-- This function should only be used by insert.
+insertInternal :: (Ord k, Semigroup v) => k -> Set k -> v -> DisjointMap k v -> DisjointMap k v
 insertInternal !x !ks !v set@(DisjointMap p r) =
   let (l, p') = M.insertLookupWithKey (\_ _ old -> old) x x p
    in case l of
@@ -199,7 +252,7 @@
           let (m,DisjointMap p2 r') = representative' x set
            in case m of
                 Nothing -> error "DisjointMap insert: invariant violated"
-                Just root -> DisjointMap p2 (M.adjust (\(Ranked rank oldKs vOld) -> Ranked rank (mappend oldKs ks) (mappend v vOld)) root r')
+                Just root -> DisjointMap p2 (M.adjust (\(Ranked rank oldKs vOld) -> Ranked rank (mappend oldKs ks) (v <> vOld)) root r')
         Nothing ->
           let r' = M.insert x (Ranked 0 ks v) r
           in  DisjointMap p' r'
@@ -216,18 +269,27 @@
 empty :: DisjointMap k v
 empty = DisjointMap M.empty M.empty
 
-append :: (Ord k, Monoid v) => DisjointMap k v -> DisjointMap k v -> DisjointMap k v
+append :: (Ord k, Semigroup v) => DisjointMap k v -> DisjointMap k v -> DisjointMap k v
 append s1@(DisjointMap m1 r1) s2@(DisjointMap m2 r2) = if M.size m1 > M.size m2
-  then appendParents r2 s1 m2
-  else appendParents r1 s2 m1
+  then appendPhase2 (appendPhase1 r2 s1 m2) m2
+  else appendPhase2 (appendPhase1 r1 s2 m1) m1
 
-appendParents :: (Ord k, Monoid v) => Map k (Ranked k v) -> DisjointMap k v -> Map k k -> DisjointMap k v
-appendParents !ranks = M.foldlWithKey' $ \ds x y -> if x == y
+appendPhase1 :: (Ord k, Semigroup v)
+  => Map k (Ranked k v)
+  -> DisjointMap k v
+  -> Map k k
+  -> DisjointMap k v
+appendPhase1 !ranks = M.foldlWithKey' $ \ds x y -> if x == y
   then case M.lookup x ranks of
-    Nothing -> error "DisjointMap appendParents: invariant violated"
-    Just (Ranked _ ks v) -> insertInternal x ks v ds
-  else union x y ds
+    Nothing -> error "Data.DisjointMap.appendParents: invariant violated"
+    Just (Ranked _ ks v) -> F.foldl' (\dm k -> unionWeakly k x dm) (insert x v ds) ks
+  else ds
 
+appendPhase2 :: (Ord k, Semigroup v) => DisjointMap k v -> Map k k -> DisjointMap k v
+appendPhase2 = M.foldlWithKey' $ \ds x y -> if x == y
+  then ds
+  else unionWeakly x y ds
+
 {-| Create a disjoint map with one key. Everything in the
     'Set' argument is consider part of the same equivalence
     class.
@@ -263,15 +325,25 @@
 lookupCompressAdd !x set =
   case find x set of
     Nothing -> (x, insert x mempty set)
-    Just rep -> let set' = compress rep x set
-                in  set' `seq` (rep, set')
+    Just rep -> let !set' = compress rep x set
+                 in (rep, set')
 
+lookupCompress :: Ord k => k -> DisjointMap k v -> (Maybe k, DisjointMap k v)
+lookupCompress !x set =
+  case find x set of
+    Nothing -> (Nothing, set)
+    Just rep ->
+      let !set' = compress rep x set
+       in (Just rep, set')
+
 find :: Ord k => k -> DisjointMap k v -> Maybe k
-find !x (DisjointMap p _) =
-  do x' <- M.lookup x p
-     return $! if x == x' then x' else find' x'
-  where find' y = let y' = p M.! y
-                  in  if y == y' then y' else find' y'
+find !x (DisjointMap p _) = do
+  x' <- M.lookup x p
+  return $! if x == x' then x' else find' x'
+  where
+  find' y =
+    let y' = p M.! y
+     in if y == y' then y' else find' y'
 
 {-| Find the value associated with the set containing
     the provided key. If the key is not found, use 'mempty'.
@@ -283,19 +355,21 @@
     the provided key.
 -}
 lookup' :: Ord k => k -> DisjointMap k v -> Maybe v
-lookup' !x (DisjointMap p r) =
-  do x' <- M.lookup x p
-     if x == x'
-       then case M.lookup x r of
-         Nothing -> Nothing
-         Just (Ranked _ _ v) -> Just v
-       else find' x'
-  where find' y = let y' = p M.! y
-                   in if y == y'
-                        then case M.lookup y r of
-                          Nothing -> Nothing
-                          Just (Ranked _ _ v) -> Just v
-                        else find' y'
+lookup' !x (DisjointMap p r) = do
+  x' <- M.lookup x p
+  if x == x'
+    then case M.lookup x r of
+      Nothing -> Nothing
+      Just (Ranked _ _ v) -> Just v
+    else find' x'
+  where
+  find' y =
+    let y' = p M.! y
+     in if y == y'
+          then case M.lookup y r of
+            Nothing -> Nothing
+            Just (Ranked _ _ v) -> Just v
+          else find' y'
 
 -- TODO: make this smarter about recreating the parents Map.
 -- Currently, it will recreate it more often than needed.
@@ -305,9 +379,10 @@
   helper !x set@(DisjointMap p r)
     | x == rep  = set
     | otherwise = helper x' set'
-    where x'    = p M.! x
-          set'  = let p' = M.insert x rep p
-                  in  p' `seq` DisjointMap p' r
+    where
+    x' = p M.! x
+    set' = let !p' = M.insert x rep p
+            in DisjointMap p' r
 
 {- $tutorial
 
diff --git a/test/Spec.hs b/test/Spec.hs
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -2,39 +2,91 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
-import Test.QuickCheck
-import Data.Word
-import Data.Monoid
-import Data.DisjointSet (DisjointSet)
+import Data.Aeson (ToJSON,FromJSON)
+import Data.Bifunctor (first)
 import Data.DisjointMap (DisjointMap)
-import Data.Set (Set)
+import Data.DisjointSet (DisjointSet)
+import Data.Enum.Types (C,E,G,H)
+import Test.QuickCheck.Instances.Enum ()
 import Data.Foldable (toList)
-import Test.QuickCheck.Classes (jsonProps)
+import Data.Maybe (mapMaybe)
+import Data.Monoid
 import Data.Proxy (Proxy(..))
-import Data.Aeson (ToJSON,FromJSON)
+import Data.Set (Set)
+import Data.Word
+import Test.QuickCheck
+import Test.QuickCheck.Classes (jsonLaws,Laws(..))
+import Test.Tasty (TestTree,defaultMain,testGroup)
+
+import qualified Data.DisjointMap as DM
+import qualified Data.DisjointSet as DS
 import qualified Data.Foldable as F
 import qualified Data.Set as S
-import qualified Data.DisjointSet as DS
-import qualified Data.DisjointMap as DM
 import qualified GHC.OldList as L
+import qualified Test.QuickCheck.Classes as QCC
+import qualified Test.Tasty.QuickCheck as TQC
 
 main :: IO ()
-main = do
-  putStrLn "\nBeginning QuickCheck Tests"
-  quickCheck propUnionAll
-  quickCheck propUnionAppend
-  quickCheck propSingletons
-  quickCheck propEquivalances
-  quickCheck propMapUnionAppend
-  putStrLn "* Disjoint Set JSON"
-  F.forM_ (jsonProps (Proxy :: Proxy (DisjointSet Word8))) $ \(name,p) -> do
-    putStrLn name
-    quickCheck p
-  putStrLn "* Disjoint Map JSON"
-  F.forM_ (jsonProps (Proxy :: Proxy (DisjointMap Word8 WrapWord8))) $ \(name,p) -> do
-    putStrLn name
-    quickCheck p
+main = defaultMain tests
 
+tests :: TestTree
+tests = testGroup "Data"
+  [ testGroup "DisjointSet"
+    [ testGroup "union"
+      [ TQC.testProperty "all" propUnionAll
+      , TQC.testProperty "append" propUnionAll
+      ]
+    , TQC.testProperty "singletons" propSingletons
+    , TQC.testProperty "equivalences" propEquivalances
+    , lawsToTest (QCC.jsonLaws (Proxy :: Proxy (DisjointSet Word8)))
+    , lawsToTest (QCC.jsonLaws (Proxy :: Proxy (DisjointSet Word8)))
+    , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (DisjointSet Integer)))
+    , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DisjointSet Integer)))
+    ]
+  , testGroup "DisjointMap"
+    [ testGroup "union"
+      [ TQC.testProperty "append" propMapUnionAppend
+      , TQC.testProperty "order" propMapUnionOrder
+      , TQC.testProperty "extra" propMapInsertUnionOrder
+      ]
+    , TQC.testProperty "insert" propMapInsertOrder
+    , lawsToTest (QCC.jsonLaws (Proxy :: Proxy (DisjointMap Word8 WrapWord8)))
+    , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (DisjointMap Word8 G)))
+    , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DisjointMap Word8 G)))
+    ]
+  ]
+
+lawsToTest :: QCC.Laws -> TestTree
+lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs)
+
+propMapUnionOrder :: C -> [Integer] -> C -> [Integer] -> Property
+propMapUnionOrder x xs y ys =
+  (x /= y)
+  ==>
+  DM.lookup x (DM.union x y (DM.singleton x xs <> DM.singleton y ys))
+  ===
+  (xs ++ ys)
+
+propMapInsertOrder :: C -> C -> [Integer] -> [Integer] -> [Integer] -> Property
+propMapInsertOrder k j xs ys zs =
+  (k /= j)
+  ==> 
+  DM.lookup k (DM.insert k xs $ DM.insert j ys $ DM.insert k zs $ mempty)
+  ===
+  (xs ++ zs)
+
+propMapInsertUnionOrder :: E -> E -> E -> [Integer] -> [Integer] -> [Integer] -> Property
+propMapInsertUnionOrder a b c xs ys zs =
+  (a /= b)
+  ==> 
+  (b /= c)
+  ==> 
+  (c /= a)
+  ==> 
+  DM.lookup a (DM.union a c (DM.insert a xs $ DM.insert b ys $ DM.insert c zs $ mempty))
+  ===
+  (xs ++ zs)
+
 propUnionAll :: [Word] -> Bool
 propUnionAll xs =
   let pairs = zip xs (drop 1 xs)
@@ -52,13 +104,13 @@
       r2 = unionPairs xs1 <> unionPairs xs2
    in r1 == r2
 
-propMapUnionAppend :: [(Word,Word)] -> [(Word,Sum Word)] -> Bool
+propMapUnionAppend :: [(Word8,Word8)] -> [(Word8,G)] -> Property
 propMapUnionAppend xs ys = 
   let r1 = unionMapPairs xs <> mapFromPairs ys
       (xs1,xs2) = splitList xs
       (ys1,ys2) = splitList ys
       r2 = unionMapPairs xs1 <> mapFromPairs ys1 <> unionMapPairs xs2 <> mapFromPairs ys2
-   in r1 == r2
+   in r1 === r2
 
 propSingletons :: [Set Word] -> Bool
 propSingletons xs = foldMap unionFoldable xs == foldMap DS.singletons xs
@@ -111,16 +163,28 @@
 
 instance (Arbitrary k, Ord k, Monoid v, Arbitrary v) => Arbitrary (DisjointMap k v) where
   arbitrary = do
-    xs <- arbitrary
-    ys <- arbitrary
+    SmallList xs <- arbitrary
+    SmallList ys <- arbitrary
     let s1 = foldMap (\(k,v) -> DM.singleton k v) (xs :: [(k,v)])
         s2 = foldMap (\(k1,k2) -> DM.union k1 k2 DM.empty) (ys :: [(k,k)])
     return (s1 <> s2)
+  shrink = mapMaybe DM.fromSets . shrink . DM.toSets
 
 newtype WrapWord8 = WrapWord8 Word8
   deriving (FromJSON,ToJSON,Show,Eq,Arbitrary,Ord)
 
+instance Semigroup WrapWord8 where
+  WrapWord8 a <> WrapWord8 b = WrapWord8 (a + b)
+
 instance Monoid WrapWord8 where
   mempty = WrapWord8 0
   mappend (WrapWord8 a) (WrapWord8 b) = WrapWord8 (a + b)
 
+newtype SmallList a = SmallList { getSmallList :: [a] }
+
+instance Arbitrary a => Arbitrary (SmallList a) where
+  arbitrary = do
+    n <- choose (0,20)
+    xs <- vector n
+    return (SmallList xs)
+  shrink = map SmallList . shrink . getSmallList