{-# 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.List (ListT)
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 { DeclareT d m a -> d -> m (d, a)
runDeclareT :: d -> m (d, a) }
  deriving (a -> DeclareT d m b -> DeclareT d m a
(a -> b) -> DeclareT d m a -> DeclareT d m b
(forall a b. (a -> b) -> DeclareT d m a -> DeclareT d m b)
-> (forall a b. a -> DeclareT d m b -> DeclareT d m a)
-> Functor (DeclareT d m)
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
<$ :: 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 :: (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 :: a -> DeclareT d m a
pure a
x = (d -> m (d, a)) -> DeclareT d m a
forall d (m :: * -> *) a. (d -> m (d, a)) -> DeclareT d m a
DeclareT (\d
_ -> (d, a) -> m (d, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (d
forall a. Monoid a => a
mempty, a
x))
  DeclareT d -> m (d, a -> b)
df <*> :: DeclareT d m (a -> b) -> DeclareT d m a -> DeclareT d m b
<*> DeclareT d -> m (d, a)
dx = (d -> m (d, b)) -> DeclareT d m b
forall d (m :: * -> *) a. (d -> m (d, a)) -> DeclareT d m a
DeclareT ((d -> m (d, b)) -> DeclareT d m b)
-> (d -> m (d, b)) -> DeclareT d m b
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 (d -> d -> d
forall a. Monoid a => a -> a -> a
mappend d
d d
d')
    (d, b) -> m (d, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (d -> d -> d
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 :: a -> DeclareT d m a
return a
x = (d -> m (d, a)) -> DeclareT d m a
forall d (m :: * -> *) a. (d -> m (d, a)) -> DeclareT d m a
DeclareT (\d
_ -> (d, a) -> m (d, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (d
forall a. Monoid a => a
mempty, a
x))
  DeclareT d -> m (d, a)
dx >>= :: DeclareT d m a -> (a -> DeclareT d m b) -> DeclareT d m b
>>= a -> DeclareT d m b
f = (d -> m (d, b)) -> DeclareT d m b
forall d (m :: * -> *) a. (d -> m (d, a)) -> DeclareT d m a
DeclareT ((d -> m (d, b)) -> DeclareT d m b)
-> (d -> m (d, b)) -> DeclareT d m b
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) <- DeclareT d m b -> d -> m (d, b)
forall d (m :: * -> *) a. DeclareT d m a -> d -> m (d, a)
runDeclareT (a -> DeclareT d m b
f a
x) (d -> d -> d
forall a. Monoid a => a -> a -> a
mappend d
d d
d')
    (d, b) -> m (d, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (d -> d -> d
forall a. Monoid a => a -> a -> a
mappend d
d' d
d'', b
y)

instance Monoid d => MonadTrans (DeclareT d) where
  lift :: m a -> DeclareT d m a
lift m a
m = (d -> m (d, a)) -> DeclareT d m a
forall d (m :: * -> *) a. (d -> m (d, a)) -> DeclareT d m a
DeclareT (\d
_ -> (,) d
forall a. Monoid a => a
mempty (a -> (d, a)) -> m a -> m (d, a)
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 = (d -> m (d, ())) -> DeclareT d m ()
forall d (m :: * -> *) a. (d -> m (d, a)) -> DeclareT d m a
DeclareT (\d
_ -> (d, ()) -> m (d, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (d
d, ()))
  look :: DeclareT d m d
look = (d -> m (d, d)) -> DeclareT d m d
forall d (m :: * -> *) a. (d -> m (d, a)) -> DeclareT d m a
DeclareT (\d
d -> (d, d) -> m (d, d)
forall (m :: * -> *) a. Monad m => a -> m a
return (d
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 :: Declare d a -> m a
liftDeclare Declare d a
da = do
  (d
d', a
a) <- (d -> (d, a)) -> m (d, a)
forall d (m :: * -> *) a. MonadDeclare d m => (d -> a) -> m a
looks (Declare d a -> d -> (d, a)
forall d a. Declare d a -> d -> (d, a)
runDeclare Declare d a
da)
  d -> m ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare d
d'
  a -> m a
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 :: (d -> a) -> m a
looks d -> a
f = d -> a
f (d -> a) -> m d -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m d
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 :: DeclareT d m a -> d -> m a
evalDeclareT (DeclareT d -> m (d, a)
f) d
d = (d, a) -> a
forall a b. (a, b) -> b
snd ((d, a) -> a) -> m (d, a) -> m a
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 :: DeclareT d m a -> d -> m d
execDeclareT (DeclareT d -> m (d, a)
f) d
d = (d, a) -> d
forall a b. (a, b) -> a
fst ((d, a) -> d) -> m (d, a) -> m d
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 :: DeclareT d m a -> m a
undeclareT = (DeclareT d m a -> d -> m a) -> d -> DeclareT d m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip DeclareT d m a -> d -> m a
forall (m :: * -> *) d a. Monad m => DeclareT d m a -> d -> m a
evalDeclareT d
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 :: Declare d a -> d -> (d, a)
runDeclare Declare d a
m = Identity (d, a) -> (d, a)
forall a. Identity a -> a
runIdentity (Identity (d, a) -> (d, a))
-> (d -> Identity (d, a)) -> d -> (d, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declare d a -> d -> Identity (d, a)
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 :: Declare d a -> d -> a
evalDeclare Declare d a
m = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (d -> Identity a) -> d -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declare d a -> d -> Identity a
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 :: Declare d a -> d -> d
execDeclare Declare d a
m = Identity d -> d
forall a. Identity a -> a
runIdentity (Identity d -> d) -> (d -> Identity d) -> d -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declare d a -> d -> Identity d
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 :: Declare d a -> a
undeclare = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a)
-> (Declare d a -> Identity a) -> Declare d a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declare d a -> Identity a
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 = m () -> ContT r m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ContT r m ()) -> (d -> m ()) -> d -> ContT r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> m ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: ContT r m d
look = m d -> ContT r m d
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m d
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 = m () -> ExceptT e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT e m ()) -> (d -> m ()) -> d -> ExceptT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> m ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: ExceptT e m d
look = m d -> ExceptT e m d
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m d
forall d (m :: * -> *). MonadDeclare d m => m d
look

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

instance MonadDeclare d m => MonadDeclare d (MaybeT m) where
  declare :: d -> MaybeT m ()
declare = m () -> MaybeT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> MaybeT m ()) -> (d -> m ()) -> d -> MaybeT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> m ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: MaybeT m d
look = m d -> MaybeT m d
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m d
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 = m () -> ReaderT r m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT r m ()) -> (d -> m ()) -> d -> ReaderT r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> m ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: ReaderT r m d
look = m d -> ReaderT r m d
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m d
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 = m () -> RWST r w s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RWST r w s m ()) -> (d -> m ()) -> d -> RWST r w s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> m ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: RWST r w s m d
look = m d -> RWST r w s m d
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m d
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 = m () -> RWST r w s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RWST r w s m ()) -> (d -> m ()) -> d -> RWST r w s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> m ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: RWST r w s m d
look = m d -> RWST r w s m d
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m d
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 = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ()) -> (d -> m ()) -> d -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> m ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: StateT s m d
look = m d -> StateT s m d
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m d
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 = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ()) -> (d -> m ()) -> d -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> m ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: StateT s m d
look = m d -> StateT s m d
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m d
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 = m () -> WriterT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WriterT w m ()) -> (d -> m ()) -> d -> WriterT w m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> m ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: WriterT w m d
look = m d -> WriterT w m d
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m d
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 = m () -> WriterT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WriterT w m ()) -> (d -> m ()) -> d -> WriterT w m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> m ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare
  look :: WriterT w m d
look = m d -> WriterT w m d
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m d
forall d (m :: * -> *). MonadDeclare d m => m d
look