{-# LANGUAGE ConstraintKinds #-}

-- | Extra functions for "Control.Monad".
--   These functions provide looping, list operations and booleans.
--   If you need a wider selection of monad loops and list generalisations,
--   see <https://hackage.haskell.org/package/monad-loops monad-loops>.
module Control.Monad.Extra(
    module Control.Monad,
    whenJust, whenJustM,
    pureIf,
    whenMaybe, whenMaybeM,
    unit,
    maybeM, fromMaybeM, eitherM,
    -- * Loops
    loop, loopM, whileM, whileJustM, untilJustM,
    -- * Lists
    partitionM, concatMapM, concatForM, mconcatMapM, mapMaybeM, findM, firstJustM,
    fold1M, fold1M_,
    -- * Booleans
    whenM, unlessM, ifM, notM, (||^), (&&^), orM, andM, anyM, allM
    ) where

import Control.Monad
import Control.Exception.Extra
import Data.Maybe
import Control.Applicative
import Data.Monoid
import Prelude

-- General utilities

-- | Perform some operation on 'Just', given the field inside the 'Just'.
--   This is a specialized 'Data.Foldable.for_'.
--
-- > whenJust Nothing  print == pure ()
-- > whenJust (Just 1) print == print 1
whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
whenJust :: forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe a
mg a -> m ()
f = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) a -> m ()
f Maybe a
mg

-- | Like 'whenJust', but where the test can be monadic.
whenJustM :: Monad m => m (Maybe a) -> (a -> m ()) -> m ()
-- Can't reuse whenMaybe on GHC 7.8 or lower because Monad does not imply Applicative
whenJustM :: forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM m (Maybe a)
mg a -> m ()
f = forall (m :: * -> *) b a.
Monad m =>
m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) a -> m ()
f m (Maybe a)
mg

-- | Return either a `pure` value if a condition is `True`, otherwise `empty`.
--
-- > pureIf @Maybe True  5 == Just 5
-- > pureIf @Maybe False 5 == Nothing
-- > pureIf @[]    True  5 == [5]
-- > pureIf @[]    False 5 == []
pureIf :: (Alternative m) => Bool -> a -> m a
pureIf :: forall (m :: * -> *) a. Alternative m => Bool -> a -> m a
pureIf Bool
b a
a = if Bool
b then forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a else forall (f :: * -> *) a. Alternative f => f a
empty

-- | Like 'when', but return either 'Nothing' if the predicate was 'False',
--   of 'Just' with the result of the computation.
--
-- > whenMaybe True  (print 1) == fmap Just (print 1)
-- > whenMaybe False (print 1) == pure Nothing
whenMaybe :: Applicative m => Bool -> m a -> m (Maybe a)
whenMaybe :: forall (m :: * -> *) a. Applicative m => Bool -> m a -> m (Maybe a)
whenMaybe Bool
b m a
x = if Bool
b then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
x else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- | Like 'whenMaybe', but where the test can be monadic.
whenMaybeM :: Monad m => m Bool -> m a -> m (Maybe a)
-- Can't reuse whenMaybe on GHC 7.8 or lower because Monad does not imply Applicative
whenMaybeM :: forall (m :: * -> *) a. Monad m => m Bool -> m a -> m (Maybe a)
whenMaybeM m Bool
mb m a
x = do
    Bool
b <- m Bool
mb
    if Bool
b then forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just m a
x else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- | The identity function which requires the inner argument to be @()@. Useful for functions
--   with overloaded return types.
--
-- > \(x :: Maybe ()) -> unit x == x
unit :: m () -> m ()
unit :: forall (m :: * -> *). m () -> m ()
unit = forall a. a -> a
id


-- | Monadic generalisation of 'maybe'.
maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM :: forall (m :: * -> *) b a.
Monad m =>
m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM m b
n a -> m b
j m (Maybe a)
x = forall b a. b -> (a -> b) -> Maybe a -> b
maybe m b
n a -> m b
j forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Maybe a)
x


-- | Monadic generalisation of 'fromMaybe'.
fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a
fromMaybeM :: forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
fromMaybeM m a
n m (Maybe a)
x = forall (m :: * -> *) b a.
Monad m =>
m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM m a
n forall (f :: * -> *) a. Applicative f => a -> f a
pure m (Maybe a)
x


-- | Monadic generalisation of 'either'.
eitherM :: Monad m => (a -> m c) -> (b -> m c) -> m (Either a b) -> m c
eitherM :: forall (m :: * -> *) a c b.
Monad m =>
(a -> m c) -> (b -> m c) -> m (Either a b) -> m c
eitherM a -> m c
l b -> m c
r m (Either a b)
x = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> m c
l b -> m c
r forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Either a b)
x

-- | A variant of 'foldM' that has no base case, and thus may only be applied to non-empty lists.
--
-- > fold1M (\x y -> Just x) [] == undefined
-- > fold1M (\x y -> Just $ x + y) [1, 2, 3] == Just 6
fold1M :: (Partial, Monad m) => (a -> a -> m a) -> [a] -> m a
fold1M :: forall (m :: * -> *) a.
(Partial, Monad m) =>
(a -> a -> m a) -> [a] -> m a
fold1M a -> a -> m a
f (a
x:[a]
xs) = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM a -> a -> m a
f a
x [a]
xs
fold1M a -> a -> m a
f [a]
xs = forall a. Partial => [Char] -> a
error [Char]
"fold1M: empty list"

