diff --git a/src/Control/Monad/Logic/Trans.purs b/src/Control/Monad/Logic/Trans.purs index 53ecf2b..763441a 100644 --- a/src/Control/Monad/Logic/Trans.purs +++ b/src/Control/Monad/Logic/Trans.purs @@ -7,7 +7,9 @@ import Control.MonadPlus (class MonadPlus, class Alternative, class Alt, class P 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,28 @@ 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) 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 +55,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 +66,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