module Agda.Utils.Monad
    ( module Agda.Utils.Monad
    , when, unless, MonadPlus(..)
    , (<$>), (<*>)
    , (<$)
    )
    where

import Control.Applicative  (liftA2)
import Control.Monad hiding (mapM, forM)

import qualified Control.Monad.Fail as Fail

import Control.Monad.Identity ( Identity )
import Control.Monad.State

import Data.Traversable as Trav hiding (for, sequence)
import Data.Foldable as Fold
import Data.Maybe

import Agda.Utils.Either
import Agda.Utils.Except
  ( Error(strMsg)
  , MonadError(catchError, throwError)
  )

import Agda.Utils.Null (ifNotNullM)

import Agda.Utils.Impossible

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

-- | Binary bind.
(==<<) :: Monad m => (a -> b -> m c) -> (m a, m b) -> m c
a -> b -> m c
k ==<< :: (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 (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

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

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

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

-- | Monadic guard.
guardM :: (Monad m, MonadPlus m) => m Bool -> m ()
guardM :: m Bool -> m ()
guardM m Bool
c = Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
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 :: 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 (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 :: 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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return Bool
False)

andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
andM :: f (m Bool) -> m Bool
andM = (m Bool -> m Bool -> m Bool) -> m Bool -> f (m Bool) -> m Bool
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 (m :: * -> *) a. Monad m => a -> m a
return Bool
True)

allM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
allM :: f a -> (a -> m Bool) -> m Bool
allM f a
xs a -> m Bool
f = f (m Bool) -> m Bool
forall (f :: * -> *) (m :: * -> *).
(Foldable f, Monad m) =>
f (m Bool) -> m Bool
andM (f (m Bool) -> m Bool) -> f (m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ (a -> m Bool) -> f a -> f (m Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> m Bool
f f a
xs

-- | Lazy monadic disjunction.
or2M :: Monad m => m Bool -> m Bool -> m Bool
or2M :: 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 (m :: * -> *) a. Monad m => a -> m a
return Bool
True)

orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
orM :: f (m Bool) -> m Bool
orM = (m Bool -> m Bool -> m Bool) -> m Bool -> f (m Bool) -> m Bool
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 (m :: * -> *) a. Monad m => a -> m a
return Bool
False)

anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
anyM :: f a -> (a -> m Bool) -> m Bool
anyM f a
xs a -> m Bool
f = f (m Bool) -> m Bool
forall (f :: * -> *) (m :: * -> *).
(Foldable f, Monad m) =>
f (m Bool) -> m Bool
orM (f (m Bool) -> m Bool) -> f (m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ (a -> m Bool) -> f a -> f (m Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> m Bool
f f a
xs

-- | 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 :: (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 (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, Functor m) => [m (Either e b)] -> m (Either e b)
orEitherM :: [m (Either e b)] -> m (Either e b)
orEitherM []       = Either e b -> m (Either e b)
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, Functor m) =>
[m (Either e b)] -> m (Either e b)
orEitherM [m (Either e b)]
ms)
                                   (Either e b -> m (Either e b)
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' :: (a -> m b) -> t a -> m b
mapM' a -> m b
f = (m b -> a -> m b) -> m b -> t a -> m 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 (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 (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' :: 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 :: (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)
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 :: 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_ :: (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_ :: 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 -------------------------------------------------------

-- | A monadic version of @'mapMaybe' :: (a -> Maybe b) -> [a] -> [b]@.
mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM :: (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM a -> m (Maybe b)
f [a]
xs = [Maybe b] -> [b]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe b] -> [b]) -> m [Maybe b] -> m [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> m (Maybe b)) -> [a] -> m [Maybe b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
Trav.mapM a -> m (Maybe b)
f [a]
xs

-- | A version of @'mapMaybeM'@ with a computation for the input list.
mapMaybeMM :: Monad m => (a -> m (Maybe b)) -> m [a] -> m [b]
mapMaybeMM :: (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

-- | The @for@ version of 'mapMaybeM'.
forMaybeM :: Monad m => [a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM :: [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 :: 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 :: (a -> m Bool) -> [a] -> m [a]
dropWhileM a -> m Bool
p []       = [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 (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 :: (a -> m Bool) -> [a] -> m [a]
dropWhileEndM a -> m Bool
p []       = [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 (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 (m :: * -> *) a. Monad m => a -> m a
return []) ([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 :: (Functor m, Applicative m) => (a -> m Bool) -> [a] -> m ([a],[a])
partitionM :: (a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
f [] =
  ([a], [a]) -> m ([a], [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
partitionM a -> m Bool
f (a
x:[a]
xs) =
  (\ Bool
b ([a]
l, [a]
r) -> if Bool
b then (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
l, [a]
r) else ([a]
l, a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
r)) (Bool -> ([a], [a]) -> ([a], [a]))
-> m Bool -> m (([a], [a]) -> ([a], [a]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m Bool
f a
x m (([a], [a]) -> ([a], [a])) -> m ([a], [a]) -> m ([a], [a])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> m Bool) -> [a] -> m ([a], [a])
forall (m :: * -> *) a.
(Functor m, Applicative m) =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
f [a]
xs

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

-- | Translates 'Maybe' to 'MonadPlus'.
fromMaybeMP :: MonadPlus m => Maybe a -> m a
fromMaybeMP :: Maybe a -> m a
fromMaybeMP = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Generalises the 'catMaybes' function from lists to an arbitrary
-- 'MonadPlus'.
catMaybesMP :: MonadPlus m => m (Maybe a) -> m a
catMaybesMP :: m (Maybe a) -> m a
catMaybesMP = (m (Maybe a) -> (Maybe a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe a -> m a
forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
fromMaybeMP)

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

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

finally :: MonadError e m => m a -> m () -> m a
m a
first finally :: m a -> m () -> m a
`finally` m ()
after = do
  Either e a
r <- m (Either e a) -> (e -> m (Either e a)) -> m (Either e 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 (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 (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)
  m ()
after
  case Either e a
r of
    Left e
e  -> e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
    Right a
r -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

-- | Try a computation, return 'Nothing' if an 'Error' occurs.

tryMaybe :: (MonadError e m, Functor m) => m a -> m (Maybe a)
tryMaybe :: 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 e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \ e
_ -> Maybe a -> m (Maybe 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.

tryCatch :: (MonadError e m, Functor m) => m () -> m (Maybe e)
tryCatch :: m () -> m (Maybe e)
tryCatch m ()
m = (Maybe e
forall a. Maybe a
Nothing Maybe e -> m () -> m (Maybe e)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ m ()
m) m (Maybe e) -> (e -> m (Maybe e)) -> m (Maybe e)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \ e
err -> Maybe e -> m (Maybe e)
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

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

-- | 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_ :: m a -> (a -> m ()) -> m b -> m b
bracket_ m a
acquire a -> m ()
release m b
compute = do
  a
resource <- m a
acquire
  b
result <- m b
compute
  a -> m ()
release a
resource
  b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
result

-- | Restore state after computation.
localState :: MonadState s m => m a -> m a
localState :: 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

-- Read -------------------------------------------------------------------

readM :: (Error e, MonadError e m, Read a) => String -> m a
readM :: String -> m a
readM String
s = case ReadS a
forall a. Read a => ReadS a
reads String
s of
            [(a
x,String
"")]    -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
            [(a, String)]
_           ->
              e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m a) -> e -> m a
forall a b. (a -> b) -> a -> b
$ String -> e
forall a. Error a => String -> a
strMsg (String -> e) -> String -> e
forall a b. (a -> b) -> a -> b
$ String
"readM: parse error string " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s