-- | Like 'fold1M' but discards the result.
fold1M_ :: (Partial, Monad m) => (a -> a -> m a) -> [a] -> m ()
fold1M_ :: forall (m :: * -> *) a.
(Partial, Monad m) =>
(a -> a -> m a) -> [a] -> m ()
fold1M_ a -> a -> m a
f [a]
xs = forall (m :: * -> *) a.
(Partial, Monad m) =>
(a -> a -> m a) -> [a] -> m a
fold1M a -> a -> m a
f [a]
xs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- Data.List for Monad

-- | A version of 'partition' that works with a monadic predicate.
--
-- > partitionM (Just . even) [1,2,3] == Just ([2], [1,3])
-- > partitionM (const Nothing) [1,2,3] == Nothing
partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM :: forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
f [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
partitionM a -> m Bool
f (a
x:[a]
xs) = do
    Bool
res <- a -> m Bool
f a
x
    ([a]
as,[a]
bs) <- forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
f [a]
xs
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a
x | Bool
res]forall a. [a] -> [a] -> [a]
++[a]
as, [a
x | Bool -> Bool
not Bool
res]forall a. [a] -> [a] -> [a]
++[a]
bs)


-- | A version of 'concatMap' that works with a monadic predicate.
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
{-# INLINE concatMapM #-}
concatMapM :: forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM a -> m [b]
op = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> m [b] -> m [b]
f (forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
    where f :: a -> m [b] -> m [b]
f a
x m [b]
xs = do [b]
x <- a -> m [b]
op a
x; if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [b]
x then m [b]
xs else do [b]
xs <- m [b]
xs; forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [b]
xforall a. [a] -> [a] -> [a]
++[b]
xs

-- | Like 'concatMapM', but has its arguments flipped, so can be used
--   instead of the common @fmap concat $ forM@ pattern.
concatForM :: Monad m => [a] -> (a -> m [b]) -> m [b]
concatForM :: forall (m :: * -> *) a b. Monad m => [a] -> (a -> m [b]) -> m [b]
concatForM = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM

-- | A version of 'mconcatMap' that works with a monadic predicate.
mconcatMapM :: (Monad m, Monoid b) => (a -> m b) -> [a] -> m b
mconcatMapM :: forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
mconcatMapM a -> m b
f = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m b
f

-- | A version of 'mapMaybe' that works with a monadic predicate.
mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
{-# INLINE mapMaybeM #-}
mapMaybeM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM a -> m (Maybe b)
op = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> m [b] -> m [b]
f (forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
    where f :: a -> m [b] -> m [b]
f a
x m [b]
xs = do Maybe b
x <- a -> m (Maybe b)
op a
x; case Maybe b
x of Maybe b
Nothing -> m [b]
xs; Just b
x -> do [b]
xs <- m [b]
xs; forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ b
xforall a. a -> [a] -> [a]
:[b]
xs

-- Looping

-- | A looping operation, where the predicate returns 'Left' as a seed for the next loop
--   or 'Right' to abort the loop.
--
-- > loop (\x -> if x < 10 then Left $ x * 2 else Right $ show x) 1 == "16"
loop :: (a -> Either a b) -> a -> b
loop :: forall a b. (a -> Either a b) -> a -> b
loop a -> Either a b
act a
x = case a -> Either a b
act a
x of
    Left a
x -> forall a b. (a -> Either a b) -> a -> b
loop a -> Either a b
act a
x
    Right b
v -> b
v

-- | A monadic version of 'loop', where the predicate returns 'Left' as a seed for the next loop
--   or 'Right' to abort the loop.
loopM :: Monad m => (a -> m (Either a b)) -> a -> m b
loopM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m (Either a b)) -> a -> m b
loopM a -> m (Either a b)
act a
x = do
    Either a b
res <- a -> m (Either a b)
act a
x
    case Either a b
res of
        Left a
x -> forall (m :: * -> *) a b.
Monad m =>
(a -> m (Either a b)) -> a -> m b
loopM a -> m (Either a b)
act a
x
        Right b
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure b
v

-- | Keep running an operation until it becomes 'False'. As an example:
--
-- @
-- whileM $ do sleep 0.1; notM $ doesFileExist "foo.txt"
-- readFile "foo.txt"
-- @
--
--   If you need some state persisted between each test, use 'loopM'.
whileM :: Monad m => m Bool -> m ()
whileM :: forall (m :: * -> *). Monad m => m Bool -> m ()
whileM m Bool
act = do
    Bool
b <- m Bool
act
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => m Bool -> m ()
whileM m Bool
act

-- | Keep running an operation until it becomes a 'Nothing', accumulating the
--   monoid results inside the 'Just's as the result of the overall loop.
whileJustM :: (Monad m, Monoid a) => m (Maybe a) -> m a
whileJustM :: forall (m :: * -> *) a. (Monad m, Monoid a) => m (Maybe a) -> m a
whileJustM m (Maybe a)
act = a -> m a
go forall a. Monoid a => a
mempty
  where
    go :: a -> m a
go a
accum = do
        Maybe a
res <- m (Maybe a)
act
        case Maybe a
res of
            Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
accum
            Just a
r -> a -> m a
go forall a b. (a -> b) -> a -> b
$! (a
accum forall a. Semigroup a => a -> a -> a
<> a
r) -- strict apply, otherwise space leaks

-- | Keep running an operation until it becomes a 'Just', then return the value
--   inside the 'Just' as the result of the overall loop.
untilJustM :: Monad m => m (Maybe a) -> m a
untilJustM :: forall (m :: * -> *) a. Monad m => m (Maybe a) -> m a
untilJustM m (Maybe a)
act = do
    Maybe a
res <- m (Maybe a)
act
    case Maybe a
res of
        Just a
r  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r
        Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => m (Maybe a) -> m a
untilJustM m (Maybe a)
act

-- Booleans

-- | Like 'when', but where the test can be monadic.
whenM :: Monad m => m Bool -> m () -> m ()
whenM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
b m ()
t = forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
b m ()
t (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Like 'unless', but where the test can be monadic.
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM m Bool
b m ()
f = forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
b (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) m ()
f

-- | Like @if@, but where the test can be monadic.
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM :: forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
b m a
t m a
f = do Bool
b <- m Bool
b; if Bool
b then m a
t else m a
f

-- | Like 'not', but where the test can be monadic.
notM :: Functor m => m Bool -> m Bool
notM :: forall (m :: * -> *). Functor m => m Bool -> m Bool
notM = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not

-- | The lazy '||' operator lifted to a monad. If the first
--   argument evaluates to 'True' the second argument will not
--   be evaluated.
--
-- > Just True  ||^ undefined  == Just True
-- > Just False ||^ Just True  == Just True
-- > Just False ||^ Just False == Just False
(||^) :: Monad m => m Bool -> m Bool -> m Bool
||^ :: forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
(||^) m Bool
a m Bool
b = forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
a (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) m Bool
b

-- | The lazy '&&' operator lifted to a monad. If the first
--   argument evaluates to 'False' the second argument will not
--   be evaluated.
--
-- > Just False &&^ undefined  == Just False
-- > Just True  &&^ Just True  == Just True
-- > Just True  &&^ Just False == Just False
(&&^) :: Monad m => m Bool -> m Bool -> m Bool
&&^ :: forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
(&&^) m Bool
a m Bool
b = forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
a m Bool
b (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)

-- | A version of 'any' lifted to a monad. Retains the short-circuiting behaviour.
--
-- > anyM Just [False,True ,undefined] == Just True
-- > anyM Just [False,False,undefined] == undefined
-- > \(f :: Int -> Maybe Bool) xs -> anyM f xs == orM (map f xs)
anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
anyM :: forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
anyM a -> m Bool
p = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
(||^) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m Bool
p) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)

-- | A version of 'all' lifted to a monad. Retains the short-circuiting behaviour.
--
-- > allM Just [True,False,undefined] == Just False
-- > allM Just [True,True ,undefined] == undefined
-- > \(f :: Int -> Maybe Bool) xs -> anyM f xs == orM (map f xs)
allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
allM :: forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM a -> m Bool
p = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
(&&^) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m Bool
p) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)

