{-# LANGUAGE DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-}
module Control.Monad.Plus (
module Control.Monad,
Monad.msum,
msum',
mfold,
mfromList,
mfromMaybe,
mreturn,
mpartition,
mscatter,
mscatter',
mcatMaybes,
mlefts,
mrights,
mpartitionEithers,
mmapMaybe,
mconcatMap,
mconcatMap',
Partial(..),
partial,
predicate,
always,
never,
) where
import Control.Monad hiding (msum)
import Control.Applicative
import Data.Monoid
import Data.List (partition)
import Data.Maybe (listToMaybe, maybeToList, catMaybes, mapMaybe, fromMaybe)
import Data.Either (lefts, rights, partitionEithers)
import Data.Foldable (Foldable(..), toList)
import qualified Control.Monad as Monad
import qualified Data.Foldable as Foldable
msum' :: (MonadPlus m, Foldable t) => t (m a) -> m a
msum' = Foldable.msum
mfold :: (MonadPlus m, Foldable t) => t a -> m a
mfold = mfromList . Foldable.toList
mfromList :: MonadPlus m => [a] -> m a
mfromList = Monad.msum . map return
mfromMaybe :: MonadPlus m => Maybe a -> m a
mfromMaybe = maybe mzero return
mreturn :: MonadPlus m => (a -> Maybe b) -> a -> m b
mreturn f = mfromMaybe . f
mpartition :: MonadPlus m => (a -> Bool) -> m a -> (m a, m a)
mpartition p a = (mfilter p a, mfilter (not . p) a)
mcatMaybes :: MonadPlus m => m (Maybe a) -> m a
mcatMaybes = (>>= mfromMaybe)
mscatter :: MonadPlus m => m [b] -> m b
mscatter = (>>= mfromList)
mscatter' :: (MonadPlus m, Foldable t) => m (t b) -> m b
mscatter' = (>>= mfold)
mlefts :: MonadPlus m => m (Either a b) -> m a
mlefts = mcatMaybes . liftM l
where
l (Left a) = Just a
l (Right a) = Nothing
mrights :: MonadPlus m => m (Either a b) -> m b
mrights = mcatMaybes . liftM r
where
r (Left a) = Nothing
r (Right a) = Just a
mpartitionEithers :: MonadPlus m => m (Either a b) -> (m a, m b)
mpartitionEithers a = (mlefts a, mrights a)
mmapMaybe :: MonadPlus m => (a -> Maybe b) -> m a -> m b
mmapMaybe f = mcatMaybes . liftM f
mconcatMap :: MonadPlus m => (a -> [b]) -> m a -> m b
mconcatMap f = mscatter . liftM f
mconcatMap' :: (MonadPlus m, Foldable t) => (a -> t b) -> m a -> m b
mconcatMap' f = mscatter' . liftM f
partial :: (a -> Bool) -> a -> Maybe a
partial p x = if p x then Just x else Nothing
predicate :: (a -> Maybe a) -> a -> Bool
predicate f x = case f x of
Just _ -> True
Nothing -> False
always :: (a -> b) -> a -> Maybe b
always f = Just . f
never :: a -> Maybe c
never = const Nothing
newtype Partial a b = Partial { getPartial :: a -> Maybe b }
instance Functor (Partial r) where
fmap f (Partial g) = Partial (fmap f . g)
instance Monad (Partial r) where
return x = Partial (\_ -> Just x)
Partial f >>= k = Partial $ \r -> do { x <- f r; getPartial (k x) r }
instance MonadPlus (Partial r) where
mzero = Partial (const Nothing)
Partial f `mplus` Partial g = Partial $ \x -> f x `mplus` g x
instance Applicative (Partial r) where
pure x = Partial (\_ -> Just x)
Partial f <*> Partial g = Partial $ \x -> f x <*> g x
instance Alternative (Partial r) where
empty = Partial (const Nothing)
Partial f <|> Partial g = Partial $ \x -> f x <|> g x
instance Semigroup (Partial a b) where
(<>) = mappend
instance Monoid (Partial a b) where
mempty = mzero
mappend = mplus