{-# LANGUAGE CPP #-}

module Agda.Utils.Monad
    ( module Agda.Utils.Monad
    , module X
    , (<$>), (<*>) , (<$)
    )
    where

import Control.Monad.Except   ( MonadError(catchError, throwError), ExceptT, runExceptT )
import Control.Monad.Identity ( runIdentity )
import Control.Monad.State    ( MonadState(get, put) )
import Control.Monad.Writer   ( MonadWriter(tell), Writer, WriterT, mapWriterT )

import Data.Bifunctor         ( first, second )
import Data.Bool              ( bool )
import Data.Traversable as Trav hiding (for, sequence)
import Data.Foldable as Fold
import Data.Maybe
import Data.Monoid

import Agda.Utils.Applicative
import Agda.Utils.Boolean
import Agda.Utils.Either
import Agda.Utils.Null (empty, ifNotNullM)
import Agda.Utils.Singleton
import Agda.Utils.ExpandCase

import Agda.Utils.Impossible

-- Reexport Control.Monad
import Control.Applicative as X
  ( liftA2
  )
import Control.Monad as X
  ( MonadPlus(..), (<$!>), (>=>), (<=<)
  , filterM, foldM, forM, forM_
  , join
  , liftM2, liftM3, liftM4
  , msum
  , void
  , zipWithM, zipWithM_
  )
import Control.Monad.Trans as X
  ( MonadTrans, lift
  )


---------------------------------------------------------------------------
-- Vendor some new functions from mtl-2.3.1

#if MIN_VERSION_mtl(2,3,1)
import Control.Monad.Except as X ( tryError, withError )
#endif

#if !MIN_VERSION_mtl(2,3,1)
-- | 'MonadError' analogue to the 'Control.Exception.try' function.
tryError :: MonadError e m => m a -> m (Either e a)
tryError action = (Right <$> action) `catchError` (pure . Left)

-- | 'MonadError' analogue to the 'withExceptT' function.
-- Modify the value (but not the type) of an error.  The type is
-- fixed because of the functional dependency @m -> e@.  If you need
-- to change the type of @e@ use 'mapError' or 'modifyError'.
withError :: MonadError e m => (e -> e) -> m a -> m a
withError f action = tryError action >>= either (throwError . f) pure
#endif

---------------------------------------------------------------------------

-- | Binary bind.
(==<<) :: Monad m => (a -> b -> m c) -> (m a, m b) -> m c
a -> b -> m c
k ==<< :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m c) -> (m a, m b) -> m c
==<< (m a
ma, m b
mb) = m a
ma m a -> (a -> m c) -> m c
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ a
a -> a -> b -> m c
k a
a (b -> m c) -> m b -> m c
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m b
mb

-- | Strict `ap`
(<*!>) :: Monad m => m (a -> b) -> m a -> m b
<*!> :: forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
(<*!>) m (a -> b)
mf m a
ma = do
  f <- m (a -> b)
