Add a way to only get one value out

src/Control/Monad/Logic/Trans.purs

@@ -1,13 +1,15 @@
-module Control.Monad.Logic.Trans (SFKT, runSFKT) where
+module Control.Monad.Logic.Trans (SFKT, runSFKT, runSFKTOnce) where
 
 import Prelude (class Applicative, class Apply, class Bind, class Functor, class Monad, bind, pure, ($), (<<<), (>>=))
 import Control.Monad.Logic.Class
 
-import Control.MonadPlus (class MonadPlus, class Alternative, class Alt, class Plus, (<|>))
+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 Data.Functor (map)
 import Data.Tuple.Nested ((/\))
+import Data.List (List(Nil), (:))
 import Data.Maybe (Maybe(..))
 
 type FK :: Type -> Type
@@ -19,25 +21,31 @@ type SK ans a = a -> 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)
 
-runSFKT :: forall a m. SFKT m a -> forall ans. SK (m ans) a -> FK (m ans) -> m ans
-runSFKT (SFKT f) = f
+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. MonadPlus m => SFKT m a -> m a
+runSFKTOnce (SFKT f) = f ((<|>) <<< pure) empty
 
 instance Functor (SFKT m) where
-    map f m = SFKT (\sk -> runSFKT m (\a -> sk (f a)))
+    map f m = SFKT (\sk -> unSFKT m (\a -> sk (f a)))
 
 instance Apply m => Apply (SFKT m) where
-    apply mf ma = SFKT (\sk -> runSFKT mf (\f -> runSFKT ma (\a -> sk (f a))))
+    apply mf ma = SFKT (\sk -> unSFKT mf (\f -> unSFKT ma (\a -> sk (f a))))
 
 instance Applicative m => Applicative (SFKT m) where
     pure a = SFKT (\sk fk -> sk a fk)
 
 instance Bind m => Bind (SFKT m) where
-    bind m f = SFKT (\sk -> runSFKT m (\a -> runSFKT (f a) sk))
+    bind m f = SFKT (\sk -> unSFKT m (\a -> unSFKT (f a) sk))
 
 instance Monad m => Monad (SFKT m)
 
 instance Alt (SFKT m) where
-    alt m1 m2 = SFKT (\sk fk -> runSFKT m1 sk (runSFKT 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)
@@ -50,7 +58,7 @@ instance MonadTrans SFKT where
     lift m = SFKT (\sk fk -> m >>= (\a -> sk a fk))
 
 instance Monad m => MonadLogic (SFKT m) where
-    msplit ma = lift (runSFKT ma (\a fk -> pure (Just (a /\ (lift fk >>= reflect)))) (pure Nothing))
+    msplit ma = lift (unSFKT ma (\a fk -> pure (Just (a /\ (lift fk >>= reflect)))) (pure Nothing))
     interleave m1 m2 = do
         r <- msplit m1
         case r of
@@ -61,7 +69,7 @@ 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 -> runSFKT m (\a -> local f <<< sk a))
+    local f m = SFKT (\sk -> unSFKT m (\a -> local f <<< sk a))
 
 instance MonadState s m => MonadState s (SFKT m) where
     state f = lift $ state f