{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module:      Data.OpenApi.Declare
-- Maintainer:  Nickolay Kudasov <nickolay@getshoptv.com>
-- Stability:   experimental
--
-- Declare monad transformer and associated functions.
module Data.OpenApi.Declare where

import Prelude ()
import Prelude.Compat

import Control.Monad
import Control.Monad.Cont (ContT)
import Control.Monad.Reader (ReaderT)
import Control.Monad.Trans
import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans.Identity (IdentityT)
import Control.Monad.Trans.Maybe (MaybeT)
import Control.Monad.Trans.State.Lazy as Lazy
import Control.Monad.Trans.State.Strict as Strict
import Control.Monad.Trans.RWS.Lazy as Lazy
import Control.Monad.Trans.RWS.Strict as Strict
import Control.Monad.Trans.Writer.Lazy as Lazy
import Control.Monad.Trans.Writer.Strict as Strict
import Data.Functor.Identity

-- | A declare monad transformer parametrized by:
--
--  * @d@ — the output to accumulate (declarations);
--
--  * @m@ — the inner monad.
--
-- This monad transformer is similar to both state and writer monad transformers.
-- Thus it can be seen as
--
--  * a restricted append-only version of a state monad transformer or
--
--  * a writer monad transformer with the extra ability to read all previous output.
newtype DeclareT d m a = DeclareT { forall d (m :: * -> *) a. DeclareT d m a -> d -> m (d, a)
runDeclareT :: d -> m (d, a) }
  deriving (forall a b. a -> DeclareT d m b -> DeclareT d m a
forall a b. (a -> b) -> DeclareT d m a -> DeclareT d m b
forall d (m :: * -> *) a b.
Functor m =>
a -> DeclareT d m b -> DeclareT d m a
forall d (m :: * -> *) a b.
Functor m =>
(a -> b) -> DeclareT d m a -> DeclareT d m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> DeclareT d m b -> DeclareT d m a
$c<$ :: forall d (m :: * -> *) a b.
Functor m =>
a -> DeclareT d m b -> DeclareT d m a
fmap :: forall a b. (a -> b) -> DeclareT d m a -> DeclareT d m b
$cfmap :: forall d (m :: * -> *) a b.
Functor m =>
(a -> b) -> DeclareT d m a -> DeclareT d m b
Functor)

instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where
  pure :: forall a. a -> DeclareT d m a
pure a
x = forall d (m :: * -> *) a. (d -> m (d, a)) -> DeclareT d m a
DeclareT (\d
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Monoid a => a
mempty, a
x))
  DeclareT d -> m (d, a -> b)
df <*> :: forall a b.
DeclareT d m (a -> b) -> DeclareT d m a -> DeclareT d m b
<*> DeclareT d -> m (d, a)
dx = forall d (m :: * -> *) a. (d -> m (d, a)) -> DeclareT d m a
DeclareT forall a b. (a -> b) -> a -> b
$ \d
d -> do
    ~(d
d',  a -> b
f) <- d -> m (d, a -> b)
df d
d
    ~(d
d'', a
x) <- d -> m (d, a)
dx (forall a. Monoid a => a -> a -> a
mappend d
d d
d')
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a -> a -> a
mappend d
d' d
d'', a -> b
f a
x)

instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
  return :: forall a. a -> DeclareT d m a
return a
x = forall d (m :: * -> *) a. (d -> m (d, a)) -> DeclareT d m a
DeclareT (\d
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Monoid a => a
mempty, a
x))
  DeclareT d -> m (d, a)
dx >>= :: forall a b.
DeclareT d m a -> (a -> DeclareT d m b) -> DeclareT d m b
>>= a -> DeclareT d m b
f = forall d (m :: * -> *) a. (d -> m (d, a)) -> DeclareT d m a
DeclareT forall a b. (a -> b) -> a -> b
$ \d
d -> do
    ~(d
d',  a
x) <- d -> m (d, a)
dx d
d
    ~(d
d'', b
y) <- forall d (m :: * -> *) a. DeclareT d m a -> d -> m (d, a)
runDeclareT (a -> DeclareT d m b
f a
x) (forall a. Monoid a => a -> a -> a
mappend d
d d
d')
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a -> a -> a
mappend d
d' d
d'', b
y)

instance Monoid d => MonadTrans (DeclareT d) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> DeclareT d m a
lift m a
m = forall d (m :: * -> *) a. (d -> m (d, a)) -> DeclareT d m a
DeclareT (\d
_ -> (,) forall a. Monoid a => a
mempty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
m)

-- |
-- Definitions of @declare@ and @look@ must satisfy the following laws:
--
-- [/monoid homomorphism (mempty)/]
--   @'declare' mempty == return ()@
--
-- [/monoid homomorphism (mappend)/]
--   @'declare' x >> 'declare' y == 'declare' (x <> y)@
--   for every @x@, @y@
--
-- [/@declare@-@look@/]
--   @'declare' x >> 'look' == 'fmap' (<> x) 'look' <* 'declare' x@
--   for every @x@
--
-- [/@look@ as left identity/]
--   @'look' >> m == m@
--   for every @m@
class (Applicative m, Monad m) => MonadDeclare d m | m -> d where
  -- | @'declare' x@ is an action that produces the output @x@.
  declare :: d -> m ()
  -- | @'look'@ is an action that returns all the output so far.
  look :: m d

instance (Applicative m, Monad m, Monoid d) => MonadDeclare d (DeclareT d m) where
  declare :: d -> DeclareT d m ()
declare d
d = forall d (m :: * -> *) a. (d -> m (d, a)) -> DeclareT d m a
DeclareT (\d
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (d
d, ()))
  look :: DeclareT d m d
look = forall d (m :: * -> *) a. (d -> m (d, a)) -> DeclareT d m a
DeclareT (\d
d -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty, d
d))

-- | Lift a computation from the simple Declare monad.
liftDeclare :: MonadDeclare d m => Declare d a -> m a
liftDeclare :: forall d (m :: * -> *) a. MonadDeclare d m => Declare d a -> m a
liftDeclare Declare d a
da = do
  (d
d', a
a) <- forall d (m :: * -> *) a. MonadDeclare d m => (d -> a) -> m a
looks (forall d a. Declare d a -> d -> (d, a)
runDeclare Declare d a
da)
  forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare d
d'
  forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- | Retrieve a function of all the output so far.
looks :: MonadDeclare d m => (d -> a) -> m a
looks :: forall d (m :: * -> *) a. MonadDeclare d m => (d -> a) -> m a
looks d -> a
f = d -> a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall d (m :: * -> *). MonadDeclare d m => m d
look

-- | Evaluate @'DeclareT' d m a@ computation,
-- ignoring new output @d@.
evalDeclareT :: Monad m => DeclareT d m a -> d -> m a
evalDeclareT :: forall (m :: * -> *) d a. Monad m => DeclareT d m a -> d -> m a
evalDeclareT (DeclareT d -> m (d, a)
f) d
d = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> d -> m (d, a)
f d
d

-- | Execute @'DeclateT' d m a@ computation,
-- ignoring result and only producing new output @d@.
execDeclareT :: Monad m => DeclareT d m a -> d -> m d
execDeclareT :: forall (m :: * -> *) d a. Monad m => DeclareT d m a -> d -> m d
execDeclareT (DeclareT d -> m (d, a)
f) d
d = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> d -> m (d, a)
f d
d

-- | Evaluate @'DeclareT' d m a@ computation,
-- starting with empty output history.
undeclareT :: (Monad m, Monoid d) => DeclareT d m a -> m a
undeclareT :: forall (m :: * -> *) d a.
(Monad m, Monoid d) =>
DeclareT d m a -> m a
undeclareT = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) d a. Monad m => DeclareT d m a -> d -> m a
evalDeclareT forall a. Monoid a => a
mempty

-- | A declare monad parametrized by @d@ — the output to accumulate (declarations).
--
-- This monad is similar to both state and writer monads.
-- Thus it can be seen as
--
--  * a restricted append-only version of a state monad or
--
--  * a writer monad with the extra ability to read all previous output.
type Declare d = DeclareT d Identity

