Manually uncurry the success continuation (?)
This commit is contained in:
parent
3fe4f60542
commit
880ade17dc
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue