logict/src/Control/Monad/Logic/Class.purs

42 lines
1.5 KiB
Plaintext

module Control.Monad.Logic.Class (class MonadLogic, msplit, interleave, fbind, reflect, (>>-)) where
import Prelude
import Control.MonadPlus (class MonadPlus, (<|>), empty)
import Control.Monad.State.Trans (StateT(..), runStateT)
import Control.Monad.Reader.Trans (ReaderT(..), runReaderT)
import Data.Tuple.Nested (type (/\), (/\))
import Data.Maybe (Maybe(..))
class (MonadPlus m) <= MonadLogic m where
msplit :: forall a. m a -> m (Maybe (a /\ (m a)))
interleave :: forall a. m a -> m a -> m a
fbind :: forall a b m. MonadLogic m => m a -> (a -> m b) -> m b
fbind m f = do
r <- msplit m
case r of
Nothing -> empty
Just (a /\ m') -> interleave (f a) (m' `fbind` f)
reflect :: forall a m. MonadLogic m => Maybe (a /\ m a) -> m a
reflect Nothing = empty
reflect (Just (a /\ ma)) = pure a <|> ma
infixl 1 fbind as >>-
instance MonadLogic m => MonadLogic (StateT s m) where
msplit sm = StateT $ \s -> do
r <- msplit (runStateT sm s)
case r of
Nothing -> pure (Nothing /\ s)
Just ((a /\ s') /\ m) -> pure (Just (a /\ (StateT $ const m)) /\ s')
interleave m1 m2 = StateT $ \s -> runStateT m1 s `interleave` runStateT m2 s
instance MonadLogic m => MonadLogic (ReaderT r m) where
msplit sm = ReaderT $ \r -> do
msplit (runReaderT sm r) >>= case _ of
Nothing -> pure Nothing
Just (a /\ m) -> pure $ Just $ a /\ (ReaderT $ const m)
interleave m1 m2 = ReaderT $ \r -> runReaderT m1 r `interleave` runReaderT m2 r