{-# LANGUAGE DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-}

-------------------------------------------------------------------------------------
-- |
-- Copyright   : (c) Hans Hoglund 2012
--
-- License     : BSD-style
--
-- Maintainer  : hans@hanshoglund.se
-- Stability   : experimental
-- Portability : non-portable (TF,GNTD)
--
-- Partial maps and filters over 'MonadPlus' instances. The basic idea here is that
-- the monad interface together with the monoidal structure of 'MonadPlus' is enough
-- to implement partial maps and filters (i.e. 'mmapMaybe' and 'mfilter').
--
-- This is especially useful for sequential structures such as event lists, tracks etc.
--
-- Inspired by the following blog post:
--
--    * <http://conal.net/blog/posts/a-handy-generalized-filter>
--
-------------------------------------------------------------------------------------

module Control.Monad.Plus (
        -- * Basics
        module Control.Monad,
        Monad.msum,
        msum',      
        
        -- * Constructing
        mfold,
        mfromList,
        mfromMaybe,
        mreturn,

        -- * Filtering
        -- mfilter,
        mpartition,

        -- ** Special filters
        mscatter,
        mscatter',
        mcatMaybes,
        mlefts,
        mrights,
        mpartitionEithers,

        -- * Special maps
        mmapMaybe,
        mconcatMap,
        mconcatMap',
        
        -- * Utility
        Partial(..),
        partial,
        predicate,
        always,
        never,
  ) where

import Control.Monad hiding (msum)
import Control.Applicative                   
import Control.Category (Category)
import qualified Control.Category as Category
import Data.Semigroup as Sem
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

-- |
-- This generalizes the list-based 'concat' function. 
-- 
msum' :: (MonadPlus m, Foldable t) => t (m a) -> m a
msum' :: forall (m :: * -> *) (t :: * -> *) a.
(MonadPlus m, Foldable t) =>
t (m a) -> m a
msum' = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
Foldable.msum

-- | 
-- Fold a value into an arbitrary 'MonadPlus' type.
-- 
-- This function generalizes the 'toList' function.
-- 
mfold :: (MonadPlus m, Foldable t) => t a -> m a
mfold :: forall (m :: * -> *) (t :: * -> *) a.
(MonadPlus m, Foldable t) =>
t a -> m a
mfold = forall (m :: * -> *) a. MonadPlus m => [a] -> m a
mfromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList

-- | 
-- Translate a list to an arbitrary 'MonadPlus' type.
--
-- This function generalizes the 'listToMaybe' function.
-- 
mfromList :: MonadPlus m => [a] -> m a
mfromList :: forall (m :: * -> *) a. MonadPlus m => [a] -> m a
mfromList = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
Monad.msum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. Monad m => a -> m a
return

-- | 
-- Translate maybe to an arbitrary 'MonadPlus' type.
-- 
-- This function generalizes the 'maybeToList' function.
-- 
mfromMaybe :: MonadPlus m => Maybe a -> m a
mfromMaybe :: forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
mfromMaybe = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadPlus m => m a
mzero forall (m :: * -> *) a. Monad m => a -> m a
return

-- | 
-- Convert a partial function to a function returning an arbitrary
-- 'MonadPlus' type.
-- 
mreturn :: MonadPlus m => (a -> Maybe b) -> a -> m b
mreturn :: forall (m :: * -> *) a b. MonadPlus m => (a -> Maybe b) -> a -> m b
mreturn a -> Maybe b
f = forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
mfromMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
f

-- | 
-- The 'partition' function takes a predicate a list and returns
-- the pair of lists of elements which do and do not satisfy the
-- predicate, respectively; i.e.,
--
-- > partition p xs == (filter p xs, filter (not . p) xs)
--
-- This function generalizes the 'partition' function.
-- 
mpartition :: MonadPlus m => (a -> Bool) -> m a -> (m a, m a)
mpartition :: forall (m :: * -> *) a.
MonadPlus m =>
(a -> Bool) -> m a -> (m a, m a)
mpartition a -> Bool
p m a
a = (forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter a -> Bool
p m a
a, forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p) m a
a)

-- | 
-- Pass through @Just@ elements.
-- 
-- This function generalizes the 'catMaybes' function.
-- 
mcatMaybes :: MonadPlus m => m (Maybe a) -> m a
mcatMaybes :: forall (m :: * -> *) a. MonadPlus m => m (Maybe a) -> m a
mcatMaybes = (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
mfromMaybe)

