Everything-I-Know-About-Types
/
logict
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Change runSFKT to report all results of execution

This commit is contained in:
Danila Fedorin 2023-03-04 15:14:14 -08:00
parent 24298710fa
commit f1792e6627
1 changed files with 13 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
src/Control/Monad/Logic/Trans.purs
View File

@ -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.Reader.Class (class MonadReader, local, class MonadAsk, ask)
import Control.Monad.State.Class (class MonadState, state) import Control.Monad.State.Class (class MonadState, state)
import Control.Monad.Trans.Class (class MonadTrans, lift) import Control.Monad.Trans.Class (class MonadTrans, lift)
import Data.Functor (map)
import Data.Tuple.Nested ((/\)) import Data.Tuple.Nested ((/\))
import Data.List (List(Nil), (:))
import Data.Maybe (Maybe(..)) import Data.Maybe (Maybe(..))
type FK :: Type -> Type type FK :: Type -> Type
@ -19,25 +21,28 @@ type SK ans a = a -> 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)
runSFKT :: forall a m. SFKT m a -> 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
runSFKT (SFKT f) = f 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 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 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 instance Applicative m => Applicative (SFKT m) where
pure a = SFKT (\sk fk -> sk a fk) pure a = SFKT (\sk fk -> sk a fk)
instance Bind m => Bind (SFKT m) where 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 Monad m => Monad (SFKT m)
instance Alt (SFKT m) where 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 instance Plus (SFKT m) where
empty = SFKT (\_ fk -> fk) empty = SFKT (\_ fk -> fk)
@ -50,7 +55,7 @@ instance MonadTrans SFKT where
lift m = SFKT (\sk fk -> m >>= (\a -> sk a fk)) lift m = SFKT (\sk fk -> m >>= (\a -> sk a fk))
instance Monad m => MonadLogic (SFKT m) where 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 interleave m1 m2 = do
r <- msplit m1 r <- msplit m1
case r of case r of
@ -61,7 +66,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 -> 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 instance MonadState s m => MonadState s (SFKT m) where
state f = lift $ state f state f = lift $ state f