-- | A version of 'or' lifted to a monad. Retains the short-circuiting behaviour.
--
-- > orM [Just False,Just True ,undefined] == Just True
-- > orM [Just False,Just False,undefined] == undefined
-- > \xs -> Just (or xs) == orM (map Just xs)
orM :: Monad m => [m Bool] -> m Bool
orM :: forall (m :: * -> *). Monad m => [m Bool] -> m Bool
orM = forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
anyM forall a. a -> a
id

-- | A version of 'and' lifted to a monad. Retains the short-circuiting behaviour.
--
-- > andM [Just True,Just False,undefined] == Just False
-- > andM [Just True,Just True ,undefined] == undefined
-- > \xs -> Just (and xs) == andM (map Just xs)
andM :: Monad m => [m Bool] -> m Bool
andM :: forall (m :: * -> *). Monad m => [m Bool] -> m Bool
andM = forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM forall a. a -> a
id

-- Searching

-- | Like 'find', but where the test can be monadic.
--
-- > findM (Just . isUpper) "teST"             == Just (Just 'S')
-- > findM (Just . isUpper) "test"             == Just Nothing
-- > findM (Just . const True) ["x",undefined] == Just (Just "x")
findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
findM :: forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM a -> m Bool
p = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x -> forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (a -> m Bool
p a
x) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x)) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)

-- | Like 'findM', but also allows you to compute some additional information in the predicate.
firstJustM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM a -> m (Maybe b)
p [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
firstJustM a -> m (Maybe b)
p (a
x:[a]
xs) = forall (m :: * -> *) b a.
Monad m =>
m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM (forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM a -> m (Maybe b)
p [a]
xs) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) (a -> m (Maybe b)
p a
x)