-- | 
-- Join list elements together.
-- 
-- This function generalizes the 'catMaybes' function.
-- 
mscatter :: MonadPlus m => m [b] -> m b
mscatter :: forall (m :: * -> *) b. MonadPlus m => m [b] -> m b
mscatter = (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadPlus m => [a] -> m a
mfromList)

-- | 
-- Join foldable elements together.
-- 
-- This function generalizes the 'catMaybes' function.
-- 
mscatter' :: (MonadPlus m, Foldable t) => m (t b) -> m b
mscatter' :: forall (m :: * -> *) (t :: * -> *) b.
(MonadPlus m, Foldable t) =>
m (t b) -> m b
mscatter' = (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) (t :: * -> *) a.
(MonadPlus m, Foldable t) =>
t a -> m a
mfold)

-- | 
-- Pass through @Left@ elements.
-- 
-- This function generalizes the 'lefts' function.
-- 
mlefts :: MonadPlus m => m (Either a b) -> m a
mlefts :: forall (m :: * -> *) a b. MonadPlus m => m (Either a b) -> m a
mlefts = forall (m :: * -> *) a. MonadPlus m => m (Maybe a) -> m a
mcatMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall {a} {b}. Either a b -> Maybe a
l
    where
        l :: Either a b -> Maybe a
l (Left a
a)  = forall a. a -> Maybe a
Just a
a
        l (Right b
a) = forall a. Maybe a
Nothing

-- | 
-- Pass through @Right@ elements.
-- 
-- This function generalizes the 'rights' function.
-- 
mrights :: MonadPlus m => m (Either a b) -> m b
mrights :: forall (m :: * -> *) a b. MonadPlus m => m (Either a b) -> m b
mrights = forall (m :: * -> *) a. MonadPlus m => m (Maybe a) -> m a
mcatMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall {a} {a}. Either a a -> Maybe a
r
    where
        r :: Either a a -> Maybe a
r (Left a
a)  = forall a. Maybe a
Nothing
        r (Right a
a) = forall a. a -> Maybe a
Just a
a

-- | 
-- Separate @Left@ and @Right@ elements.
-- 
-- This function generalizes the 'partitionEithers' function.
-- 
mpartitionEithers :: MonadPlus m => m (Either a b) -> (m a, m b)
mpartitionEithers :: forall (m :: * -> *) a b.
MonadPlus m =>
m (Either a b) -> (m a, m b)
mpartitionEithers m (Either a b)
a = (forall (m :: * -> *) a b. MonadPlus m => m (Either a b) -> m a
mlefts m (Either a b)
a, forall (m :: * -> *) a b. MonadPlus m => m (Either a b) -> m b
mrights m (Either a b)
a)


-- | 
-- Modify or discard a value.
-- 
-- This function generalizes the 'mapMaybe' function.
-- 
mmapMaybe :: MonadPlus m => (a -> Maybe b) -> m a -> m b
mmapMaybe :: forall (m :: * -> *) a b.
MonadPlus m =>
(a -> Maybe b) -> m a -> m b
mmapMaybe a -> Maybe b
f = forall (m :: * -> *) a. MonadPlus m => m (Maybe a) -> m a
mcatMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe b
f

-- | 
-- Modify, discard or spawn values.
-- 
-- This function generalizes the 'concatMap' function.
-- 
mconcatMap :: MonadPlus m => (a -> [b]) -> m a -> m b
mconcatMap :: forall (m :: * -> *) a b. MonadPlus m => (a -> [b]) -> m a -> m b
mconcatMap a -> [b]
f = forall (m :: * -> *) b. MonadPlus m => m [b] -> m b
mscatter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> [b]
f

-- | 
-- Modify, discard or spawn values.
-- 
-- This function generalizes the 'concatMap' function.
-- 
mconcatMap' :: (MonadPlus m, Foldable t) => (a -> t b) -> m a -> m b
mconcatMap' :: forall (m :: * -> *) (t :: * -> *) a b.
(MonadPlus m, Foldable t) =>
(a -> t b) -> m a -> m b
mconcatMap' a -> t b
f = forall (m :: * -> *) (t :: * -> *) b.
(MonadPlus m, Foldable t) =>
m (t b) -> m b
mscatter' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> t b
f



-- |
-- Convert a predicate to a partial function.
--
partial :: (a -> Bool) -> a -> Maybe a
partial :: forall a. (a -> Bool) -> a -> Maybe a
partial a -> Bool
p a
x = if a -> Bool
p a
x then forall a. a -> Maybe a
Just a
x else forall a. Maybe a
Nothing

-- |
-- Convert a partial function to a predicate.
--
predicate :: (a -> Maybe a) -> a -> Bool
predicate :: forall a. (a -> Maybe a) -> a -> Bool
predicate a -> Maybe a
f a
x = case a -> Maybe a
f a
x of
    Just a
