{-# LANGUAGE CPP #-}
#if defined(__GLASGOW_HASKELL__)
{-# LANGUAGE DefaultSignatures #-}
#endif
{-# OPTIONS -fno-warn-deprecations #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2012-2015 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- This module provides the 'Bound' class, for performing substitution into
-- things that are not necessarily full monad transformers.
----------------------------------------------------------------------------
module Bound.Class
  ( Bound(..)
  , (=<<<)
  ) where

import Control.Monad.Trans.Class
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Error
import Control.Monad.Trans.Identity
import Control.Monad.Trans.List
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.RWS
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Control.Monad.Trans.Writer

infixl 1 >>>=

-- | Instances of 'Bound' generate left modules over monads.
--
-- This means they should satisfy the following laws:
--
-- @
-- m '>>>=' 'return' ≡ m
-- m '>>>=' (λ x → k x '>>=' h) ≡ (m '>>>=' k) '>>>=' h
-- @
--
-- This guarantees that a typical Monad instance for an expression type
-- where Bound instances appear will satisfy the Monad laws (see doc/BoundLaws.hs).
--
-- If instances of 'Bound' are monad transformers, then @m '>>>=' f ≡ m '>>=' 'lift' '.' f@
-- implies the above laws, and is in fact the default definition.
--
-- This is useful for types like expression lists, case alternatives,
-- schemas, etc. that may not be expressions in their own right, but often
-- contain expressions.
--
-- /Note:/ 'Control.Monad.Free.Free' isn't "really" a monad transformer, even if
-- the kind matches. Therefore there isn't @'Bound' 'Control.Monad.Free.Free'@ instance.
class Bound t where
  -- | Perform substitution
  --
  -- If @t@ is an instance of @MonadTrans@ and you are compiling on GHC >= 7.4, then this
  -- gets the default definition:
  --
  -- @m '>>>=' f = m '>>=' 'lift' '.' f@
  (>>>=) :: Monad f => t f a -> (a -> f c) -> t f c
#if defined(__GLASGOW_HASKELL__)
  default (>>>=) :: (MonadTrans t, Monad f, Monad (t f)) =>
                    t f a -> (a -> f c) -> t f c
  t f a
m >>>= a -> f c
f = t f a
m t f a -> (a -> t f c) -> t f c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= f c -> t f c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (f c -> t f c) -> (a -> f c) -> a -> t f c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f c
f
  {-# INLINE (>>>=) #-}
#endif

instance Bound (ContT c) where
  ContT c f a
m >>>= :: ContT c f a -> (a -> f c) -> ContT c f c
>>>= a -> f c
f = ContT c f a
m ContT c f a -> (a -> ContT c f c) -> ContT c f c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= f c -> ContT c f c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (f c -> ContT c f c) -> (a -> f c) -> a -> ContT c f c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f c
f
  {-# INLINE (>>>=) #-}

instance Error e => Bound (ErrorT e) where
 ErrorT e f a
m >>>= :: ErrorT e f a -> (a -> f c) -> ErrorT e f c
>>>= a -> f c
f = ErrorT e f a
m ErrorT e f a -> (a -> ErrorT e f c) -> ErrorT e f c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= f c -> ErrorT e f c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (f c -> ErrorT e f c) -> (a -> f c) -> a -> ErrorT e f c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f c
f
 {-# INLINE (>>>=) #-}

instance Bound IdentityT where
 IdentityT f a
m >>>= :: IdentityT f a -> (a -> f c) -> IdentityT f c
>>>= a -> f c
f = IdentityT f a
m IdentityT f a -> (a -> IdentityT f c) -> IdentityT f c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= f c -> IdentityT f c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (f c -> IdentityT f c) -> (a -> f c) -> a -> IdentityT f c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f c
f
 {-# INLINE (>>>=) #-}

instance Bound ListT where
 ListT f a
m >>>= :: ListT f a -> (a -> f c) -> ListT f c
>>>= a -> f c
f = ListT f a
m ListT f a -> (a -> ListT f c) -> ListT f c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= f c -> ListT f c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (f c -> ListT f c) -> (a -> f c) -> a -> ListT f c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f c
f
 {-# INLINE (>>>=) #-}

instance Bound MaybeT where
 MaybeT f a
m >>>= :: MaybeT f a -> (a -> f c) -> MaybeT f c
>>>= a -> f c
f = MaybeT f a
m MaybeT f a -> (a -> MaybeT f c) -> MaybeT f c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= f c -> MaybeT f c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (f c -> MaybeT f c) -> (a -> f c) -> a -> MaybeT f c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f c
f
 {-# INLINE (>>>=) #-}

instance Monoid w => Bound (RWST r w s) where
 RWST r w s f a
m >>>= :: RWST r w s f a -> (a -> f c) -> RWST r w s f c
>>>= a -> f c
f = RWST r w s f a
m RWST r w s f a -> (a -> RWST r w s f c) -> RWST r w s f c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= f c -> RWST r w s f c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (f c -> RWST r w s f c) -> (a -> f c) -> a -> RWST r w s f c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f c
f
 {-# INLINE (>>>=) #-}

instance Bound (ReaderT r) where
 ReaderT r f a
m >>>= :: ReaderT r f a -> (a -> f c) -> ReaderT r f c
>>>= a -> f c
f = ReaderT r f a
m ReaderT r f a -> (a -> ReaderT r f c) -> ReaderT r f c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= f c -> ReaderT r f c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (f c -> ReaderT r f c) -> (a -> f c) -> a -> ReaderT r f c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f c
f
 {-# INLINE (>>>=) #-}

instance Bound (StateT s) where
 StateT s f a
m >>>= :: StateT s f a -> (a -> f c) -> StateT s f c
>>>= a -> f c
f = StateT s f a
m StateT s f a -> (a -> StateT s f c) -> StateT s f c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= f c -> StateT s f c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (f c -> StateT s f c) -> (a -> f c) -> a -> StateT s f c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f c
f
 {-# INLINE (>>>=) #-}

instance Monoid w => Bound (WriterT w) where
 WriterT w f a
m >>>= :: WriterT w f a -> (a -> f c) -> WriterT w f c
>>>= a -> f c
f = WriterT w f a
m WriterT w f a -> (a -> WriterT w f c) -> WriterT w f c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= f c -> WriterT w f c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (f c -> WriterT w f c) -> (a -> f c) -> a -> WriterT w f c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f c
f
 {-# INLINE (>>>=) #-}

infixr 1 =<<<
-- | A flipped version of ('>>>=').
--
-- @('=<<<') = 'flip' ('>>>=')@
(=<<<) :: (Bound t, Monad f) => (a -> f c) -> t f a -> t f c
=<<< :: (a -> f c) -> t f a -> t f c
(=<<<) = (t f a -> (a -> f c) -> t f c) -> (a -> f c) -> t f a -> t f c
forall a b c. (a -> b -> c) -> b -> a -> c
flip t f a -> (a -> f c) -> t f c
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a c.
(Bound t, Monad f) =>
t f a -> (a -> f c) -> t f c
(>>>=)
{-# INLINE (=<<<) #-}