mf
  a <- ma
  pure $! f a
{-# INLINE (<*!>) #-}
infixl 4 <*!>

-- Conditionals and monads ------------------------------------------------

{-# SPECIALIZE when :: Monad m => Bool -> m () -> m () #-}
when :: (IsBool b, Monad m) => b -> m () -> m ()
when :: forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
when b
b m ()
m = b -> m () -> m () -> m ()
forall b. b -> b -> b -> b
forall a b. IsBool a => a -> b -> b -> b
ifThenElse b
b m ()
m (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{-# SPECIALIZE unless :: Monad m => Bool -> m () -> m () #-}
unless :: (IsBool b, Monad m) => b -> m () -> m()
unless :: forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless b
b m ()
m = b -> m () -> m () -> m ()
forall b. b -> b -> b -> b
forall a b. IsBool a => a -> b -> b -> b
ifThenElse b
b (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) m ()
m

{-# SPECIALIZE guard :: MonadPlus m => Bool -> m () #-}
guard :: (IsBool b, MonadPlus m) => b -> m ()
guard :: forall b (m :: * -> *). (IsBool b, MonadPlus m) => b -> m ()
guard b
b = b -> m () -> m () -> m ()
forall b. b -> b -> b -> b
forall a b. IsBool a => a -> b -> b -> b
ifThenElse b
b (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) m ()
forall a. m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

whenM :: Monad m => m Bool -> m () -> m ()
whenM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
c m ()
m = m Bool
c m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> m () -> m ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
`when` m ()
m)

unlessM :: Monad m => m Bool -> m () -> m ()
unlessM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM m Bool
c m ()
m = m Bool
c m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> m () -> m ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
`unless` m ()
m)

-- | Monadic guard.
guardM :: (MonadPlus m) => m Bool -> m ()
guardM :: forall (m :: * -> *). MonadPlus m => m Bool -> m ()
guardM m Bool
c = Bool -> m ()
forall b (m :: * -> *). (IsBool b, MonadPlus m) => b -> m ()
guard (Bool -> m ()) -> m Bool -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Bool
c

-- | Monadic if-then-else.
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
c m a
m m a
m' = m Bool
c m Bool -> (Bool -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> if Bool
b then m a
m else m a
m'

-- | @ifNotM mc = ifM (not <$> mc)@
ifNotM :: Monad m => m Bool -> m a -> m a -> m a
ifNotM :: forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifNotM m Bool
c = (m a -> m a -> m a) -> m a -> m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((m a -> m a -> m a) -> m a -> m a -> m a)
-> (m a -> m a -> m a) -> m a -> m a -> m a
forall a b. (a -> b) -> a -> b
$ m Bool -> m a -> m a -> m a
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
c

-- | Lazy monadic conjunction.
and2M :: Monad m => m Bool -> m Bool -> m Bool
and2M :: forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
and2M m Bool
ma m Bool
mb = m Bool -> m Bool -> m Bool -> m Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
ma m Bool
mb (Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)

andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
andM :: forall (f :: * -> *) (m :: * -> *).
(Foldable f, Monad m) =>
f (m Bool) -> m Bool
andM = (m Bool -> m Bool -> m Bool) -> m Bool -> f (m Bool) -> m Bool
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Fold.foldl' m Bool -> m Bool -> m Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
and2M (Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)

allM :: (Foldable f, Monad m) => (a -> m Bool) -> f a -> m Bool
allM :: forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Monad m) =>
(a -> m Bool) -> f a -> m Bool
allM a -> m Bool
f = (m Bool -> a -> m Bool) -> m Bool -> f a -> m Bool
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Fold.foldl' (\ m Bool
b -> m Bool -> m Bool -> m Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
and2M m Bool
b (m Bool -> m Bool) -> (a -> m Bool) -> a -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m Bool
f) (Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)

forallM :: (Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
forallM :: forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Monad m) =>
f a -> (a -> m Bool) -> m Bool
forallM f a
xs a -> m Bool
f = (m Bool -> a -> m Bool) -> m Bool -> f a -> m Bool
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Fold.foldl' (\m Bool
b -> m Bool -> m Bool -> m Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
and2M m Bool
b (m Bool -> m Bool) -> (a -> m Bool) -> a -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m Bool
f) (Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) f a
xs

-- | Lazy monadic disjunction.
or2M :: Monad m => m Bool -> m Bool -> m Bool
or2M :: forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
or2M m Bool
ma = m Bool -> m Bool -> m Bool -> m Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
ma (Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)

orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
orM :: forall (f :: * -> *) (m :: * -> *).
(Foldable f, Monad m) =>
f (m Bool) -> m Bool
orM = (m Bool -> m Bool -> m Bool) -> m Bool -> f (m Bool) -> m Bool
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Fold.foldl' m Bool -> m Bool -> m Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
or2M (Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)

anyM :: (Foldable f, Monad m) => (a -> m Bool) -> f a -> m Bool
anyM :: forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Monad m) =>
(a -> m Bool) -> f a -> m Bool
anyM a -> m Bool
f = (m Bool -> a -> m Bool) -> m Bool -> f a -> m Bool
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Fold.foldl' (\ m Bool
b -> m Bool -> m Bool -> m Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
or2M m Bool
b (m Bool -> m Bool) -> (a -> m Bool) -> a -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m Bool
f) (Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)

