Extract UnifyT into its own package and get an example going

src/Language/Bergamot/Syntax.purs

@@ -13,6 +13,9 @@ import Control.Applicative (class Applicative, pure)
 import Control.Bind (class Bind, bind, (>>=))
 import Control.MonadPlus (class MonadPlus)
 import Control.Monad.Logic.Class (class MonadLogic, msplit, interleave)
+import Control.Monad.Unify.Class (class MonadUnify, class Unifiable, class UnificationVariable, Stream(..), squash, alongside, ComparisonAction(..))
+import Control.Monad.Unify.Trans (UnifyT(..), runUnifyT)
+import Control.Monad.Logic.Trans (SFKT(..), runSFKT)
 import Data.List (List(..), (:))
 import Data.Functor (class Functor, (<$>), map)
 import Data.Eq (class Eq)
@@ -53,14 +56,6 @@ instance Traversable Expr where
 
     traverse f e = sequence (f <$> e)
 
-data Stream k = StreamCons k (Lazy (Stream k))
-
-pop :: forall k. Stream k -> Tuple k (Stream k)
-pop (StreamCons k lks) = Tuple k (force lks)
-
-class Ord k <= UnificationVariable k where
-    variables :: Stream k
-
 newtype IntVar = MkIntVar Int
 
 derive instance Eq IntVar
@@ -70,16 +65,6 @@ instance UnificationVariable IntVar where
     variables = mkVarList 0
         where mkVarList n = StreamCons (MkIntVar n) $ defer $ \_ -> mkVarList (n+1)
 
-data ComparisonAction k f
-    = Merge k k
-    | Store k (f k)
-    | Fail
-
-class (UnificationVariable k, Traversable f) <= Unifiable k f where
-    variable :: k -> f k
-    squash :: f (f k) -> f k
-    alongside :: f k -> f k -> f (ComparisonAction k f)
-
 instance UnificationVariable k => Unifiable k Expr where
     variable = Var
     squash (Var f) = f
@@ -95,93 +80,22 @@ instance UnificationVariable k => Unifiable k Expr where
           combine Nil (_:_) = (Var Fail) : Nil
           combine (x:xs) (y:ys) = alongside x y : combine xs ys
 
-class (Unifiable k f, MonadPlus m) <= MonadUnify k f m | m -> k, m -> f where
-    fresh :: m k
-    merge :: k -> k -> m Unit
-    store :: k -> f k -> m Unit
-    reify :: f k -> m (f k)
+newtype Unifier a = MkUnifier (UnifyT IntVar Expr (SFKT Maybe) a)
 
-unify :: forall k f m. MonadUnify k f m => f k -> f k -> m Unit
-unify f1 f2 =
-    do
-       _ <- traverse process $ alongside f1 f2
-       pure unit
-    where
-      process (Merge k1 k2) = merge k1 k2
-      process (Store k f) = store k f
-      process Fail = empty
+derive instance Newtype (Unifier a) _
+derive newtype instance Functor Unifier
+derive newtype instance Apply Unifier
+derive newtype instance Applicative Unifier
+derive newtype instance Alternative Unifier
+derive newtype instance Bind Unifier
+derive newtype instance Monad Unifier
+derive newtype instance MonadPlus Unifier
+derive newtype instance MonadUnify IntVar Expr Unifier
 