-- | Run @'Declare' d a@ computation with output history @d@,
-- producing result @a@ and new output @d@.
runDeclare :: Declare d a -> d -> (d, a)
runDeclare :: forall d a. Declare d a -> d -> (d, a)
runDeclare Declare d a
m = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d (m :: * -> *) a. DeclareT d m a -> d -> m (d, a)
runDeclareT Declare d a
m

-- | Evaluate @'Declare' d a@ computation, ignoring output @d@.
evalDeclare :: Declare d a -> d -> a
evalDeclare :: forall d a. Declare d a -> d -> a
evalDeclare Declare d a
m = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) d a. Monad m => DeclareT d m a -> d -> m a
evalDeclareT Declare d a
m

-- | Execute @'Declate' d a@ computation, ignoring result and only
-- producing output @d@.
execDeclare :: Declare d a -> d -> d
execDeclare :: forall d a. Declare d a -> d -> d
execDeclare Declare d a
m = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) d a. Monad m => DeclareT d m a -> d -> m d
execDeclareT Declare d a
m

-- | Evaluate @'DeclareT' d m a@ computation,
-- starting with empty output history.
undeclare :: Monoid d => Declare d a -> a
undeclare :: forall d a. Monoid d => Declare d a -> a
undeclare = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) d a.
(Monad m, Monoid d) =>
DeclareT d m a -> m a
undeclareT

-- ---------------------------------------------------------------------------
-- Instances for other mtl transformers
--
-- All of these instances need UndecidableInstances,
-- because they do not satisfy the coverage condition.

instance MonadDeclare d m => MonadDeclare d (ContT r m) where
  declare :: d -> ContT r m ()
declare = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: ContT r m d
look = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall d (m :: * -> *). MonadDeclare d m => m d
look

instance MonadDeclare d m => MonadDeclare d (ExceptT e m) where
  declare :: d -> ExceptT e m ()
declare = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: ExceptT e m d
look = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall d (m :: * -> *). MonadDeclare d m => m d
look

instance MonadDeclare d m => MonadDeclare d (IdentityT m) where
  declare :: d -> IdentityT m ()
declare = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: IdentityT m d
look = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall d (m :: * -> *). MonadDeclare d m => m d
look

instance MonadDeclare d m => MonadDeclare d (MaybeT m) where
  declare :: d -> MaybeT m ()
declare = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: MaybeT m d
look = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall d (m :: * -> *). MonadDeclare d m => m d
look

instance MonadDeclare d m => MonadDeclare d (ReaderT r m) where
  declare :: d -> ReaderT r m ()
declare = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: ReaderT r m d
look = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall d (m :: * -> *). MonadDeclare d m => m d
look

instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Lazy.RWST r w s m) where
  declare :: d -> RWST r w s m ()
declare = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: RWST r w s m d
look = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall d (m :: * -> *). MonadDeclare d m => m d
look

instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Strict.RWST r w s m) where
  declare :: d -> RWST r w s m ()
declare = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: RWST r w s m d
look = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall d (m :: * -> *). MonadDeclare d m => m d
look

instance MonadDeclare d m => MonadDeclare d (Lazy.StateT s m) where
  declare :: d -> StateT s m ()
declare = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: StateT s m d
look = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall d (m :: * -> *). MonadDeclare d m => m d
look

instance MonadDeclare d m => MonadDeclare d (Strict.StateT s m) where
  declare :: d -> StateT s m ()
declare = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: StateT s m d
look = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall d (m :: * -> *). MonadDeclare d m => m d
look

instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Lazy.WriterT w m) where
  declare :: d -> WriterT w m ()
declare = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: WriterT w m d
look = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall d (m :: * -> *). MonadDeclare d m => m d
look

instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Strict.WriterT w m) where
  declare :: d -> WriterT w m ()
declare = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: WriterT w m d
look = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall d (m :: * -> *). MonadDeclare d m => m d
look