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.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