-type UnificationState k f =
-    { boundVariables :: Map k { equivalence :: Set k, boundTo :: Maybe (f k) }
-    , currentVariables :: Stream k
-    }
+-- >:(
+instance MonadLogic Unifier where
+    msplit m = MkUnifier $ MkUnifyT $ map (map (rmap (MkUnifier <<< MkUnifyT))) $ msplit $ un MkUnifyT $ un MkUnifier m
+    interleave = over2 MkUnifier (over2 MkUnifyT interleave)
 
-newtype UnifyT k f m a = MkUnifyT (StateT (UnificationState k f) m a)
-
-derive instance Newtype (UnifyT k f m a) _
-derive instance Functor m => Functor (UnifyT k f m)
-
-instance Monad m => Apply (UnifyT k f m) where
-    apply m1 m2 = MkUnifyT $ apply (un MkUnifyT m1) (un MkUnifyT m2)
-
-instance Monad m => Applicative (UnifyT k f m) where
-    pure a = MkUnifyT $ pure a
-
-instance Monad m => Bind (UnifyT k f m) where
-    bind m f = MkUnifyT $ (un MkUnifyT m) >>= (un MkUnifyT <<< f)
-
-instance Monad m => Monad (UnifyT k f m)
-
-instance (Monad m, Alt m) => Alt (UnifyT k f m) where
-    alt = over2 MkUnifyT alt
-
-instance (Monad m, Plus m) => Plus (UnifyT k f m) where
-    empty = MkUnifyT empty
-
-instance (Monad m, Alternative m) => Alternative (UnifyT k f m)
-instance (MonadPlus m) => MonadPlus (UnifyT k f m)
-
-instance MonadLogic m => MonadLogic (UnifyT k f m) where
-    msplit m = MkUnifyT $ map (map (rmap MkUnifyT)) $ msplit $ un MkUnifyT m
-    interleave m1 m2 = over2 MkUnifyT interleave m1 m2
-
-instance (Unifiable k f, MonadPlus m) => MonadUnify k f (UnifyT k f m) where
-    fresh = MkUnifyT $ do
-        Tuple k restVariables <- gets (pop <<< _.currentVariables)
-        _ <- modify $ _ { currentVariables = restVariables }
-        pure k
-    merge k1 k2 = do
-        boundVariables <- MkUnifyT $ gets _.boundVariables
-        let
-            equivalence k = fromMaybe (singleton k) (_.equivalence <$> lookup k boundVariables)
-            boundTo k = lookup k boundVariables >>= _.boundTo
-            fullSet = equivalence k1 `union` equivalence k2
-        newTerm <-
-            case boundTo k1 /\ boundTo k2 of
-                Just t1 /\ Just t2 -> unify t1 t2 >>= const (Just <$> reify t1)
-                Just t1 /\ Nothing -> pure $ Just t1
-                Nothing /\ Just t2 -> pure $ Just t2
-                Nothing /\ Nothing -> pure $ Nothing
-        let newMapValue = {equivalence: fullSet, boundTo: newTerm}
-        _ <- MkUnifyT $ modify $ _ { boundVariables = foldr (flip insert newMapValue) boundVariables fullSet }
-        pure unit
-    store k f = do
-        boundVariables <- MkUnifyT $ gets _.boundVariables
-        let fullSet = fromMaybe (singleton k) (_.equivalence <$> lookup k boundVariables)
-        let anyBound = any (isJust <<< (_>>=(_.boundTo)) <<< (flip lookup boundVariables)) fullSet
-        if anyBound
-            then empty
-            else do
-                let newMapValue = {equivalence: fullSet, boundTo: Just f}
-                _ <- MkUnifyT $ modify $ _ { boundVariables = foldr (flip insert newMapValue) boundVariables fullSet }
-                pure unit
-    reify f =
-        MkUnifyT $ do
-            boundVariables <- gets _.boundVariables
-            let
-                reify' f' = squash $ process <$> f'
-                process k = fromMaybe (variable k) (reify' <$> (lookup k boundVariables >>= _.boundTo))
-            pure $ reify' f
-
-runUnifyT :: forall k f m a. Monad m => UnificationVariable k => UnifyT k f m a -> m a
-runUnifyT m = fst <$> runStateT (un MkUnifyT m) { boundVariables: Map.empty, currentVariables: variables }
+runUnifier :: forall a. Unifier a -> Maybe a
+runUnifier m = runSFKT (runUnifyT $ un MkUnifier m) (const <<< Just) Nothing