diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Andrew Martin (c) 2017
+
+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 @@
+# disjoint-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/disjoint-containers.cabal b/disjoint-containers.cabal
new file mode 100644
--- /dev/null
+++ b/disjoint-containers.cabal
@@ -0,0 +1,40 @@
+name: disjoint-containers
+version: 0.1.0
+synopsis: Disjoint containers
+description: Disjoint containers
+homepage: https://github.com/andrewthad/disjoint-containers#readme
+license: BSD3
+license-file: LICENSE
+author: Andrew Martin
+maintainer: andrew.thaddeus@gmail.com
+copyright: 2017 Andrew Martin
+category: Web
+build-type: Simple
+extra-source-files: README.md
+cabal-version: >=1.10
+
+library
+  hs-source-dirs: src
+  exposed-modules:
+    Data.DisjointSet
+    Data.DisjointMap
+  build-depends:
+      base >= 4.7 && < 5
+    , transformers >= 0.5 && < 0.6
+    , containers >= 0.5.10 && < 0.6
+  default-language: Haskell2010
+
+test-suite test
+  type: exitcode-stdio-1.0
+  hs-source-dirs: test
+  main-is: Spec.hs
+  build-depends:
+      base
+    , disjoint-containers
+    , containers
+    , QuickCheck
+  default-language: Haskell2010
+
+source-repository head
+  type: git
+  location: https://github.com/andrewthad/disjoint-containers
diff --git a/src/Data/DisjointMap.hs b/src/Data/DisjointMap.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/DisjointMap.hs
@@ -0,0 +1,201 @@
+{-# LANGUAGE BangPatterns #-}
+
+{-# OPTIONS_GHC -Wall #-}
+
+module Data.DisjointMap
+  ( DisjointMap
+  , empty
+  , singleton
+  , singletons
+  , insert
+  , union
+  , lookup
+  , representative
+  , representative'
+  , toLists
+  ) where
+
+import Prelude hiding (lookup)
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Class
+import Control.Monad
+
+import Data.Map (Map)
+import Data.Set (Set)
+import Data.Bifunctor (first)
+import qualified Data.Map.Strict as M
+import qualified Data.Map.Merge.Strict as MM
+import qualified Data.Set as S
+
+data DisjointMap k v = DisjointMap
+  !(Map k k) -- parents and values
+  !(Map k (Ranked v)) -- ranks
+
+data Ranked b = Ranked {-# UNPACK #-} !Int !b
+
+instance (Ord k, Monoid v) => Monoid (DisjointMap k v) where
+  mappend = append
+  mempty = empty
+
+-- technically, it should be possible to weaken the Ord constraint on v to
+-- an Eq constraint
+instance (Ord k, Ord v) => Eq (DisjointMap k v) where
+  a == b = S.fromList (toSets a) == S.fromList (toSets b)
+
+instance (Ord k, Ord v) => Ord (DisjointMap k v) where
+  compare a b = compare (S.fromList (toSets a)) (S.fromList (toSets b))
+
+instance (Show k, Ord k, Show v) => Show (DisjointMap k v) where
+  show = showDisjointSet
+
+showDisjointSet :: (Show k, Ord k, Show v) => DisjointMap k v -> String
+showDisjointSet = show . toLists
+
+toLists :: Ord k => DisjointMap k v -> [([k],v)]
+toLists = (fmap.first) S.toList . toSets
+
+toSets :: Ord k => DisjointMap k v -> [(Set k,v)]
+toSets dm@(DisjointMap _ r) = M.elems $ MM.merge MM.dropMissing MM.dropMissing (MM.zipWithMatched $ \_ ks (Ranked _ v) -> (ks,v)) (flatten dm) r
+
+-- in the result of this, the key in the
+-- map keeps everything separate.
+flatten :: Ord k => DisjointMap k v -> Map k (Set k)
+flatten ds@(DisjointMap p _) = S.foldl'
+  ( \m a -> case find a ds of
+    Nothing -> error "DisjointMap flatten: invariant violated. missing key."
+    Just b -> M.insertWith S.union b (S.singleton a) m
+  ) M.empty (M.keysSet p)
+
+{-|
+Create an equivalence relation between x and y. If either x or y
+are not already is the disjoint set, they are first created
+as singletons.
+-}
+union :: (Ord k, Monoid v) => k -> k -> DisjointMap k v -> DisjointMap k v
+union !x !y set = flip execState set $ runMaybeT $ do
+  repx <- lift $ state $ lookupCompressAdd x
+  repy <- lift $ state $ lookupCompressAdd y
+  guard $ repx /= repy
+  DisjointMap p r <- lift get
+  let Ranked rankx valx = r M.! repx
+  let Ranked ranky valy = r M.! repy
+  let val = mappend valx valy
+  lift $ put $! case compare rankx ranky of
+    LT -> let p' = M.insert repx repy p
+              r' = M.delete repx $! M.insert repy (Ranked ranky val) r
+          in  DisjointMap p' r'
+    GT -> let p' = M.insert repy repx p
+              r' = M.delete repy $! M.insert repx (Ranked rankx val) r
+          in  DisjointMap p' r'
+    EQ -> let p' = M.insert repx repy p
+              r' = M.delete repx $! M.insert repy (Ranked (ranky + 1) val) r
+          in  DisjointMap p' r'
+
+{-|
+Find the set representative for this input.
+-}
+representative :: Ord k => k -> DisjointMap k v -> Maybe k
+representative = find
+
+{-| Insert x into the disjoint set.  If it is already a member,
+    then do nothing, otherwise x has no equivalence relations.
+    O(logn).
+-}
+insert :: (Ord k, Monoid v) => k -> v -> DisjointMap k v -> DisjointMap k v
+insert !x !v set@(DisjointMap p r) =
+  let (l, p') = M.insertLookupWithKey (\_ _ old -> old) x x p
+   in case l of
+        Just _ ->
+          let (m,DisjointMap p' r') = representative' x set
+           in case m of
+                Nothing -> error "DisjointMap insert: invariant violated"
+                Just root -> DisjointMap p' (M.adjust (\(Ranked rank vOld) -> Ranked rank (mappend v vOld)) root r')
+        Nothing ->
+          let r' = M.insert x (Ranked 0 v) r
+          in  DisjointMap p' r'
+
+{-| Create a disjoint set with one member. O(1). -}
+singleton :: k -> v -> DisjointMap k v
+singleton !x !v =
+  let p = M.singleton x x
+      r = M.singleton x (Ranked 0 v)
+   in DisjointMap p r
+
+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 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
+
+appendParents :: (Ord k, Monoid v) => Map k (Ranked v) -> DisjointMap k v -> Map k k -> DisjointMap k v
+appendParents !ranks = M.foldlWithKey' $ \ds x y -> if x == y
+  then case M.lookup x ranks of
+    Nothing -> error "DisjointMap appendParents: invariant violated"
+    Just (Ranked _ v) -> insert x v ds
+  else union x y ds
+
+{-| Create a disjoint set where all members are equal. -}
+singletons :: Eq k => Set k -> v -> DisjointMap k v
+singletons s v = case S.lookupMin s of
+  Nothing -> empty
+  Just x ->
+    let p = M.fromSet (\_ -> x) s
+        r = M.singleton x (Ranked 1 v)
+    in DisjointMap p r
+
+{-|
+Find the set representative for this input. Returns a new disjoint
+set in which the path has been compressed.
+-}
+representative' :: Ord k => k -> DisjointMap k v -> (Maybe k, DisjointMap k v)
+representative' !x set =
+  case find x set of
+    Nothing  -> (Nothing, set)
+    Just rep -> let set' = compress rep x set
+                in  set' `seq` (Just rep, set')
+
+lookupCompressAdd :: (Ord k, Monoid v) => k -> DisjointMap k v -> (k, DisjointMap k v)
+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')
+
+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'
+
+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'
+
+-- TODO: make this smarter about recreating the parents Map.
+-- Currently, it will recreate it more often than needed.
+compress :: Ord k => k -> k -> DisjointMap k v -> DisjointMap k v
+compress !rep = helper
+  where
+  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
+
+
diff --git a/src/Data/DisjointSet.hs b/src/Data/DisjointSet.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/DisjointSet.hs
@@ -0,0 +1,175 @@
+{-# LANGUAGE BangPatterns #-}
+
+{-# OPTIONS_GHC -Wall #-}
+
+module Data.DisjointSet
+  ( DisjointSet
+  , empty
+  , singleton
+  , singletons
+  , insert
+  , union
+  , representative
+  , representative'
+  , toLists
+  ) where
+
+import Prelude hiding (lookup)
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Class
+import Control.Monad
+
+import Data.Map (Map)
+import Data.Set (Set)
+import Data.Semigroup (Semigroup)
+import qualified Data.Semigroup
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+
+data DisjointSet a = DisjointSet
+  !(Map a a) -- parents
+  !(Map a Int) -- ranks
+
+instance Ord a => Monoid (DisjointSet a) where
+  mappend = append
+  mempty = empty
+
+instance Ord a => Semigroup (DisjointSet a) where
+  (<>) = append
+
+instance Ord a => Eq (DisjointSet a) where
+  a == b = S.fromList (toSets a) == S.fromList (toSets b)
+
+instance Ord a => Ord (DisjointSet a) where
+  compare a b = compare (S.fromList (toSets a)) (S.fromList (toSets b))
+
+instance (Show a, Ord a) => Show (DisjointSet a) where
+  show = showDisjointSet
+
+showDisjointSet :: (Show a, Ord a) => DisjointSet a -> String
+showDisjointSet = show . toLists
+
+toLists :: Ord a => DisjointSet a -> [[a]]
+toLists = map S.toList . toSets
+
+toSets :: Ord a => DisjointSet a -> [Set a]
+toSets = M.elems . flatten
+
+-- in the result of this, the key in the
+-- map keeps everything separate.
+flatten :: Ord a => DisjointSet a -> Map a (Set a)
+flatten ds@(DisjointSet p _) = S.foldl'
+  ( \m a -> case find a ds of
+    Nothing -> error "DisjointSet flatten: invariant violated. missing key."
+    Just b -> M.insertWith S.union b (S.singleton a) m
+  ) M.empty (M.keysSet p)
+
+{-|
+Create an equivalence relation between x and y. If either x or y
+are not already is the disjoint set, they are first created
+as singletons.
+-}
+union :: Ord a => a -> a -> DisjointSet a -> DisjointSet a
+union !x !y set = flip execState set $ runMaybeT $ do
+  repx <- lift $ state $ lookupCompressAdd x
+  repy <- lift $ state $ lookupCompressAdd y
+  guard $ repx /= repy
+  DisjointSet p r <- lift get
+  let rankx = r M.! repx
+  let ranky = r M.! repy
+  lift $ put $! case compare rankx ranky of
+    LT -> let p' = M.insert repx repy p
+              r' = M.delete repx r
+          in  DisjointSet p' r'
+    GT -> let p' = M.insert repy repx p
+              r' = M.delete repy r
+          in  DisjointSet p' r'
+    EQ -> let p' = M.insert repx repy p
+              r' = M.delete repx $! M.insert repy (ranky + 1) r
+          in  DisjointSet p' r'
+
+{-|
+Find the set representative for this input.
+-}
+representative :: Ord a => a -> DisjointSet a -> Maybe a
+representative = find
+
+{-| Insert x into the disjoint set.  If it is already a member,
+    then do nothing, otherwise x has no equivalence relations.
+    O(logn).
+-}
+insert :: Ord a => a -> DisjointSet a -> DisjointSet a
+insert !x set@(DisjointSet p r) =
+    let (l, p') = M.insertLookupWithKey (\_ _ old -> old) x x p
+    in  case l of
+          Just _  -> set
+          Nothing ->
+              let r' = M.insert x 0 r
+              in  DisjointSet p' r'
+
+{-| Create a disjoint set with one member. O(1). -}
+singleton :: a -> DisjointSet a
+singleton !x =
+  let p = M.singleton x x
+      r = M.singleton x 0
+   in DisjointSet p r
+
+empty :: DisjointSet a
+empty = DisjointSet M.empty M.empty
+
+append :: Ord a => DisjointSet a -> DisjointSet a -> DisjointSet a
+append s1@(DisjointSet m1 _) s2@(DisjointSet m2 _) = if M.size m1 > M.size m2
+  then appendParents s1 m2
+  else appendParents s2 m1
+
+appendParents :: Ord a => DisjointSet a -> Map a a -> DisjointSet a
+appendParents = M.foldlWithKey' $ \ds x y -> if x == y
+  then insert x ds
+  else union x y ds
+
+{-| Create a disjoint set where all members are equal. -}
+singletons :: Eq a => Set a -> DisjointSet a
+singletons s = case S.lookupMin s of
+  Nothing -> empty
+  Just x ->
+    let p = M.fromSet (\_ -> x) s
+        r = M.singleton x 1
+    in DisjointSet p r
+
+{-|
+Find the set representative for this input. Returns a new disjoint
+set in which the path has been compressed.
+-}
+representative' :: Ord a => a -> DisjointSet a -> (Maybe a, DisjointSet a)
+representative' !x set =
+  case find x set of
+    Nothing  -> (Nothing, set)
+    Just rep -> let set' = compress rep x set
+                in  set' `seq` (Just rep, set')
+
+lookupCompressAdd :: Ord a => a -> DisjointSet a -> (a, DisjointSet a)
+lookupCompressAdd !x set =
+  case find x set of
+    Nothing -> (x, insert x set)
+    Just rep -> let set' = compress rep x set
+                in  set' `seq` (rep, set')
+
+find :: Ord a => a -> DisjointSet a -> Maybe a
+find !x (DisjointSet 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'
+
+-- TODO: make this smarter about recreating the parents Map.
+-- Currently, it will recreate it more often than needed.
+compress :: Ord a => a -> a -> DisjointSet a -> DisjointSet a
+compress !rep = helper
+    where helper !x set@(DisjointSet 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` DisjointSet p' r
+
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE BangPatterns #-}
+
+import Test.QuickCheck
+import Data.Word
+import Data.Monoid
+import Data.DisjointSet (DisjointSet)
+import Data.DisjointMap (DisjointMap)
+import Data.Set (Set)
+import Data.Foldable (toList)
+import qualified Data.Foldable as F
+import qualified Data.DisjointSet as DS
+import qualified Data.DisjointMap as DM
+import qualified GHC.OldList as L
+
+main :: IO ()
+main = do
+  putStrLn "\nBeginning QuickCheck Tests"
+  quickCheck propUnionAll
+  quickCheck propUnionAppend
+  quickCheck propSingletons
+  quickCheck propMapUnionAppend
+
+propUnionAll :: [Word] -> Bool
+propUnionAll xs =
+  let pairs = zip xs (drop 1 xs)
+      ds = L.foldl' (\s (a,b) -> DS.union a b s) DS.empty pairs
+      roots = mapM (\x -> DS.representative x ds) xs
+   in case roots of
+        Nothing -> L.length xs == 1
+        Just [] -> L.null xs
+        Just (y : ys) -> L.all (== y) ys
+
+propUnionAppend :: [(Word,Word)] -> Bool
+propUnionAppend xs = 
+  let r1 = unionPairs xs
+      (xs1,xs2) = splitList xs
+      r2 = unionPairs xs1 <> unionPairs xs2
+   in r1 == r2
+
+propMapUnionAppend :: [(Word,Word)] -> [(Word,Sum Word)] -> Bool
+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
+
+propSingletons :: [Set Word] -> Bool
+propSingletons xs = foldMap unionFoldable xs == foldMap DS.singletons xs
+
+splitList :: [a] -> ([a],[a])
+splitList xs =
+  let halfLen = div (L.length xs) 2
+      xs1 = L.drop halfLen xs
+      xs2 = L.take halfLen xs
+   in (xs1,xs2)
+
+unionFoldable :: Ord a => Foldable t => t a -> DisjointSet a
+unionFoldable xs =
+  let ys = toList xs
+      pairs = zip ys (drop 1 ys)
+   in case ys of
+        [] -> DS.empty
+        z : _ -> unionPairsGo pairs (DS.singleton z)
+
+mapFromPairs :: (Ord k, Monoid v) => Foldable t => t (k,v) -> DisjointMap k v
+mapFromPairs = F.foldl' (\dm (k,v) -> DM.insert k v dm) DM.empty
+
+unionPairs :: Ord a => [(a,a)] -> DisjointSet a
+unionPairs xs = unionPairsGo xs DS.empty
+
+unionPairsGo :: Ord a => [(a,a)] -> DisjointSet a -> DisjointSet a
+unionPairsGo [] !ds = ds
+unionPairsGo ((a,b):xs) !ds = unionPairsGo xs (DS.union a b ds)
+
+unionMapPairs :: (Ord k, Monoid v) => [(k,k)] -> DisjointMap k v
+unionMapPairs xs = unionMapPairsGo xs DM.empty
+
+unionMapPairsGo :: (Ord k, Monoid v) => [(k,k)] -> DisjointMap k v -> DisjointMap k v
+unionMapPairsGo [] !ds = ds
+unionMapPairsGo ((a,b):xs) !ds = unionMapPairsGo xs (DM.union a b ds)