diff --git a/src/Unimap.hs b/src/Unimap.hs
new file mode 100644
--- /dev/null
+++ b/src/Unimap.hs
@@ -0,0 +1,497 @@
+-- | (Import this module qualified)
+module Unimap
+  ( Changed (..)
+  , maybeChanged
+  , Equiv (..)
+  , emptyEquiv
+  , Entry (..)
+  , filterRootEntries
+  , MergeOne
+  , MergeMany
+  , adaptMergeOne
+  , foldMergeOne
+  , foldMergeMany
+  , concatMergeOne
+  , concatMergeMany
+  , UnionMap (unUnionMap)
+  , UnionMapLens
+  , empty
+  , size
+  , member
+  , toList
+  , values
+  , AddRes (..)
+  , AddVal (..)
+  , add
+  , addLM
+  , addM
+  , TraceRes (..)
+  , trace
+  , LookupRes (..)
+  , LookupVal (..)
+  , lookup
+  , lookupLM
+  , lookupM
+  , equiv
+  , equivLM
+  , equivM
+  , compact
+  , compactLM
+  , compactM
+  , canonicalize
+  , canonicalizeLM
+  , canonicalizeM
+  , UpdateRes (..)
+  , UpdateVal (..)
+  , update
+  , updateLM
+  , updateM
+  , MergeRes (..)
+  , MergeVal (..)
+  , mergeOne
+  , mergeOneLM
+  , mergeOneM
+  , mergeMany
+  , mergeManyLM
+  , mergeManyM
+  , extract
+  , extractLM
+  , extractM
+  )
+where
+
+import Control.Monad.Except (Except, MonadError (..), runExcept)
+import Control.Monad.State.Strict (MonadState, StateT, get, put, runStateT, state)
+import Data.Coerce (Coercible)
+import Data.Foldable (fold, foldl')
+import Data.Foldable qualified as F
+import Data.Maybe (fromMaybe, mapMaybe)
+import IntLike.Map (IntLikeMap)
+import IntLike.Map qualified as ILM
+import IntLike.Set (IntLikeSet)
+import IntLike.Set qualified as ILS
+import Optics (Lens', Traversal', equality', over, set, view)
+import Prelude hiding (lookup)
+
+-- Private util
+
+mayStateLens :: (MonadState s m) => Lens' s x -> (x -> (a, Maybe x)) -> m a
+mayStateLens l f = state $ \s ->
+  let u = view l s
+      (a, mu') = f u
+  in  case mu' of
+        Nothing -> (a, s)
+        Just u' ->
+          let s' = set l u' s
+          in  (a, s')
+
+stateLens :: (MonadState s m) => Lens' s x -> (x -> (a, x)) -> m a
+stateLens l f = state $ \s ->
+  let u = view l s
+      (a, u') = f u
+      s' = set l u' s
+  in  (a, s')
+
+newtype DropM e s a = DropM {unDropM :: StateT s (Except e) a}
+  deriving newtype (Functor, Applicative, Monad, MonadState s, MonadError e)
+
+runDropM :: DropM e s a -> s -> Either e (a, s)
+runDropM it s = runExcept (runStateT (unDropM it) s)
+
+safeTail :: [a] -> [a]
+safeTail xs =
+  case xs of
+    [] -> xs
+    _ : ys -> ys
+
+-- The real stuff
+
+data Changed
+  = ChangedYes
+  | ChangedNo
+  deriving stock (Eq, Show)
+
+maybeChanged :: Maybe a -> Changed
+maybeChanged = \case
+  Nothing -> ChangedNo
+  Just _ -> ChangedYes
+
+data Equiv k = Equiv
+  { equivFwd :: !(IntLikeMap k (IntLikeSet k))
+  , equivBwd :: !(IntLikeMap k k)
+  }
+  deriving stock (Eq, Show)
+
+emptyEquiv :: Equiv k
+emptyEquiv = Equiv ILM.empty ILM.empty
+
+data Entry k v
+  = EntryLink !k
+  | EntryValue !v
+  deriving stock (Eq, Show, Ord, Functor, Foldable, Traversable)
+
+filterRootEntries :: (Coercible k Int) => IntLikeMap k (Entry k v) -> IntLikeMap k v
+filterRootEntries = ILM.fromList . mapMaybe (uncurry go) . ILM.toList
+ where
+  go k = \case
+    EntryLink _ -> Nothing
+    EntryValue v -> Just (k, v)
+
+type MergeOne e v r = Maybe v -> v -> Either e (r, v)
+
+type MergeMany f e v r = Maybe v -> f v -> Either e (r, v)
+
+adaptMergeOne :: (v -> f v) -> MergeMany f e v r -> MergeOne e v r
+adaptMergeOne h g mv = g mv . h
+
+foldMergeOne :: (Monoid r) => (v -> v -> Either e (r, v)) -> MergeOne e v r
+foldMergeOne g mv v =
+  case mv of
+    Nothing -> Right (mempty, v)
+    Just w -> g w v
+
+foldMergeMany :: (Foldable f, Monoid r) => Either e v -> (v -> v -> Either e (r, v)) -> MergeMany f e v r
+foldMergeMany onE g mv fv = start
+ where
+  start =
+    let vs = F.toList fv
+    in  case maybe vs (: vs) mv of
+          [] -> fmap (mempty,) onE
+          y : ys -> go mempty y ys
+  go !r !v = \case
+    [] -> Right (r, v)
+    w : ws ->
+      case g v w of
+        Right (s, u) -> go (r <> s) u ws
+        e@(Left _) -> e
+
+concatMergeOne :: (Semigroup v) => MergeOne e v ()
+concatMergeOne mv v = Right ((), maybe v (<> v) mv)
+
+concatMergeMany :: (Foldable f, Monoid v) => MergeMany f e v ()
+concatMergeMany mv vs = concatMergeOne mv (fold vs)
+
+newtype UnionMap k v = UnionMap {unUnionMap :: IntLikeMap k (Entry k v)}
+  deriving stock (Eq, Show, Functor, Foldable, Traversable)
+
+type UnionMapLens s k v = Lens' s (UnionMap k v)
+
+empty :: UnionMap k v
+empty = UnionMap ILM.empty
+
+size :: UnionMap k v -> Int
+size = ILM.size . unUnionMap
+
+member :: (Coercible k Int) => k -> UnionMap k v -> Bool
+member k = ILM.member k . unUnionMap
+
+toList :: (Coercible k Int) => UnionMap k v -> [(k, Entry k v)]
+toList = ILM.toList . unUnionMap
+
+values :: (Coercible k Int) => UnionMap k v -> IntLikeMap k v
+values = foldl' go ILM.empty . toList
+ where
+  go m (k, ue) =
+    case ue of
+      EntryValue v -> ILM.insert k v m
+      _ -> m
+
+data AddRes k v
+  = AddResAdded !(UnionMap k v)
+  | AddResDuplicate
+  deriving stock (Eq, Show)
+
+add :: (Coercible k Int) => k -> v -> UnionMap k v -> AddRes k v
+add k v (UnionMap m) =
+  case ILM.lookup k m of
+    Nothing -> AddResAdded (UnionMap (ILM.insert k (EntryValue v) m))
+    Just _ -> AddResDuplicate
+
+data AddVal
+  = AddValAdded
+  | AddValDuplicate
+  deriving stock (Eq, Show)
+
+addLM :: (Coercible k Int, MonadState s m) => UnionMapLens s k v -> k -> v -> m AddVal
+addLM l k v = mayStateLens l $ \u ->
+  case add k v u of
+    AddResAdded w -> (AddValAdded, Just w)
+    AddResDuplicate -> (AddValDuplicate, Nothing)
+
+addM :: (Coercible k Int, MonadState (UnionMap k v) m) => k -> v -> m AddVal
+addM = addLM equality'
+
+data TraceRes k v
+  = TraceResMissing !k
+  | TraceResFound !k !v ![k]
+  deriving stock (Eq, Show)
+
+trace :: (Coercible k Int) => k -> UnionMap k v -> TraceRes k v
+trace k (UnionMap m) = go [] k
+ where
+  go !acc j =
+    case ILM.lookup j m of
+      Nothing -> TraceResMissing j
+      Just link -> case link of
+        EntryLink kx -> go (j : acc) kx
+        EntryValue v -> TraceResFound j v acc
+
+data LookupRes k v
+  = LookupResMissing !k
+  | LookupResFound !k !v !(Maybe (UnionMap k v))
+  deriving stock (Eq, Show)
+
+lookup :: (Coercible k Int) => k -> UnionMap k v -> LookupRes k v
+lookup k u = case trace k u of
+  TraceResMissing kx -> LookupResMissing kx
+  TraceResFound kr vr acc ->
+    let mu =
+          if null acc
+            then Nothing
+            else Just (foldl' (\(UnionMap n) kx -> UnionMap (ILM.insert kx (EntryLink kr) n)) u (safeTail acc))
+    in  LookupResFound kr vr mu
+
+data LookupVal k v
+  = LookupValMissing !k
+  | LookupValOk !k !v !Changed
+  deriving stock (Eq, Show)
+
+lookupLM :: (Coercible k Int, MonadState s m) => UnionMapLens s k v -> k -> m (LookupVal k v)
+lookupLM l k = mayStateLens l $ \u ->
+  case lookup k u of
+    LookupResMissing x -> (LookupValMissing x, Nothing)
+    LookupResFound x y mw -> (LookupValOk x y (maybeChanged mw), mw)
+
+lookupM :: (Coercible k Int, MonadState (UnionMap k v) m) => k -> m (LookupVal k v)
+lookupM = lookupLM equality'
+
+equiv :: (Coercible k Int) => UnionMap k v -> (Equiv k, Maybe (UnionMap k v))
+equiv u = foldl' go (emptyEquiv, Nothing) (toList u)
+ where
+  go (Equiv fwd bwd, mw) (k, ue) =
+    case ue of
+      EntryValue _ ->
+        let fwd' = ILM.alter (Just . fromMaybe ILS.empty) k fwd
+        in  (Equiv fwd' bwd, mw)
+      EntryLink _ ->
+        case lookup k (fromMaybe u mw) of
+          LookupResMissing _ -> error "impossible"
+          LookupResFound r _ mw' ->
+            let fwd' = ILM.alter (Just . maybe (ILS.singleton k) (ILS.insert k)) r fwd
+                bwd' = ILM.insert k r bwd
+            in  (Equiv fwd' bwd', mw')
+
+equivLM :: (Coercible k Int, MonadState s m) => UnionMapLens s k v -> m (Equiv k)
+equivLM l = mayStateLens l equiv
+
+equivM :: (Coercible k Int, MonadState (UnionMap k v) m) => m (Equiv k)
+equivM = equivLM equality'
+
+-- | Compresses all paths so there is never more than one jump to the root of each class
+-- Retains all keys in the map but returns a mapping of non-root -> root keys
+compact :: (Coercible k Int) => UnionMap k v -> (IntLikeMap k k, UnionMap k v)
+compact u = foldl' go (ILM.empty, u) (toList u)
+ where
+  go mw@(m, w) (k, ue) =
+    if ILM.member k m
+      then mw
+      else case ue of
+        EntryValue _ -> mw
+        EntryLink _ ->
+          case trace k w of
+            TraceResMissing _ -> error "impossible"
+            TraceResFound r _ kacc ->
+              foldl' (\(m', w') j -> (ILM.insert j r m', UnionMap (ILM.insert j (EntryLink r) (unUnionMap w')))) mw kacc
+
+compactLM :: (Coercible k Int, MonadState s m) => UnionMapLens s k v -> m (IntLikeMap k k)
+compactLM l = stateLens l compact
+
+compactM :: (Coercible k Int, MonadState (UnionMap k v) m) => m (IntLikeMap k k)
+compactM = compactLM equality'
+
+-- | Compacts and rewrites all values with canonical keys.
+-- Retains all keys in the map and again returns a mapping of non-root -> root keys.
+-- TODO remove non-canonical keys?
+canonicalize :: (Coercible k Int) => Traversal' v k -> UnionMap k v -> (IntLikeMap k k, UnionMap k v)
+canonicalize t u = res
+ where
+  res = let (m, UnionMap w) = compact u in (m, UnionMap (fmap (go m) w))
+  go m ue =
+    case ue of
+      EntryLink _ -> ue
+      EntryValue fk -> EntryValue (over t (\j -> ILM.findWithDefault j j m) fk)
+
+canonicalizeLM
+  :: (Coercible k Int, MonadState s m) => UnionMapLens s k v -> Traversal' v k -> m (IntLikeMap k k)
+canonicalizeLM l t = stateLens l (canonicalize t)
+
+canonicalizeM :: (Coercible k Int, MonadState (UnionMap k v) m) => Traversal' v k -> m (IntLikeMap k k)
+canonicalizeM = canonicalizeLM equality'
+
+data UpdateRes e k v r
+  = UpdateResMissing !k
+  | UpdateResEmbed !e
+  | UpdateResAdded !v !r !(UnionMap k v)
+  | UpdateResUpdated !k !v !r !(UnionMap k v)
+  deriving stock (Eq, Show)
+
+update :: (Coercible k Int, Eq k) => MergeOne e v r -> k -> v -> UnionMap k v -> UpdateRes e k v r
+update g k v u@(UnionMap m) = goLookupK
+ where
+  goLookupK = case lookup k u of
+    LookupResMissing kx ->
+      if k == kx
+        then goAdd
+        else UpdateResMissing kx
+    LookupResFound kr vr mu -> goMerge kr vr (fromMaybe u mu)
+  goAdd =
+    case g Nothing v of
+      Left e -> UpdateResEmbed e
+      Right (r, vg) -> UpdateResAdded vg r (UnionMap (ILM.insert k (EntryValue v) m))
+  goMerge kr vr (UnionMap mr) =
+    case g (Just vr) v of
+      Left e -> UpdateResEmbed e
+      Right (r, vg) -> UpdateResUpdated kr vg r (UnionMap (ILM.insert kr (EntryValue vg) mr))
+
+data UpdateVal e k v r
+  = UpdateValMissing !k
+  | UpdateValEmbed !e
+  | UpdateValAdded !v !r
+  | UpdateValUpdated !k !v !r
+  deriving stock (Eq, Show)
+
+updateLM
+  :: (Coercible k Int, Eq k, MonadState s m) => UnionMapLens s k v -> MergeOne e v r -> k -> v -> m (UpdateVal e k v r)
+updateLM l g k v = mayStateLens l $ \u ->
+  case update g k v u of
+    UpdateResMissing x -> (UpdateValMissing x, Nothing)
+    UpdateResEmbed e -> (UpdateValEmbed e, Nothing)
+    UpdateResAdded y r w -> (UpdateValAdded y r, Just w)
+    UpdateResUpdated x y r w -> (UpdateValUpdated x y r, Just w)
+
+updateM :: (Coercible k Int, Eq k, MonadState (UnionMap k v) m) => MergeOne e v r -> k -> v -> m (UpdateVal e k v r)
+updateM = updateLM equality'
+
+data MergeRes e k v r
+  = MergeResMissing !k
+  | MergeResEmbed !e
+  | MergeResMerged !k !v !r !(UnionMap k v)
+  deriving stock (Eq, Show)
+
+mergeOne :: (Coercible k Int, Eq k) => MergeOne e v r -> k -> k -> UnionMap k v -> MergeRes e k v r
+mergeOne g k j u = goLookupK
+ where
+  doCompactCheck kr jr w jacc = doCompact kr w (if kr == jr then safeTail jacc else jr : jacc)
+  doCompact kr w acc = UnionMap (foldl' (\m x -> ILM.insert x (EntryLink kr) m) (unUnionMap w) acc)
+  doRoot kr gv w = UnionMap (ILM.insert kr (EntryValue gv) (unUnionMap w))
+  goLookupK = case lookup k u of
+    LookupResMissing kx -> if k == kx then goAssign else MergeResMissing kx
+    LookupResFound kr kv mw -> goLookupJ kr kv (fromMaybe u mw)
+  goAssign = case trace j u of
+    TraceResMissing jx -> MergeResMissing jx
+    TraceResFound jr jv jacc -> goMerge k Nothing jv (doCompactCheck k jr u jacc)
+  goLookupJ kr kv w = case trace j w of
+    TraceResMissing jx -> MergeResMissing jx
+    TraceResFound jr jv jacc -> goMerge kr (Just kv) jv (doCompactCheck kr jr w jacc)
+  goMerge kr mkv jv w1 =
+    case g mkv jv of
+      Left e -> MergeResEmbed e
+      Right (r, gv) ->
+        let w2 = doRoot kr gv w1
+        in  MergeResMerged kr gv r w2
+
+data MergeVal e k v r
+  = MergeValMissing !k
+  | MergeValEmbed !e
+  | MergeValMerged !k !v !r
+  deriving stock (Eq, Show)
+
+mergeOneLM
+  :: (Coercible k Int, Eq k, MonadState s m) => UnionMapLens s k v -> MergeOne e v r -> k -> k -> m (MergeVal e k v r)
+mergeOneLM l g k j = mayStateLens l $ \u ->
+  case mergeOne g k j u of
+    MergeResMissing x -> (MergeValMissing x, Nothing)
+    MergeResEmbed e -> (MergeValEmbed e, Nothing)
+    MergeResMerged x y r w -> (MergeValMerged x y r, Just w)
+
+mergeOneM :: (Coercible k Int, Eq k, MonadState (UnionMap k v) m) => MergeOne e v r -> k -> k -> m (MergeVal e k v r)
+mergeOneM = mergeOneLM equality'
+
+mergeMany :: (Traversable f, Coercible k Int, Eq k) => MergeMany f e v r -> k -> f k -> UnionMap k v -> MergeRes e k v r
+mergeMany g k js u = goLookupK
+ where
+  doCompactCheck kr jr w jacc = doCompact kr w (if kr == jr then safeTail jacc else jr : jacc)
+  doCompact kr w acc = UnionMap (foldl' (\m x -> ILM.insert x (EntryLink kr) m) (unUnionMap w) acc)
+  doRoot kr gv w = UnionMap (ILM.insert kr (EntryValue gv) (unUnionMap w))
+  doTraceJ kr y = do
+    w <- get
+    case trace y w of
+      TraceResMissing jx -> throwError jx
+      TraceResFound jr jv jacc -> do
+        put (doCompactCheck kr jr w jacc)
+        pure jv
+  doTraceJs kr = runDropM (traverse (doTraceJ kr) js)
+  goLookupK = case lookup k u of
+    LookupResMissing kx -> if k == kx then goAssign else MergeResMissing kx
+    LookupResFound kr kv mw -> goLookupJs kr kv (fromMaybe u mw)
+  goAssign =
+    case doTraceJs k u of
+      Left jx -> MergeResMissing jx
+      Right (jvs, w1) -> goMerge k Nothing jvs w1
+  goLookupJs kr kv w =
+    case doTraceJs kr w of
+      Left jx -> MergeResMissing jx
+      Right (jvs, w1) -> goMerge kr (Just kv) jvs w1
+  goMerge kr mkv jvs w1 =
+    case g mkv jvs of
+      Left e -> MergeResEmbed e
+      Right (r, gv) ->
+        let w2 = doRoot kr gv w1
+        in  MergeResMerged kr gv r w2
+
+mergeManyLM
+  :: (Traversable f, Coercible k Int, Eq k, MonadState s m)
+  => UnionMapLens s k v
+  -> MergeMany f e v r
+  -> k
+  -> f k
+  -> m (MergeVal e k v r)
+mergeManyLM l g k js = mayStateLens l $ \u ->
+  case mergeMany g k js u of
+    MergeResMissing x -> (MergeValMissing x, Nothing)
+    MergeResEmbed e -> (MergeValEmbed e, Nothing)
+    MergeResMerged x y r w -> (MergeValMerged x y r, Just w)
+
+mergeManyM
+  :: (Traversable f, Coercible k Int, Eq k, MonadState (UnionMap k v) m)
+  => MergeMany f e v r
+  -> k
+  -> f k
+  -> m (MergeVal e k v r)
+mergeManyM = mergeManyLM equality'
+
+-- | Return the subgraph accessible from a given key.
+extract :: (Coercible k Int) => Traversal' v k -> k -> UnionMap k v -> (Maybe (k, IntLikeMap k v), UnionMap k v)
+extract t k0 u =
+  let (m, w) = canonicalize t u
+      n = filterRootEntries (unUnionMap w)
+      mk1 = case ILM.lookup k0 m of
+        Nothing -> k0 <$ ILM.lookup k0 n
+        Just k1 -> Just k1
+      mp = fmap (,n) mk1
+  in  (mp, w)
+
+extractLM
+  :: (Coercible k Int, MonadState s m)
+  => UnionMapLens s k v
+  -> Traversal' v k
+  -> k
+  -> m (Maybe (k, IntLikeMap k v))
+extractLM l t k = stateLens l (extract t k)
+
+extractM
+  :: (Coercible k Int, MonadState (UnionMap k v) m)
+  => Traversal' v k
+  -> k
+  -> m (Maybe (k, IntLikeMap k v))
+extractM = extractLM equality'
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,172 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (main) where
+
+import Control.Monad.State.Strict (MonadState (..), State, StateT (..), evalStateT, runState)
+import Control.Monad.Trans (lift)
+import Data.Bifunctor (bimap, first)
+import Data.Char (chr, ord)
+import Data.Semigroup (Max)
+import Data.Void (Void)
+import IntLike.Map (IntLikeMap)
+import IntLike.Map qualified as ILM
+import IntLike.Set (IntLikeSet)
+import IntLike.Set qualified as ILS
+import PropUnit (TestTree, testGroup, testMain, testUnit, (===))
+import Unimap qualified as UM
+
+runS :: (Monad m) => s -> StateT s m () -> m ()
+runS = flip evalStateT
+
+testS :: (Monad m) => (s -> m a) -> StateT s m a
+testS p = get >>= lift . p
+
+applyS :: (Monad m) => State s a -> StateT s m a
+applyS = state . runState
+
+applyTestS :: (Monad m) => State s a -> (a -> s -> m b) -> StateT s m b
+applyTestS act check = do
+  a <- applyS act
+  s <- get
+  lift (check a s)
+
+newtype V = V {unV :: Int}
+  deriving newtype (Eq)
+  deriving stock (Show)
+
+toV :: Char -> V
+toV = V . ord
+
+fromV :: V -> Char
+fromV = chr . unV
+
+setV :: String -> IntLikeSet V
+setV = ILS.fromList . fmap toV
+
+mapV :: [(Char, a)] -> IntLikeMap V a
+mapV = ILM.fromList . fmap (first toV)
+
+mapVV :: [(Char, Char)] -> IntLikeMap V V
+mapVV = ILM.fromList . fmap (bimap toV toV)
+
+multiMapVV :: [(Char, String)] -> IntLikeMap V (IntLikeSet V)
+multiMapVV = ILM.fromList . fmap (bimap toV setV)
+
+type UMV = UM.UnionMap V (Max Int)
+
+emptyUMV :: UMV
+emptyUMV = UM.empty
+
+mergeOneUMV :: UM.MergeOne Void (Max Int) ()
+mergeOneUMV = UM.concatMergeOne
+
+testUmSimple :: TestTree
+testUmSimple = testUnit "UM simple" $ runS emptyUMV $ do
+  -- start with empty map
+  testS $ \um -> UM.size um === 0
+  -- add 'a'
+  applyTestS (UM.addM (toV 'a') 1) $ \res um -> do
+    res === UM.AddValAdded
+    UM.size um === 1
+    UM.trace (toV 'a') um === UM.TraceResFound (toV 'a') 1 []
+    UM.values um === mapV [('a', 1)]
+  -- lookup 'a'
+  applyTestS (UM.lookupM (toV 'a')) $ \res _ ->
+    res === UM.LookupValOk (toV 'a') 1 UM.ChangedNo
+  -- try to add 'a' again
+  applyTestS (UM.addM (toV 'a') 1) $ \res um -> do
+    res === UM.AddValDuplicate
+    UM.size um === 1
+  -- add 'b' and 'c' and check them
+  _ <- applyS (UM.addM (toV 'b') 2)
+  _ <- applyS (UM.addM (toV 'c') 3)
+  testS $ \um -> do
+    UM.size um === 3
+    UM.trace (toV 'b') um === UM.TraceResFound (toV 'b') 2 []
+    UM.trace (toV 'c') um === UM.TraceResFound (toV 'c') 3 []
+    UM.values um === mapV [('a', 1), ('b', 2), ('c', 3)]
+  applyTestS UM.equivM $ \(UM.Equiv fwd bwd) _ -> do
+    fwd === multiMapVV [('a', ""), ('b', ""), ('c', "")]
+    bwd === mapVV []
+  -- merge 'a' and 'c'
+  applyTestS (UM.mergeOneM mergeOneUMV (toV 'a') (toV 'c')) $ \res um -> do
+    res === UM.MergeValMerged (toV 'a') 3 ()
+    UM.size um === 3
+    UM.trace (toV 'a') um === UM.TraceResFound (toV 'a') 3 []
+    UM.trace (toV 'b') um === UM.TraceResFound (toV 'b') 2 []
+    UM.trace (toV 'c') um === UM.TraceResFound (toV 'a') 3 [toV 'c']
+    UM.values um === mapV [('a', 3), ('b', 2)]
+  applyTestS UM.equivM $ \(UM.Equiv fwd bwd) _ -> do
+    fwd === multiMapVV [('a', "c"), ('b', "")]
+    bwd === mapVV [('c', 'a')]
+  -- try to merge again
+  applyTestS (UM.mergeOneM mergeOneUMV (toV 'a') (toV 'c')) $ \res _ ->
+    res === UM.MergeValMerged (toV 'a') 3 ()
+  -- and the other way around
+  applyTestS (UM.mergeOneM mergeOneUMV (toV 'c') (toV 'a')) $ \res _ ->
+    res === UM.MergeValMerged (toV 'a') 3 ()
+  -- and a non-existent merge
+  applyTestS (UM.mergeOneM mergeOneUMV (toV 'b') (toV 'z')) $ \res _ ->
+    res === UM.MergeValMissing (toV 'z')
+  -- and creating merge
+  applyTestS (UM.mergeOneM mergeOneUMV (toV 'z') (toV 'b')) $ \res _ ->
+    res === UM.MergeValMerged (toV 'z') 2 ()
+  applyTestS UM.equivM $ \(UM.Equiv fwd bwd) _ -> do
+    fwd === multiMapVV [('a', "c"), ('z', "b")]
+    bwd === mapVV [('b', 'z'), ('c', 'a')]
+
+testUmRec :: TestTree
+testUmRec = testUnit "UM rec" $ runS emptyUMV $ do
+  _ <- applyS (UM.addM (toV 'a') 1)
+  _ <- applyS (UM.addM (toV 'b') 2)
+  _ <- applyS (UM.addM (toV 'c') 3)
+  _ <- applyS (UM.addM (toV 'c') 3)
+  applyTestS (UM.mergeOneM mergeOneUMV (toV 'b') (toV 'c')) $ \res um -> do
+    res === UM.MergeValMerged (toV 'b') 3 ()
+    UM.size um === 3
+    UM.trace (toV 'a') um === UM.TraceResFound (toV 'a') 1 []
+    UM.trace (toV 'b') um === UM.TraceResFound (toV 'b') 3 []
+    UM.trace (toV 'c') um === UM.TraceResFound (toV 'b') 3 [toV 'c']
+    UM.values um === mapV [('a', 1), ('b', 3)]
+  applyTestS UM.equivM $ \(UM.Equiv fwd bwd) _ -> do
+    fwd === multiMapVV [('a', ""), ('b', "c")]
+    bwd === mapVV [('c', 'b')]
+  applyTestS (UM.mergeOneM mergeOneUMV (toV 'a') (toV 'b')) $ \res um -> do
+    res === UM.MergeValMerged (toV 'a') 3 ()
+    UM.size um === 3
+    UM.trace (toV 'a') um === UM.TraceResFound (toV 'a') 3 []
+    UM.trace (toV 'b') um === UM.TraceResFound (toV 'a') 3 [toV 'b']
+    UM.trace (toV 'c') um === UM.TraceResFound (toV 'a') 3 [toV 'b', toV 'c']
+    UM.values um === mapV [('a', 3)]
+  applyTestS UM.equivM $ \(UM.Equiv fwd bwd) _ -> do
+    fwd === multiMapVV [('a', "bc")]
+    bwd === mapVV [('b', 'a'), ('c', 'a')]
+
+testUmTail :: TestTree
+testUmTail = testUnit "UM tail" $ runS emptyUMV $ do
+  applyS $ do
+    _ <- UM.addM (toV 'a') 1
+    _ <- UM.addM (toV 'b') 2
+    _ <- UM.addM (toV 'c') 3
+    _ <- UM.addM (toV 'd') 4
+    _ <- UM.mergeOneM mergeOneUMV (toV 'c') (toV 'd')
+    _ <- UM.mergeOneM mergeOneUMV (toV 'b') (toV 'c')
+    _ <- UM.mergeOneM mergeOneUMV (toV 'a') (toV 'b')
+    pure ()
+  testS $ \um ->
+    UM.trace (toV 'd') um === UM.TraceResFound (toV 'a') 4 [toV 'b', toV 'c', toV 'd']
+  applyTestS UM.equivM $ \(UM.Equiv fwd bwd) _ -> do
+    fwd === multiMapVV [('a', "bcd")]
+    bwd === mapVV [('b', 'a'), ('c', 'a'), ('d', 'a')]
+  testS $ \um ->
+    UM.trace (toV 'd') um === UM.TraceResFound (toV 'a') 4 [toV 'd']
+
+main :: IO ()
+main =
+  testMain $ \_ ->
+    testGroup
+      "Unimap"
+      [ testUmSimple
+      , testUmRec
+      , testUmTail
+      ]
diff --git a/unimap.cabal b/unimap.cabal
new file mode 100644
--- /dev/null
+++ b/unimap.cabal
@@ -0,0 +1,113 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.37.0.
+--
+-- see: https://github.com/sol/hpack
+
+name:           unimap
+version:        0.1.0
+synopsis:       A union-find/map data structure
+description:    Please see the README on GitHub at <https://github.com/ejconlon/unimap#readme>
+homepage:       https://github.com/ejconlon/unimap#readme
+bug-reports:    https://github.com/ejconlon/unimap/issues
+author:         Eric Conlon
+maintainer:     ejconlon@gmail.com
+copyright:      (c) 2024 Eric Conlon
+license:        BSD3
+build-type:     Simple
+tested-with:
+    GHC == 9.8.4
+
+source-repository head
+  type: git
+  location: https://github.com/ejconlon/unimap
+
+library
+  exposed-modules:
+      Unimap
+  other-modules:
+      Paths_unimap
+  hs-source-dirs:
+      src
+  default-extensions:
+      BangPatterns
+      ConstraintKinds
+      DataKinds
+      DeriveFunctor
+      DeriveFoldable
+      DeriveGeneric
+      DeriveTraversable
+      DerivingStrategies
+      DerivingVia
+      FlexibleContexts
+      FlexibleInstances
+      FunctionalDependencies
+      GADTs
+      GeneralizedNewtypeDeriving
+      ImportQualifiedPost
+      LambdaCase
+      KindSignatures
+      MultiParamTypeClasses
+      MultiWayIf
+      PatternSynonyms
+      Rank2Types
+      ScopedTypeVariables
+      StandaloneDeriving
+      StandaloneKindSignatures
+      TupleSections
+      TypeApplications
+      TypeOperators
+      TypeFamilies
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds
+  build-depends:
+      base >=4.12 && <5
+    , int-like >=0.1.4 && <0.2
+    , mtl ==2.3.*
+    , optics ==0.4.*
+  default-language: GHC2021
+
+test-suite unimap-test
+  type: exitcode-stdio-1.0
+  main-is: Main.hs
+  other-modules:
+      Paths_unimap
+  hs-source-dirs:
+      test
+  default-extensions:
+      BangPatterns
+      ConstraintKinds
+      DataKinds
+      DeriveFunctor
+      DeriveFoldable
+      DeriveGeneric
+      DeriveTraversable
+      DerivingStrategies
+      DerivingVia
+      FlexibleContexts
+      FlexibleInstances
+      FunctionalDependencies
+      GADTs
+      GeneralizedNewtypeDeriving
+      ImportQualifiedPost
+      LambdaCase
+      KindSignatures
+      MultiParamTypeClasses
+      MultiWayIf
+      PatternSynonyms
+      Rank2Types
+      ScopedTypeVariables
+      StandaloneDeriving
+      StandaloneKindSignatures
+      TupleSections
+      TypeApplications
+      TypeOperators
+      TypeFamilies
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.12 && <5
+    , int-like >=0.1.4 && <0.2
+    , mtl ==2.3.*
+    , optics ==0.4.*
+    , prop-unit >=0.1.4 && <0.2
+    , unimap
+  default-language: GHC2021