Manually uncurry the success continuation (?)

spago.dhall

@@ -12,7 +12,14 @@ to generate this file without the comments in this block.
 -}
 { name = "logict"
 , dependencies =
-  [ "control", "lists", "maybe", "prelude", "transformers", "tuples" ]
+  [ "control"
+  , "lists"
+  , "maybe"
+  , "prelude"
+  , "tailrec"
+  , "transformers"
+  , "tuples"
+  ]
 , packages = ./packages.dhall
 , sources = [ "src/**/*.purs", "test/**/*.purs" ]
 }

src/Control/Monad/Logic/Class.purs

@@ -3,8 +3,8 @@ module Control.Monad.Logic.Class (class MonadLogic, msplit, interleave, fbind, r
 import Prelude
 
 import Control.MonadPlus (class MonadPlus, (<|>), empty)
-import Control.Monad.State (runStateT)
-import Control.Monad.State.Trans (StateT(..))
+import Control.Monad.State.Trans (StateT(..), runStateT)
+import Control.Monad.Reader.Trans (ReaderT(..), runReaderT)
 import Data.Tuple.Nested (type (/\), (/\))
 import Data.Maybe (Maybe(..))
 
@@ -31,4 +31,11 @@ instance MonadLogic m => MonadLogic (StateT s m) where
         case r of
             Nothing -> pure (Nothing /\ s)
             Just ((a /\ s') /\ m) -> pure (Just (a /\ (StateT $ const m)) /\ s')
-    interleave m1 m2 = StateT $ \s -> runStateT m1 s <|> runStateT m2 s
+    interleave m1 m2 = StateT $ \s -> runStateT m1 s `interleave` runStateT m2 s
+
+instance MonadLogic m => MonadLogic (ReaderT r m) where
+    msplit sm = ReaderT $ \r -> do
+        msplit (runReaderT sm r) >>= case _ of
+            Nothing -> pure Nothing
+            Just (a /\ m) -> pure $ Just $ a /\ (ReaderT $ const m)
+    interleave m1 m2 = ReaderT $ \r -> runReaderT m1 r `interleave` runReaderT m2 r

src/Control/Monad/Logic/Trans.purs

@@ -1,22 +1,24 @@
-module Control.Monad.Logic.Trans (SFKT, runSFKT, runSFKTOnce) where
+module Control.Monad.Logic.Trans (SFKT(..), FK, SK, unSFKT, runSFKT, runSFKTOnce) where
 
-import Prelude (class Applicative, class Apply, class Bind, class Functor, class Monad, bind, pure, ($), (<<<), (>>=))
+import Prelude (class Applicative, class Apply, class Bind, class Functor, class Monad, bind, pure, ($), (<<<), (>>=), Unit, unit)
 import Control.Monad.Logic.Class
 
+import Control.Lazy (class Lazy)
 import Control.MonadPlus (class MonadPlus, class Alternative, class Alt, class Plus, (<|>), empty)
 import Control.Monad.Reader.Class (class MonadReader, local, class MonadAsk, ask)
 import Control.Monad.State.Class (class MonadState, state)
 import Control.Monad.Trans.Class (class MonadTrans, lift)
+import Control.Monad.Rec.Class (class MonadRec, Step(..))
 import Data.Functor (map)
 import Data.Tuple.Nested ((/\))
 import Data.List (List(Nil), (:))
 import Data.Maybe (Maybe(..))
 
 type FK :: Type -> Type
-type FK ans = ans
+type FK ans = Unit -> ans
 
 type SK :: Type -> Type -> Type
-type SK ans a = a -> FK ans -> ans
+type SK ans a = { val :: a, fk :: FK ans } -> ans
 
 newtype SFKT :: (Type -> Type) -> Type -> Type
 newtype SFKT m a = SFKT (forall ans. SK (m ans) a -> FK (m ans) -> m ans)
@@ -24,41 +26,42 @@ newtype SFKT m a = SFKT (forall ans. SK (m ans) a -> FK (m ans) -> m ans)
 unSFKT :: forall a m. SFKT m a -> forall ans. SK (m ans) a -> FK (m ans) -> m ans
 unSFKT (SFKT f) = f
 
-runSFKT :: forall a m. Applicative m => SFKT m a -> m (List a)
-runSFKT (SFKT f) = f (map <<< (:)) (pure Nil)
-
 runSFKTOnce :: forall a m. Alternative m => SFKT m a -> m a
-runSFKTOnce (SFKT f) = f ((<|>) <<< pure) empty
+runSFKTOnce (SFKT f) = f (pure <<< _.val) (\_ -> empty)
+
+runSFKT :: forall a m. Monad m => SFKT m a -> m (List a)
+runSFKT (SFKT f) = f (\{val: a, fk} -> map (a:_) (fk unit)) (\_ -> pure Nil)
 
 instance Functor (SFKT m) where
-    map f m = SFKT (\sk -> unSFKT m (\a -> sk (f a)))
+    map f m = SFKT (\sk -> unSFKT m (\{val: a, fk} -> sk { val: f a, fk: fk }))
 
 instance Apply m => Apply (SFKT m) where
-    apply mf ma = SFKT (\sk -> unSFKT mf (\f -> unSFKT ma (\a -> sk (f a))))
+    apply mf ma = SFKT (\sk -> unSFKT mf (\{val: f, fk: fk} -> unSFKT ma (\{val: a, fk: fk'} -> sk { val: f a, fk: fk' }) fk))
 
 instance Applicative m => Applicative (SFKT m) where
-    pure a = SFKT (\sk fk -> sk a fk)
+    pure a = SFKT (\sk fk -> sk {val: a, fk: fk})
 
 instance Bind m => Bind (SFKT m) where
-    bind m f = SFKT (\sk -> unSFKT m (\a -> unSFKT (f a) sk))
+    bind m f = SFKT (\sk -> unSFKT m (\{val: a, fk} -> unSFKT (f a) sk fk))
 
 instance Monad m => Monad (SFKT m)
 
 instance Alt (SFKT m) where
-    alt m1 m2 = SFKT (\sk fk -> unSFKT m1 sk (unSFKT m2 sk fk))
+    alt m1 m2 = SFKT (\sk fk -> unSFKT m1 sk (\_ -> unSFKT m2 sk fk))
 
 instance Plus (SFKT m) where
-    empty = SFKT (\_ fk -> fk)
+    empty = SFKT (\_ fk -> fk unit)
 
 instance Applicative m => Alternative (SFKT m)
 
 instance Monad m => MonadPlus (SFKT m)
 
 instance MonadTrans SFKT where
-    lift m = SFKT (\sk fk -> m >>= (\a -> sk a fk))
+    lift m = SFKT (\sk fk -> m >>= (\a -> sk { val: a, fk: fk }))
 
 instance Monad m => MonadLogic (SFKT m) where
-    msplit ma = lift (unSFKT ma (\a fk -> pure (Just (a /\ (lift fk >>= reflect)))) (pure Nothing))
+    msplit ma = lift (unSFKT ma (\{val: a, fk} -> pure (Just (a /\ (lazyLift fk >>= reflect)))) (\_ -> pure Nothing))
+        where lazyLift f = SFKT (\sk fk -> f unit >>= (\a -> sk {val: a, fk: fk }))
     interleave m1 m2 = do
         r <- msplit m1
         case r of
@@ -69,7 +72,24 @@ instance MonadAsk r m => MonadAsk r (SFKT m) where
     ask = lift ask
 
 instance MonadReader r m => MonadReader r (SFKT m) where
-    local f m = SFKT (\sk -> unSFKT m (\a -> local f <<< sk a))
+    local f m = SFKT (\sk -> unSFKT m (local f <<< sk))
 
 instance MonadState s m => MonadState s (SFKT m) where
     state f = lift $ state f
+
+instance Lazy (SFKT m a) where
+    defer f = SFKT (\sk fk -> unSFKT (f unit) sk fk)
+
+instance Monad m => MonadRec (SFKT m) where
+    tailRecM :: forall acc b. (acc -> SFKT m (Step acc b)) -> acc -> SFKT m b
+    tailRecM f a0 = SFKT \sk fk -> go {sk: sk, fk: fk} a0
+        where
+            go :: forall ans. { sk :: SK (m ans) b, fk :: FK (m ans) } -> acc -> m ans
+            go r@{sk,fk} an =
+                let
+                    (SFKT sfktf) = f an
+                    success {val: st, fk: fk'} =
+                        case st of
+                            Loop an' -> go r an'
+                            Done b -> sk {val: b, fk: fk' }
+                 in sfktf success fk

test/Main.purs

@@ -4,12 +4,11 @@ import Prelude
 
 import Control.Alternative (guard, (<|>))
 import Control.Monad.Logic.Class (class MonadLogic, interleave)
-import Control.Monad.Logic.Trans (SFKT, runSFKT)
+import Control.Monad.Logic.Trans (runSFKT)
 import Control.Monad.Reader.Class (class MonadReader)
 import Control.Monad.Reader.Trans (runReaderT, ask)
 import Control.Monad.State.Class (class MonadState)
 import Control.Monad.State.Trans (runStateT, put, get)
-import Data.List (List(..), (:))
 import Data.Maybe (Maybe)
 import Data.Tuple (fst)
 import Data.Tuple.Nested(type (/\), (/\))
@@ -26,17 +25,14 @@ test =
             newState <- get
             pure ((offset+n) /\ (oldState <> " became " <> newState))
 
-solutions :: forall a m. Monad m => SFKT m a -> m (List a)
-solutions m = runSFKT m ((<$>) <<< (:)) (pure Nil)
-
 order1 :: Maybe String
-order1 = show <$> (runReaderT (solutions (fst <$> runStateT (test >>= \(x /\ s) -> guard (x `mod` 2 == 1) >>= \_ -> pure (x /\ s)) "initial")) 11)
+order1 = show <$> (runReaderT (runSFKT (fst <$> runStateT (test >>= \(x /\ s) -> guard (x `mod` 2 == 1) >>= \_ -> pure (x /\ s)) "initial")) 11)
 
 order2 :: Maybe String
-order2 = show <$> fst <$> (runStateT (runReaderT (solutions (test >>= \(x /\ s) -> guard (x `mod` 2 == 1) >>= \_ -> pure (x /\ s))) 11) "initial")
+order2 = show <$> fst <$> (runStateT (runReaderT (runSFKT (test >>= \(x /\ s) -> guard (x `mod` 2 == 1) >>= \_ -> pure (x /\ s))) 11) "initial")
 
 order3 :: Maybe String
-order3 = show <$> fst <$> (runStateT (runReaderT (solutions test) 0) "initial")
+order3 = show <$> fst <$> (runStateT (runReaderT (runSFKT test) 0) "initial")
 
 main :: Maybe String
 main = order1