_  -> Bool
True
    Maybe a
Nothing -> Bool
False

-- |
-- Convert a total function to a partial function.
--  
always :: (a -> b) -> a -> Maybe b
always :: forall a b. (a -> b) -> a -> Maybe b
always a -> b
f = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

-- |
-- Make a partial function that always rejects its input.
--  
never :: a -> Maybe c
never :: forall a c. a -> Maybe c
never = forall a b. a -> b -> a
const forall a. Maybe a
Nothing

-- |
-- Wrapper for partial functions with 'MonadPlus' instance.
--
newtype Partial a b = Partial { forall a b. Partial a b -> a -> Maybe b
getPartial :: a -> Maybe b }
    
instance Functor (Partial r) where
    fmap :: forall a b. (a -> b) -> Partial r a -> Partial r b
fmap a -> b
f (Partial r -> Maybe a
g) = forall a b. (a -> Maybe b) -> Partial a b
Partial (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Maybe a
g)

instance Monad (Partial r) where
    return :: forall a. a -> Partial r a
return a
x = forall a b. (a -> Maybe b) -> Partial a b
Partial (\r
_ -> forall a. a -> Maybe a
Just a
x)
    Partial r -> Maybe a
f >>= :: forall a b. Partial r a -> (a -> Partial r b) -> Partial r b
>>= a -> Partial r b
k = forall a b. (a -> Maybe b) -> Partial a b
Partial forall a b. (a -> b) -> a -> b
$ \r
r -> do { a
x <- r -> Maybe a
f r
r; forall a b. Partial a b -> a -> Maybe b
getPartial (a -> Partial r b
k a
x) r
r }
    -- f >>= k = (join' . fmap k) f
        -- where
            -- join' g = Partial $ \x -> do { h <- getPartial g x; getPartial h x }

instance MonadPlus (Partial r) where
    mzero :: forall a. Partial r a
mzero = forall a b. (a -> Maybe b) -> Partial a b
Partial (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)
    Partial r -> Maybe a
f mplus :: forall a. Partial r a -> Partial r a -> Partial r a
`mplus` Partial r -> Maybe a
g = forall a b. (a -> Maybe b) -> Partial a b
Partial forall a b. (a -> b) -> a -> b
$ \r
x -> r -> Maybe a
f r
x forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` r -> Maybe a
g r
x

instance Applicative (Partial r) where
    pure :: forall a. a -> Partial r a
pure a
x = forall a b. (a -> Maybe b) -> Partial a b
Partial (\r
_ -> forall a. a -> Maybe a
Just a
x)
    Partial r -> Maybe (a -> b)
f <*> :: forall a b. Partial r (a -> b) -> Partial r a -> Partial r b
<*> Partial r -> Maybe a
g = forall a b. (a -> Maybe b) -> Partial a b
Partial forall a b. (a -> b) -> a -> b
$ \r
x -> r -> Maybe (a -> b)
f r
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> r -> Maybe a
g r
x

instance Alternative (Partial r) where
    empty :: forall a. Partial r a
empty = forall a b. (a -> Maybe b) -> Partial a b
Partial (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)
    Partial r -> Maybe a
f <|> :: forall a. Partial r a -> Partial r a -> Partial r a
<|> Partial r -> Maybe a
g = forall a b. (a -> Maybe b) -> Partial a b
Partial forall a b. (a -> b) -> a -> b
$ \r
x -> r -> Maybe a
f r
x forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> r -> Maybe a
g r
x

instance Category Partial where
    id :: forall a. Partial a a
id  = forall a b. (a -> Maybe b) -> Partial a b
Partial (forall a b. (a -> b) -> a -> Maybe b
always forall a. a -> a
id)
    Partial b -> Maybe c
f . :: forall b c a. Partial b c -> Partial a b -> Partial a c
. Partial a -> Maybe b
g = forall a b. (a -> Maybe b) -> Partial a b
Partial forall a b. (a -> b) -> a -> b
$ \a
x -> do
        b
y <- a -> Maybe b
g a
x
        b -> Maybe c
f b
y

instance Sem.Semigroup (Partial a b) where
    <> :: Partial a b -> Partial a b -> Partial a b
(<>) = forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance Monoid (Partial a b) where
    mempty :: Partial a b
mempty  = forall (m :: * -> *) a. MonadPlus m => m a
mzero
    mappend :: Partial a b -> Partial a b -> Partial a b
mappend = forall a. Semigroup a => a -> a -> a
(<>)