Manually uncurry the success continuation (?)

This commit is contained in:
Danila Fedorin 2023-03-12 22:17:00 -07:00
parent 3fe4f60542
commit 880ade17dc
1 changed files with 14 additions and 14 deletions

View File

@ -1,6 +1,6 @@
module Control.Monad.Logic.Trans (SFKT(..), FK, SK, unSFKT, 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, ($), (<<<), (>>=), const, Unit, unit) import Prelude (class Applicative, class Apply, class Bind, class Functor, class Monad, bind, pure, ($), (<<<), (>>=), Unit, unit)
import Control.Monad.Logic.Class import Control.Monad.Logic.Class
import Control.Lazy (class Lazy) import Control.Lazy (class Lazy)
@ -18,7 +18,7 @@ type FK :: Type -> Type
type FK ans = Unit -> ans type FK ans = Unit -> ans
type SK :: Type -> Type -> Type 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 :: (Type -> Type) -> Type -> Type
newtype SFKT m a = SFKT (forall ans. SK (m ans) a -> FK (m ans) -> m ans) newtype SFKT m a = SFKT (forall ans. SK (m ans) a -> FK (m ans) -> m ans)
@ -27,22 +27,22 @@ unSFKT :: forall a m. SFKT m a -> forall ans. SK (m ans) a -> FK (m ans) -> m an
unSFKT (SFKT f) = f unSFKT (SFKT f) = f
runSFKTOnce :: forall a m. Alternative m => SFKT m a -> m a runSFKTOnce :: forall a m. Alternative m => SFKT m a -> m a
runSFKTOnce (SFKT f) = f (const <<< pure) (\_ -> empty) runSFKTOnce (SFKT f) = f (pure <<< _.val) (\_ -> empty)
runSFKT :: forall a m. Monad m => SFKT m a -> m (List a) runSFKT :: forall a m. Monad m => SFKT m a -> m (List a)
runSFKT (SFKT f) = f (\a fk -> map (a:_) (fk unit)) (\_ -> pure Nil) runSFKT (SFKT f) = f (\{val: a, fk} -> map (a:_) (fk unit)) (\_ -> pure Nil)
instance Functor (SFKT m) where 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 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 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 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 Monad m => Monad (SFKT m)
@ -57,11 +57,11 @@ instance Applicative m => Alternative (SFKT m)
instance Monad m => MonadPlus (SFKT m) instance Monad m => MonadPlus (SFKT m)
instance MonadTrans SFKT where 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 instance Monad m => MonadLogic (SFKT m) where
msplit ma = lift (unSFKT ma (\a fk -> pure (Just (a /\ (lazyLift 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 a fk)) where lazyLift f = SFKT (\sk fk -> f unit >>= (\a -> sk {val: a, fk: fk }))
interleave m1 m2 = do interleave m1 m2 = do
r <- msplit m1 r <- msplit m1
case r of case r of
@ -72,7 +72,7 @@ instance MonadAsk r m => MonadAsk r (SFKT m) where
ask = lift ask ask = lift ask
instance MonadReader r m => MonadReader r (SFKT m) where 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 instance MonadState s m => MonadState s (SFKT m) where
state f = lift $ state f state f = lift $ state f
@ -88,8 +88,8 @@ instance Monad m => MonadRec (SFKT m) where
go r@{sk,fk} an = go r@{sk,fk} an =
let let
(SFKT sfktf) = f an (SFKT sfktf) = f an
success st fk' = success {val: st, fk: fk'} =
case st of case st of
Loop an' -> go r an' Loop an' -> go r an'
Done b -> sk b fk' Done b -> sk {val: b, fk: fk' }
in sfktf success fk in sfktf success fk