existsM :: (Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
existsM :: forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Monad m) =>
f a -> (a -> m Bool) -> m Bool
existsM f a
xs a -> m Bool
f = (a -> m Bool) -> f a -> m Bool
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Monad m) =>
(a -> m Bool) -> f a -> m Bool
anyM a -> m Bool
f f a
xs

-- https://hackage-content.haskell.org/package/extra-1.8/docs/src/Data.Foldable.Extra.html#findM
findM :: (Foldable f, Monad m) => (a -> m Bool) -> f a -> m (Maybe a)
findM :: forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Monad m) =>
(a -> m Bool) -> f a -> m (Maybe a)
findM a -> m Bool
p = (a -> m (Maybe a) -> m (Maybe a))
-> m (Maybe a) -> f a -> m (Maybe a)
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x -> m Bool -> m (Maybe a) -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (a -> m Bool
p a
x) (Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x)) (Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing)

-- | Lazy monadic disjunction with @Either@  truth values.
--   Returns the last error message if all fail.
altM1 :: Monad m => (a -> m (Either err b)) -> [a] -> m (Either err b)
altM1 :: forall (m :: * -> *) a err b.
Monad m =>
(a -> m (Either err b)) -> [a] -> m (Either err b)
altM1 a -> m (Either err b)
f []       = m (Either err b)
forall a. HasCallStack => a
__IMPOSSIBLE__
altM1 a -> m (Either err b)
f [a
a]      = a -> m (Either err b)
f a
a
altM1 a -> m (Either err b)
f (a
a : [a]
as) = (err -> m (Either err b))
-> (b -> m (Either err b)) -> Either err b -> m (Either err b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m (Either err b) -> err -> m (Either err b)
forall a b. a -> b -> a
const (m (Either err b) -> err -> m (Either err b))
-> m (Either err b) -> err -> m (Either err b)
forall a b. (a -> b) -> a -> b
$ (a -> m (Either err b)) -> [a] -> m (Either err b)
forall (m :: * -> *) a err b.
Monad m =>
(a -> m (Either err b)) -> [a] -> m (Either err b)
altM1 a -> m (Either err b)
f [a]
as) (Either err b -> m (Either err b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either err b -> m (Either err b))
-> (b -> Either err b) -> b -> m (Either err b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either err b
forall a b. b -> Either a b
Right) (Either err b -> m (Either err b))
-> m (Either err b) -> m (Either err b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> m (Either err b)
f a
a

-- | Lazy monadic disjunction with accumulation of errors in a monoid.
--   Errors are discarded if we succeed.
orEitherM :: (Monoid e, Monad m) => [m (Either e b)] -> m (Either e b)
orEitherM :: forall e (m :: * -> *) b.
(Monoid e, Monad m) =>
[m (Either e b)] -> m (Either e b)
orEitherM []       = Either e b -> m (Either e b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e b -> m (Either e b)) -> Either e b -> m (Either e b)
forall a b. (a -> b) -> a -> b
$ e -> Either e b
forall a b. a -> Either a b
Left e
forall a. Monoid a => a
mempty
orEitherM (m (Either e b)
m : [m (Either e b)]
ms) = m (Either e b)
-> (e -> m (Either e b)) -> (b -> m (Either e b)) -> m (Either e b)
forall (m :: * -> *) a b c.
Monad m =>
m (Either a b) -> (a -> m c) -> (b -> m c) -> m c
caseEitherM m (Either e b)
m (\e
e -> (e -> e) -> Either e b -> Either e b
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft (e
e e -> e -> e
forall a. Monoid a => a -> a -> a
`mappend`) (Either e b -> Either e b) -> m (Either e b) -> m (Either e b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [m (Either e b)] -> m (Either e b)
forall e (m :: * -> *) b.
(Monoid e, Monad m) =>
[m (Either e b)] -> m (Either e b)
orEitherM [m (Either e b)]
ms)
                                   (Either e b -> m (Either e b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e b -> m (Either e b))
-> (b -> Either e b) -> b -> m (Either e b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either e b
forall a b. b -> Either a b
Right)

-- Loops gathering results in a Monoid ------------------------------------

-- | Generalized version of @traverse_ :: Applicative m => (a -> m ()) -> [a] -> m ()@
--   Executes effects and collects results in left-to-right order.
--   Works best with left-associative monoids.
--
--   Note that there is an alternative
--
--     @mapM' f t = foldr mappend mempty <$> mapM f t@
--
--   that collects results in right-to-left order
--   (effects still left-to-right).
--   It might be preferable for right associative monoids.
mapM' :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
mapM' :: forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Applicative m, Monoid b) =>
(a -> m b) -> t a -> m b
mapM' a -> m b
f = (m b -> a -> m b) -> m b -> t a -> m b
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Fold.foldl (\ m b
mb a
a -> (b -> b -> b) -> m b -> m b -> m b
forall a b c. (a -> b -> c) -> m a -> m b -> m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 b -> b -> b
forall a. Monoid a => a -> a -> a
mappend m b
mb (a -> m b
f a
a)) (b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
forall a. Monoid a => a
mempty)

-- | Generalized version of @for_ :: Applicative m => [a] -> (a -> m ()) -> m ()@
forM' :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
forM' :: forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Applicative m, Monoid b) =>
t a -> (a -> m b) -> m b
forM' = ((a -> m b) -> t a -> m b) -> t a -> (a -> m b) -> m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> m b) -> t a -> m b
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Applicative m, Monoid b) =>
(a -> m b) -> t a -> m b
mapM'

-- Variations of Traversable

mapMM :: (Traversable t, Monad m) => (a -> m b) -> m (t a) -> m (t b)
mapMM :: forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> m (t a) -> m (t b)
mapMM a -> m b
f m (t a)
mxs = (a -> m b) -> t a -> m (t b)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
Trav.mapM a -> m b
f (t a -> m (t b)) -> m (t a) -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (t a)
mxs

forMM :: (Traversable t, Monad m) => m (t a) -> (a -> m b) -> m (t b)
forMM :: forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
m (t a) -> (a -> m b) -> m (t b)
forMM = ((a -> m b) -> m (t a) -> m (t b))
-> m (t a) -> (a -> m b) -> m (t b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> m b) -> m (t a) -> m (t b)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> m (t a) -> m (t b)
mapMM

-- Variations of Foldable

mapMM_ :: (Foldable t, Monad m) => (a -> m ()) -> m (t a) -> m ()
mapMM_ :: forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> m (t a) -> m ()
mapMM_ a -> m ()
f m (t a)
mxs = (a -> m ()) -> t a -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
Fold.mapM_ a -> m ()
f (t a -> m ()) -> m (t a) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (t a)
mxs

forMM_ :: (Foldable t, Monad m) => m (t a) -> (a -> m ()) -> m ()
forMM_ :: forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
m (t a) -> (a -> m ()) -> m ()
forMM_ = ((a -> m ()) -> m (t a) -> m ()) -> m (t a) -> (a -> m ()) -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> m ()) -> m (t a) -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> m (t a) -> m ()
mapMM_

-- Continuation monad -----------------------------------------------------

-- Andreas, 2017-04-11, issue #2543
-- The terribly useful thread function is now UNUSED.  [Sadistic laughter :)]
--
-- type Cont r a = (a -> r) -> r
--
-- -- | 'Control.Monad.mapM' for the continuation monad. Terribly useful.
-- thread :: (a -> Cont r b) -> [a] -> Cont r [b]
-- thread f [] ret = ret []
-- thread f (x:xs) ret =
--     f x $ \y -> thread f xs $ \ys -> ret (y:ys)

-- Lists and monads -------------------------------------------------------

concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM :: forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM a -> m [b]
f [a]
xs = [[b]] -> [b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[b]] -> [b]) -> m [[b]] -> m [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> m [b]) -> [a] -> m [[b]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
Trav.mapM a -> m [b]
f [a]
xs

{-# INLINE mapMGood #-}
-- | Variant of 'mapM' which gets compiled to good code, assuming that we're mapping over an actual
--   runtime list and don't intend for list fusion to fire.
mapMGood :: (Monad m, ExpandCase (m [b])) => (a -> m b) -> [a] -> m [b]
mapMGood :: forall (m :: * -> *) b a.
(Monad m, ExpandCase (m [b])) =>
(a -> m b) -> [a] -> m [b]
mapMGood a -> m b
f = [a] -> m [b]
go where
  go :: [a] -> m [b]
go [a]
as = ((m [b] -> Result (m [b])) -> Result (m [b])) -> m [b]
forall a. ExpandCase a => ((a -> Result a) -> Result a) -> a
expand \m [b] -> Result (m [b])
ret -> case [a]
as of
    []   -> m [b] -> Result (m [b])
ret (m [b] -> Result (m [b])) -> m [b] -> Result (m [b])
forall a b. (a -> b) -> a -> b
$ [b] -> m [b]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    a
a:[a]
as -> m [b] -> Result (m [b])
ret do b <- a -> m b
f a
a; bs <- go as; pure (b:bs)

{-# INLINE forMGood #-}
forMGood :: (Monad m, ExpandCase (m [b])) => [a] -> (a -> m b) -> m [b]
forMGood :: forall (m :: * -> *) b a.
(Monad m, ExpandCase (m [b])) =>
[a] -> (a -> m b) -> m [b]
forMGood = ((a -> m b) -> [a] -> m [b]) -> [a] -> (a -> m b) -> m [b]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> m b) -> [a] -> m [b]
forall (m :: * -> *) b a.
(Monad m, ExpandCase (m [b])) =>
(a -> m b) -> [a] -> m [b]
mapMGood

{-# INLINE mapMGood_ #-}
-- | Variant of 'mapM_' which gets compiled to good code, assuming that we're mapping over an actual
--   runtime list and don't intend for list fusion to fire.
mapMGood_ :: (Monad m, ExpandCase (m ())) => (a -> m ()) -> [a] -> m ()
mapMGood_ :: forall (m :: * -> *) a.
(Monad m, ExpandCase (m ())) =>
(a -> m ()) -> [a] -> m ()
mapMGood_ a -> m ()
f = [a] -> m ()
go where
  go :: [a] -> m ()
go [a]
as = ((m () -> Result (m ())) -> Result (m ())) -> m ()
forall a. ExpandCase a => ((a -> Result a) -> Result a) -> a
expand \m () -> Result (m ())
ret -> case [a]
as of
    []   -> m () -> Result (m ())
ret (m () -> Result (m ())) -> m () -> Result (m ())
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    a
a:[a]
as -> m () -> Result (m ())
ret (m () -> Result (m ())) -> m () -> Result (m ())
forall a b. (a -> b) -> a -> b
$ a -> m ()
f a
a m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [a] -> m ()
go [a]
as

{-# INLINE forMGood_ #-}
forMGood_ :: (Monad m, ExpandCase (m ())) => [a] -> (a -> m ()) -> m ()
forMGood_ :: forall (m :: * -> *) a.
(Monad m, ExpandCase (m ())) =>
[a] -> (a -> m ()) -> m ()
forMGood_ = ((a -> m ()) -> [a] -> m ()) -> [a] -> (a -> m ()) -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> m ()) -> [a] -> m ()
forall (m :: * -> *) a.
(Monad m, ExpandCase (m ())) =>
(a -> m ()) -> [a] -> m ()
mapMGood_

{-# INLINE rangeM_ #-}
-- | Performing an action for an inclusive range of 'Int'-s, counting up by one.
rangeM_ :: (Monad m, ExpandCase (m ())) => Int -> Int -> (Int -> m ()) -> m ()
rangeM_ :: forall (m :: * -> *).
(Monad m, ExpandCase (m ())) =>
Int -> Int -> (Int -> m ()) -> m ()
rangeM_ Int
lo Int
hi Int -> m ()
f = Int -> Int -> m ()
go Int
lo Int
hi where
  go :: Int -> Int -> m ()
go !Int
lo !Int
hi = ((m () -> Result (m ())) -> Result (m ())) -> m ()
forall a. ExpandCase a => ((a -> Result a) -> Result a) -> a
expand \m () -> Result (m ())
ret -> if Int
lo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
hi
    then m () -> Result (m ())
ret (m () -> Result (m ())) -> m () -> Result (m ())
forall a b. (a -> b) -> a -> b
$ Int -> m ()
f Int
lo m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Int -> m ()
go (Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
hi
    else m () -> Result (m ())
ret (m () -> Result (m ())) -> m () -> Result (m ())
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | A monadic version of @'mapMaybe' :: (a -> Maybe b) -> [a] -> [b]@.
mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM a -> m (Maybe b)
f = [a] -> m [b]
go where
  go :: [a] -> m [b]
go []     = [b] -> m [b]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  go (a
a:[a]
as) = a -> m (Maybe b)
f a
a m (Maybe b) -> (Maybe b -> m [b]) -> m [b]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe b
Nothing -> [a] -> m [b]
go [a]
as
    Just b
b  -> do {!bs <- [a] -> m [b]
go [a]
as; pure (b : bs)}
{-# INLINE mapMaybeM #-}

-- | A version of @'mapMaybeM'@ with a computation for the input list.
mapMaybeMM :: Monad m => (a -> m (Maybe b)) -> m [a] -> m [b]
mapMaybeMM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> m [a] -> m [b]
mapMaybeMM a -> m (Maybe b)
f m [a]
m = (a -> m (Maybe b)) -> [a] -> m [b]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM a -> m (Maybe b)
f ([a] -> m [b]) -> m [a] -> m [b]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m [a]
m
{-# INLINE mapMaybeMM #-}

-- | The @for@ version of 'mapMaybeM'.
forMaybeM :: Monad m => [a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM :: forall (m :: * -> *) a b.
Monad m =>
[a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM = ((a -> m (Maybe b)) -> [a] -> m [b])
-> [a] -> (a -> m (Maybe b)) -> m [b]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> m (Maybe b)) -> [a] -> m [b]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM

-- | The @for@ version of 'mapMaybeMM'.
forMaybeMM :: Monad m => m [a] -> (a -> m (Maybe b)) -> m [b]
forMaybeMM :: forall (m :: * -> *) a b.
Monad m =>
m [a] -> (a -> m (Maybe b)) -> m [b]
forMaybeMM = ((a -> m (Maybe b)) -> m [a] -> m [b])
-> m [a] -> (a -> m (Maybe b)) -> m [b]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> m (Maybe b)) -> m [a] -> m [b]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> m [a] -> m [b]
mapMaybeMM

-- | A monadic version of @'dropWhile' :: (a -> Bool) -> [a] -> [a]@.
dropWhileM :: Monad m => (a -> m Bool) -> [a] -> m [a]
dropWhileM :: forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m [a]
dropWhileM a -> m Bool
p []       = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
dropWhileM a -> m Bool
p (a
x : [a]
xs) = m Bool -> m [a] -> m [a] -> m [a]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (a -> m Bool
p a
x) ((a -> m Bool) -> [a] -> m [a]
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m [a]
dropWhileM a -> m Bool
p [a]
xs) ([a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs))

-- | A monadic version of @'dropWhileEnd' :: (a -> Bool) -> [a] -> m [a]@.
--   Effects happen starting at the end of the list until @p@ becomes false.
dropWhileEndM :: Monad m => (a -> m Bool) -> [a] -> m [a]
dropWhileEndM :: forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m [a]
dropWhileEndM a -> m Bool
p []       = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
dropWhileEndM a -> m Bool
p (a
x : [a]
xs) = m [a] -> ([a] -> m [a]) -> m [a] -> m [a]
forall (m :: * -> *) a b.
(Monad m, Null a) =>
m a -> (a -> m b) -> m b -> m b
ifNotNullM ((a -> m Bool) -> [a] -> m [a]
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m [a]
dropWhileEndM a -> m Bool
p [a]
xs) ([a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> m [a]) -> ([a] -> [a]) -> [a] -> m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) (m [a] -> m [a]) -> m [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ {-else-}
  m Bool -> m [a] -> m [a] -> m [a]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (a -> m Bool
p a
x) ([a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []) ([a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [a
x])

-- | A ``monadic'' version of @'partition' :: (a -> Bool) -> [a] -> ([a],[a])
partitionM :: (Applicative m) => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM :: forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
f =
  (a -> m ([a], [a]) -> m ([a], [a]))
-> m ([a], [a]) -> [a] -> m ([a], [a])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ a
x -> (Bool -> ([a], [a]) -> ([a], [a]))
-> m Bool -> m ([a], [a]) -> m ([a], [a])
forall a b c. (a -> b -> c) -> m a -> m b -> m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((([a], [a]) -> ([a], [a]))
-> (([a], [a]) -> ([a], [a])) -> Bool -> ([a], [a]) -> ([a], [a])
forall a. a -> a -> Bool -> a
bool (([a] -> [a]) -> ([a], [a]) -> ([a], [a])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) (([a] -> [a]) -> ([a], [a]) -> ([a], [a])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:))) (m Bool -> m ([a], [a]) -> m ([a], [a]))
-> m Bool -> m ([a], [a]) -> m ([a], [a])
forall a b. (a -> b) -> a -> b
$ a -> m Bool
f a
x)
        (([a], [a]) -> m ([a], [a])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a], [a])
forall a. Null a => a
empty)

-- MonadPlus -----------------------------------------------------------------

-- | Translates 'Maybe' to 'MonadPlus'.
fromMaybeMP :: MonadPlus m => Maybe a -> m a
fromMaybeMP :: forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
fromMaybeMP = Maybe a -> m a
forall (f :: * -> *) (t :: * -> *) a.
(Alternative f, Foldable t) =>
t a -> f a
foldA

-- | Generalises the 'catMaybes' function from lists to an arbitrary
-- 'MonadPlus'.
catMaybesMP :: MonadPlus m => m (Maybe a) -> m a
catMaybesMP :: forall (m :: * -> *) a. MonadPlus m => m (Maybe a) -> m a
catMaybesMP = m (Maybe a) -> m a
forall (m :: * -> *) (t :: * -> *) a.
(MonadPlus m, Foldable t) =>
m (t a) -> m a
scatterMP

-- | Branch over elements of a monadic 'Foldable' data structure.
scatterMP :: (MonadPlus m, Foldable t) => m (t a) -> m a
scatterMP :: forall (m :: * -> *) (t :: * -> *) a.
(MonadPlus m, Foldable t) =>
m (t a) -> m a
scatterMP = (m (t a) -> (t a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t a -> m a
forall (f :: * -> *) (t :: * -> *) a.
(Alternative f, Foldable t) =>
t a -> f a
foldA)


-- Error monad ------------------------------------------------------------

-- | Finally for the 'Error' class. Errors in the finally part take
-- precedence over prior errors.

{-# INLINE finally #-}
finally :: MonadError e m => m a -> m () -> m a
m a
first finally :: forall e (m :: * -> *) a. MonadError e m => m a -> m () -> m a
`finally` m ()
after = do
  r <- m (Either e a) -> (e -> m (Either e a)) -> m (Either e a)
forall a. m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ((a -> Either e a) -> m a -> m (Either e a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either e a
forall a b. b -> Either a b
Right m a
first) (Either e a -> m (Either e a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e a -> m (Either e a))
-> (e -> Either e a) -> e -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e a
forall a b. a -> Either a b
Left)
  after
  case r of
    Left e
e  -> e -> m a
forall a. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
    Right a
r -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

-- | Try a computation, return 'Nothing' if an 'Error' occurs.
{-# INLINE tryMaybe #-}
tryMaybe :: (MonadError e m) => m a -> m (Maybe a)
tryMaybe :: forall e (m :: * -> *) a. MonadError e m => m a -> m (Maybe a)
tryMaybe m a
m = (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> m a -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
m) m (Maybe a) -> (e -> m (Maybe a)) -> m (Maybe a)
forall a. m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \ e
_ -> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

-- | Run a command, catch the exception and return it.
{-# INLINE tryCatch #-}
tryCatch :: (MonadError e m) => m () -> m (Maybe e)
tryCatch :: forall e (m :: * -> *). MonadError e m => m () -> m (Maybe e)
tryCatch m ()
m = (Maybe e
forall a. Maybe a
Nothing Maybe e -> m () -> m (Maybe e)
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ m ()
m) m (Maybe e) -> (e -> m (Maybe e)) -> m (Maybe e)
forall a. m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \ e
err -> Maybe e -> m (Maybe e)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe e -> m (Maybe e)) -> Maybe e -> m (Maybe e)
forall a b. (a -> b) -> a -> b
$ e -> Maybe e
forall a. a -> Maybe a
Just e
err

-- | Like 'guard', but raise given error when condition fails.

guardWithError :: MonadError e m => e -> Bool -> m ()
guardWithError :: forall e (m :: * -> *). MonadError e m => e -> Bool -> m ()
guardWithError e
e Bool
b = if Bool
b then () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return () else e -> m ()
forall a. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e

-- | Handle errors thrown in 'ExceptT'.
{-# INLINE catchExceptT #-}
catchExceptT :: Monad m => ExceptT e m a -> (e -> m a) -> m a
catchExceptT :: forall (m :: * -> *) e a.
Monad m =>
ExceptT e m a -> (e -> m a) -> m a
catchExceptT ExceptT e m a
m e -> m a
h = (e -> m a) -> (a -> m a) -> Either e a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> m a
h a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e a -> m a) -> m (Either e a) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e m a
m

-- State monad ------------------------------------------------------------

{-# INLINE bracket_ #-}
-- | Bracket without failure.  Typically used to preserve state.
bracket_ :: Monad m
         => m a         -- ^ Acquires resource. Run first.
         -> (a -> m ())  -- ^ Releases resource. Run last.
         -> m b         -- ^ Computes result. Run in-between.
         -> m b
bracket_ :: forall (m :: * -> *) a b.
Monad m =>
m a -> (a -> m ()) -> m b -> m b
bracket_ m a
acquire a -> m ()
release m b
compute = do
  resource <- m a
acquire
  result <- compute
  release resource
  return result

-- | Restore state after computation.
localState :: MonadState s m => m a -> m a
localState :: forall s (m :: * -> *) a. MonadState s m => m a -> m a
localState = m s -> (s -> m ()) -> m a -> m a
forall (m :: * -> *) a b.
Monad m =>
m a -> (a -> m ()) -> m b -> m b
bracket_ m s
forall s (m :: * -> *). MonadState s m => m s
get s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put

-- Writer monad -----------------------------------------------------------

embedWriter :: (Monad m) => Writer w a -> WriterT w m a
embedWriter :: forall (m :: * -> *) w a. Monad m => Writer w a -> WriterT w m a
embedWriter = (Identity (a, w) -> m (a, w))
-> WriterT w Identity a -> WriterT w m a
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT ((a, w) -> m (a, w)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, w) -> m (a, w))
-> (Identity (a, w) -> (a, w)) -> Identity (a, w) -> m (a, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (a, w) -> (a, w)
forall a. Identity a -> a
runIdentity)

-- | Output a single value.
tell1 :: (Singleton w ws, MonadWriter ws m) => w -> m ()
tell1 :: forall w ws (m :: * -> *).
(Singleton w ws, MonadWriter ws m) =>
w -> m ()
tell1 = ws -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (ws -> m ()) -> (w -> ws) -> w -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> ws
forall el coll. Singleton el coll => el -> coll
singleton