{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- |
-- Module : Control.Method
-- License: BSD-3
-- Maintainer: autotaker@gmail.com
-- Stability: experimental
module Control.Method
  ( -- * Usage
    -- $usage

    -- ** Dependency Injection
    -- $di

    -- ** Decorating methods
    -- $decorate

    -- * References
    Method (..),
    TupleLike (..),
    decorate,
    decorate_,
    decorateBefore_,
    invoke,
    liftJoin,
    NT,
    Interface (..),
    mapBaseRIO,
  )
where

import Control.Exception (SomeException)
import Control.Method.Internal
  ( Nil (Nil),
    TupleLike (AsTuple, fromTuple, toTuple),
    type (:*) ((:*)),
  )
import Control.Monad.Trans.Accum (AccumT)
import Control.Monad.Trans.Cont (ContT)
import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans.Maybe (MaybeT)
import qualified Control.Monad.Trans.RWS.CPS as CPS
import qualified Control.Monad.Trans.RWS.Lazy as Lazy
import qualified Control.Monad.Trans.RWS.Strict as Strict
import Control.Monad.Trans.Reader (ReaderT)
import Control.Monad.Trans.Select (SelectT)
import qualified Control.Monad.Trans.State.Lazy as Lazy
import qualified Control.Monad.Trans.State.Strict as Strict
import qualified Control.Monad.Trans.Writer.CPS as CPS
import qualified Control.Monad.Trans.Writer.Lazy as Lazy
import qualified Control.Monad.Trans.Writer.Strict as Strict
import Data.Functor.Identity (Identity)
import Data.Kind (Type)
import GHC.Generics
  ( Generic (Rep, from, to),
    K1 (K1),
    M1 (M1),
    type (:*:) ((:*:)),
    type (:+:) (L1, R1),
  )
import RIO (MonadIO (liftIO), MonadReader (ask), MonadUnliftIO, RIO, ST, SimpleGetter, runRIO, throwIO, tryAny, view)

-- $usage
-- This module provides dependency injection and decoration
-- for monadic functions (called methods).

-- $di
--
-- For example, assume that we are implementing signin function,
-- which checks user's password.
--
-- First, let's create an interface to access database.
--
-- @
-- type UserRepository env = UserRepository {
--   _findById :: UserId -> 'RIO' env (Maybe User)
--   _create :: User -> 'RIO' env UserId
-- }
-- makeLenses UserRepository''
-- @
--
-- And add Has-pattern typeclass.
--
-- @
-- class HasUserRepository env where
--   userRepositoryL :: Lens\' env (UserRepository env)
-- @
--
-- In @signup@ function, call @findById@ method via 'invoke'.
--
-- @
-- signin :: HasUserRepository env => UserId -> Password -> RIO env (Maybe User)
-- signin userId pass = do
--   muser <- invoke (userRepositoryL . findById) userId
--   pure $ do
--     user <- muser
--     guard (authCheck user pass)
--     pure user
-- @
--
-- In production code, inject @UserRepository@ implementation which
-- accesses database
--
-- @
-- userRepositoryImpl :: UserRepository env
-- userRepositoryImpl = UserRepository {
--   _findById = ...,
--   _create = ...
-- }
--
-- data ProductionEnv = ProductionEnv
-- instance HasUserRepository ProductionEnv where
--   userRepositoryL = lens (const userRepositoryImpl) const
-- @
--
-- In test code, inject @UserRepository@ mock implementation.
--
-- @
-- userRepositoryMock :: UserRepository env
-- userRepositoryMock = UserRepository {
--   _findById = \userId -> pure $ Just (User userId "password123")
--   _createUser = \user -> pure $ Just "example"
-- }
--
-- data TestEnv = TestEnv { _userRepository :: UserRepository Env }
-- makeLenses TestEnv''
--
-- instance HasUserRepository TestEnv where
--   userRepositoryL = userRepository
--
-- env = TestEnv userRepositoryMock
--
-- test :: Spec
-- test = describe "signin" $ do
--   it "return user for correct password" $ do
--     runRIO env (signin "example" "password123")
--       ``shouldReturn`` Just (User "example" "password123")
--   it "return Nothing for incorrect password" $ do
--     runRIO env (signin "example" "wrong")
--       ``shouldReturn`` Nothing
-- @

-- $decorate
-- By using 'decorate', 'decorate_', or 'decorateBefore_' function,
-- we can insert hooks before/after calling methods
--
-- Example to insert logging feature
--
-- >>> let f x y = pure (replicate x y) :: IO [String]
-- >>> let before args = putStrLn $ "args: " ++ show (toTuple args)
-- >>> let after res = putStrLn $ "ret: " ++ show res
-- >>> let decorateF = decorate_ before after f
-- >>> decorateF 2 "foo"
-- args: (2,"foo")
-- ret: Right ["foo","foo"]
-- ["foo","foo"]
--
-- Another example to decorate method with transaction management
--
-- @
-- transactional :: (Method method, MonadUnliftIO (Base method)) => (Connection -> method) -> method
-- transactional = decorate before after
--   where
--     before = do
--       conn <- liftIO $ getConnection cInfo
--       begin conn
--       pure conn
--     after conn (Left _) = liftIO $ rollback conn
--     after conn (Right _) = liftIO $ commit conn
-- @

-- | "Method" a is a function of the form
--  @a1 -> a2 -> ... -> an -> m b@
--  where @m@ is "Monad"
--
--  Typical monads in transformers package are supported.
--  If you want to support other monads (for example @M@),
--  add the following boilerplate.
--
-- @
-- instance Method (M a) where
--   Base (M a) = M
--   Ret  (M a) = a
-- @
--
--   __Caution__ Function monad @(-> r)@ cannot be an instance of 'Method'
class Monad (Base method) => Method method where
  -- | Underling monad
  --
  --   @Base (a1 -> ... -> an -> m b) = m@
  type Base method :: Type -> Type

  -- | Arguments tuple of the method
  --
  --   @Args (a1 -> ... -> an -> m b) = a1 :* ... :* an@
  type Args method :: Type

  type Args method = Nil

  -- | Return type of the method
  --
  --   @Ret  (a1 -> ... -> an -> m b) = b@
  type Ret method :: Type

  -- | Convert method to unary function
  uncurryMethod :: method -> Args method -> Base method (Ret method)
  {-# INLINE uncurryMethod #-}
  default uncurryMethod ::
    (method ~ Base method a, Args method ~ Nil, Ret method ~ a) =>
    method ->
    Args method ->
    Base method (Ret method)
  uncurryMethod method
method Args method
Nil = method
Base method (Ret method)
method

  -- | Reconstruct method from unary function
  curryMethod :: (Args method -> Base method (Ret method)) -> method
  {-# INLINE curryMethod #-}
  default curryMethod ::
    (method ~ Base method a, Args method ~ Nil, Ret method ~ a) =>
    (Args method -> Base method (Ret method)) ->
    method
  curryMethod Args method -> Base method (Ret method)
method' = Args method -> Base method (Ret method)
method' Nil
Args method
Nil

-- | Generalization of 'join' function
{-# INLINE liftJoin #-}
liftJoin :: Method method => Base method method -> method
liftJoin :: Base method method -> method
liftJoin Base method method
mMethod = (Args method -> Base method (Ret method)) -> method
forall method.
Method method =>
(Args method -> Base method (Ret method)) -> method
curryMethod ((Args method -> Base method (Ret method)) -> method)
-> (Args method -> Base method (Ret method)) -> method
forall a b. (a -> b) -> a -> b
$ \Args method
args -> do
  method
method <- Base method method
mMethod
  method -> Args method -> Base method (Ret method)
forall method.
Method method =>
method -> Args method -> Base method (Ret method)
uncurryMethod method
method Args method
args

instance Method (IO a) where
  type Base (IO a) = IO
  type Ret (IO a) = a

instance Method (RIO env a) where
  type Base (RIO env a) = RIO env
  type Ret (RIO env a) = a

instance Method (Identity a) where
  type Base (Identity a) = Identity
  type Ret (Identity a) = a

instance Method (Maybe a) where
  type Base (Maybe a) = Maybe
  type Ret (Maybe a) = a

instance Method [a] where
  type Base [a] = []
  type Ret [a] = a

instance Method (Either e a) where
  type Base (Either e a) = Either e
  type Ret (Either e a) = a

instance Method (ST s a) where
  type Base (ST s a) = ST s
  type Ret (ST s a) = a

instance (Monoid w, Monad m) => Method (AccumT w m a) where
  type Base (AccumT w m a) = AccumT w m
  type Ret (AccumT w m a) = a

instance (Monad m) => Method (ContT r m a) where
  type Base (ContT r m a) = ContT r m
  type Ret (ContT r m a) = a

instance (Monad m) => Method (ExceptT e m a) where
  type Base (ExceptT e m a) = ExceptT e m
  type Ret (ExceptT e m a) = a

instance (Monad m) => Method (MaybeT m a) where
  type Base (MaybeT m a) = MaybeT m
  type Ret (MaybeT m a) = a

instance (Monad m) => Method (CPS.RWST r w s m a) where
  type Base (CPS.RWST r w s m a) = CPS.RWST r w s m
  type Ret (CPS.RWST r w s m a) = a

instance (Monad m, Monoid w) => Method (Lazy.RWST r w s m a) where
  type Base (Lazy.RWST r w s m a) = Lazy.RWST r w s m
  type Ret (Lazy.RWST r w s m a) = a

instance (Monad m, Monoid w) => Method (Strict.RWST r w s m a) where
  type Base (Strict.RWST r w s m a) = Strict.RWST r w s m
  type Ret (Strict.RWST r w s m a) = a

instance Monad m => Method (ReaderT r m a) where
  type Base (ReaderT r m a) = ReaderT r m
  type Ret (ReaderT r m a) = a

instance Monad m => Method (SelectT r m a) where
  type Base (SelectT r m a) = SelectT r m
  type Ret (SelectT r m a) = a

instance Monad m => Method (Lazy.StateT s m a) where
  type Base (Lazy.StateT s m a) = Lazy.StateT s m
  type Ret (Lazy.StateT s m a) = a

instance Monad m => Method (Strict.StateT s m a) where
  type Base (Strict.StateT s m a) = Strict.StateT s m
  type Ret (Strict.StateT s m a) = a

instance (Monad m) => Method (CPS.WriterT w m a) where
  type Base (CPS.WriterT w m a) = CPS.WriterT w m
  type Ret (CPS.WriterT w m a) = a

instance (Monad m, Monoid w) => Method (Lazy.WriterT w m a) where
  type Base (Lazy.WriterT w m a) = Lazy.WriterT w m
  type Ret (Lazy.WriterT w m a) = a

instance (Monad m, Monoid w) => Method (Strict.WriterT w m a) where
  type Base (Strict.WriterT w m a) = Strict.WriterT w m
  type Ret (Strict.WriterT w m a) = a

instance Method b => Method (a -> b) where
  type Base (a -> b) = Base b
  type Args (a -> b) = a :* Args b
  type Ret (a -> b) = Ret b
  {-# INLINE uncurryMethod #-}
  uncurryMethod :: (a -> b) -> Args (a -> b) -> Base (a -> b) (Ret (a -> b))
uncurryMethod a -> b
method (a :* args) = b -> Args b -> Base b (Ret b)
forall method.
Method method =>
method -> Args method -> Base method (Ret method)
uncurryMethod (a -> b
method a
a) Args b
args
  {-# INLINE curryMethod #-}
  curryMethod :: (Args (a -> b) -> Base (a -> b) (Ret (a -> b))) -> a -> b
curryMethod Args (a -> b) -> Base (a -> b) (Ret (a -> b))
method' a
a = (Args b -> Base b (Ret b)) -> b
forall method.
Method method =>
(Args method -> Base method (Ret method)) -> method
curryMethod (\Args b
args -> Args (a -> b) -> Base (a -> b) (Ret (a -> b))
method' (a
a a -> Args b -> a :* Args b
forall a b. a -> b -> a :* b
:* Args b
args))

-- | Insert hooks before/after calling the argument method
{-# INLINE decorate #-}
decorate ::
  (Method method, MonadUnliftIO (Base method)) =>
  (Args method -> Base method a) ->
  (a -> Either SomeException (Ret method) -> Base method ()) ->
  (a -> method) ->
  method
decorate :: (Args method -> Base method a)
-> (a -> Either SomeException (Ret method) -> Base method ())
-> (a -> method)
-> method
decorate Args method -> Base method a
before a -> Either SomeException (Ret method) -> Base method ()
after a -> method
method = (Args method -> Base method (Ret method)) -> method
forall method.
Method method =>
(Args method -> Base method (Ret method)) -> method
curryMethod ((Args method -> Base method (Ret method)) -> method)
-> (Args method -> Base method (Ret method)) -> method
forall a b. (a -> b) -> a -> b
$ \Args method
args -> do
  a
a <- Args method -> Base method a
before Args method
args
  Either SomeException (Ret method)
res <- Base method (Ret method)
-> Base method (Either SomeException (Ret method))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (method -> Args method -> Base method (Ret method)
forall method.
Method method =>
method -> Args method -> Base method (Ret method)
uncurryMethod (a -> method
method a
a) Args method
args)
  case Either SomeException (Ret method)
res of
    Left SomeException
err -> a -> Either SomeException (Ret method) -> Base method ()
after a
a Either SomeException (Ret method)
res Base method ()
-> Base method (Ret method) -> Base method (Ret method)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> Base method (Ret method)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
err
    Right Ret method
v -> a -> Either SomeException (Ret method) -> Base method ()
after a
a Either SomeException (Ret method)
res Base method ()
-> Base method (Ret method) -> Base method (Ret method)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ret method -> Base method (Ret method)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ret method
v

-- | Insert hooks before/after calling the argument method
{-# INLINE decorate_ #-}
decorate_ ::
  (Method method, MonadUnliftIO (Base method)) =>
  (Args method -> Base method ()) ->
  (Either SomeException (Ret method) -> Base method ()) ->
  method ->
  method
decorate_ :: (Args method -> Base method ())
-> (Either SomeException (Ret method) -> Base method ())
-> method
-> method
decorate_ Args method -> Base method ()
before Either SomeException (Ret method) -> Base method ()
after method
method = (Args method -> Base method (Ret method)) -> method
forall method.
Method method =>
(Args method -> Base method (Ret method)) -> method
curryMethod ((Args method -> Base method (Ret method)) -> method)
-> (Args method -> Base method (Ret method)) -> method
forall a b. (a -> b) -> a -> b
$ \Args method
args -> do
  Args method -> Base method ()
before Args method
args
  Either SomeException (Ret method)
res <- Base method (Ret method)
-> Base method (Either SomeException (Ret method))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (method -> Args method -> Base method (Ret method)
forall method.
Method method =>
method -> Args method -> Base method (Ret method)
uncurryMethod method
method Args method
args)
  case Either SomeException (Ret method)
res of
    Left SomeException
err -> Either SomeException (Ret method) -> Base method ()
after Either SomeException (Ret method)
res Base method ()
-> Base method (Ret method) -> Base method (Ret method)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> Base method (Ret method)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
err
    Right Ret method
v -> Either SomeException (Ret method) -> Base method ()
after Either SomeException (Ret method)
res Base method ()
-> Base method (Ret method) -> Base method (Ret method)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ret method -> Base method (Ret method)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ret method
v

-- | Insert hooks only before calling the argument method.
--   Because it's free from 'MonadUnliftIO' constraint,
--   any methods are supported.
{-# INLINE decorateBefore_ #-}
decorateBefore_ ::
  (Method method) =>
  (Args method -> Base method ()) ->
  method ->
  method
decorateBefore_ :: (Args method -> Base method ()) -> method -> method
decorateBefore_ Args method -> Base method ()
before method
method = (Args method -> Base method (Ret method)) -> method
forall method.
Method method =>
(Args method -> Base method (Ret method)) -> method
curryMethod ((Args method -> Base method (Ret method)) -> method)
-> (Args method -> Base method (Ret method)) -> method
forall a b. (a -> b) -> a -> b
$ \Args method
args -> do
  Args method -> Base method ()
before Args method
args
  method -> Args method -> Base method (Ret method)
forall method.
Method method =>
method -> Args method -> Base method (Ret method)
uncurryMethod method
method Args method
args

-- | invoke method taken from reader environment
{-# INLINE invoke #-}
invoke :: (MonadReader env (Base method), Method method) => SimpleGetter env method -> method
invoke :: SimpleGetter env method -> method
invoke SimpleGetter env method
getter = Base method method -> method
forall method. Method method => Base method method -> method
liftJoin (Getting method env method -> Base method method
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting method env method
SimpleGetter env method
getter)

-- | Natural transformation from @m@ to @n@
type NT m n = forall a. m a -> n a

class LiftNT f g where
  type BaseFrom f :: Type -> Type
  type BaseTo g :: Type -> Type
  liftNT :: NT (BaseFrom f) (BaseTo g) -> f p -> g p

instance (Method c1, Method c2, Args c1 ~ Args c2, Ret c1 ~ Ret c2) => LiftNT (K1 i1 c1) (K1 i2 c2) where
  type BaseFrom (K1 i1 c1) = Base c1
  type BaseTo (K1 i2 c2) = Base c2
  {-# INLINE liftNT #-}
  liftNT :: NT (BaseFrom (K1 i1 c1)) (BaseTo (K1 i2 c2))
-> K1 i1 c1 p -> K1 i2 c2 p
liftNT NT (BaseFrom (K1 i1 c1)) (BaseTo (K1 i2 c2))
nt (K1 c1
s) = c2 -> K1 i2 c2 p
forall k i c (p :: k). c -> K1 i c p
K1 (c2 -> K1 i2 c2 p) -> c2 -> K1 i2 c2 p
forall a b. (a -> b) -> a -> b
$
    (Args c2 -> Base c2 (Ret c2)) -> c2
forall method.
Method method =>
(Args method -> Base method (Ret method)) -> method
curryMethod ((Args c2 -> Base c2 (Ret c2)) -> c2)
-> (Args c2 -> Base c2 (Ret c2)) -> c2
forall a b. (a -> b) -> a -> b
$ \Args c2
args ->
      BaseFrom (K1 i1 c1) (Ret c2) -> BaseTo (K1 i2 c2) (Ret c2)
NT (BaseFrom (K1 i1 c1)) (BaseTo (K1 i2 c2))
nt (BaseFrom (K1 i1 c1) (Ret c2) -> BaseTo (K1 i2 c2) (Ret c2))
-> BaseFrom (K1 i1 c1) (Ret c2) -> BaseTo (K1 i2 c2) (Ret c2)
forall a b. (a -> b) -> a -> b
$ c1 -> Args c1 -> Base c1 (Ret c1)
forall method.
Method method =>
method -> Args method -> Base method (Ret method)
uncurryMethod c1
s Args c1
Args c2
args

instance LiftNT f1 f2 => LiftNT (M1 i1 t1 f1) (M1 i2 t2 f2) where
  type BaseFrom (M1 i1 t1 f1) = BaseFrom f1
  type BaseTo (M1 i2 t2 f2) = BaseTo f2
  {-# INLINE liftNT #-}
  liftNT :: NT (BaseFrom (M1 i1 t1 f1)) (BaseTo (M1 i2 t2 f2))
-> M1 i1 t1 f1 p -> M1 i2 t2 f2 p
liftNT NT (BaseFrom (M1 i1 t1 f1)) (BaseTo (M1 i2 t2 f2))
nt (M1 f1 p
f1) = f2 p -> M1 i2 t2 f2 p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f2 p -> M1 i2 t2 f2 p) -> f2 p -> M1 i2 t2 f2 p
forall a b. (a -> b) -> a -> b
$ NT (BaseFrom f1) (BaseTo f2) -> f1 p -> f2 p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
LiftNT f g =>
NT (BaseFrom f) (BaseTo g) -> f p -> g p
liftNT NT (BaseFrom f1) (BaseTo f2)
NT (BaseFrom (M1 i1 t1 f1)) (BaseTo (M1 i2 t2 f2))
nt f1 p
f1

instance
  (LiftNT f1 g1, LiftNT f2 g2, BaseFrom f1 ~ BaseFrom f2, BaseTo g1 ~ BaseTo g2) =>
  LiftNT (f1 :*: f2) (g1 :*: g2)
  where
  type BaseFrom (f1 :*: f2) = BaseFrom f1
  type BaseTo (g1 :*: g2) = BaseTo g1
  {-# INLINE liftNT #-}
  liftNT :: NT (BaseFrom (f1 :*: f2)) (BaseTo (g1 :*: g2))
-> (:*:) f1 f2 p -> (:*:) g1 g2 p
liftNT NT (BaseFrom (f1 :*: f2)) (BaseTo (g1 :*: g2))
nt (f1 p
f1 :*: f2 p
f2) = NT (BaseFrom f1) (BaseTo g1) -> f1 p -> g1 p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
LiftNT f g =>
NT (BaseFrom f) (BaseTo g) -> f p -> g p
liftNT NT (BaseFrom f1) (BaseTo g1)
NT (BaseFrom (f1 :*: f2)) (BaseTo (g1 :*: g2))
nt f1 p
f1 g1 p -> g2 p -> (:*:) g1 g2 p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: NT (BaseFrom f2) (BaseTo g2) -> f2 p -> g2 p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
LiftNT f g =>
NT (BaseFrom f) (BaseTo g) -> f p -> g p
liftNT NT (BaseFrom f2) (BaseTo g2)
NT (BaseFrom (f1 :*: f2)) (BaseTo (g1 :*: g2))
nt f2 p
f2

instance
  (LiftNT f1 g1, LiftNT f2 g2, BaseFrom f1 ~ BaseFrom f2, BaseTo g1 ~ BaseTo g2) =>
  LiftNT (f1 :+: f2) (g1 :+: g2)
  where
  type BaseFrom (f1 :+: f2) = BaseFrom f1
  type BaseTo (g1 :+: g2) = BaseTo g1
  {-# INLINE liftNT #-}
  liftNT :: NT (BaseFrom (f1 :+: f2)) (BaseTo (g1 :+: g2))
-> (:+:) f1 f2 p -> (:+:) g1 g2 p
liftNT NT (BaseFrom (f1 :+: f2)) (BaseTo (g1 :+: g2))
nt (L1 f1 p
f1) = g1 p -> (:+:) g1 g2 p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (g1 p -> (:+:) g1 g2 p) -> g1 p -> (:+:) g1 g2 p
forall a b. (a -> b) -> a -> b
$ NT (BaseFrom f1) (BaseTo g1) -> f1 p -> g1 p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
LiftNT f g =>
NT (BaseFrom f) (BaseTo g) -> f p -> g p
liftNT NT (BaseFrom f1) (BaseTo g1)
NT (BaseFrom (f1 :+: f2)) (BaseTo (g1 :+: g2))
nt f1 p
f1
  liftNT NT (BaseFrom (f1 :+: f2)) (BaseTo (g1 :+: g2))
nt (R1 f2 p
f2) = g2 p -> (:+:) g1 g2 p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g2 p -> (:+:) g1 g2 p) -> g2 p -> (:+:) g1 g2 p
forall a b. (a -> b) -> a -> b
$ NT (BaseFrom f2) (BaseTo g2) -> f2 p -> g2 p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
LiftNT f g =>
NT (BaseFrom f) (BaseTo g) -> f p -> g p
liftNT NT (BaseFrom f2) (BaseTo g2)
NT (BaseFrom (f1 :+: f2)) (BaseTo (g1 :+: g2))
nt f2 p
f2

-- | "Interface" is a record whose fields are methods.
--   The instance can be derived via 'Generic'. Here is an example:
--
--   @
--   {-\# LANGUAGE DeriveGeneric \#-}
--   {-\# LANGUAGE TypeFamilies  \#-}
--   data FizzBuzz env = FizzBuzz {
--     printFizz :: RIO env (),
--     printBuzz :: RIO env (),
--     printFizzBuzz :: RIO env (),
--     printInt :: Int -> RIO env ()
--   } deriving(Generic)
--
--   instance Interface FizzBuzz where
--     type IBase FizzBuzz = RIO
--   @
--
--  ====Notes
--
--   * @iface@ takes an (poly-kinded) type parameter @k@,
--     which is the parameter to specify the base monad.
--   * Base monads of each fields must be the same.
--     (Interface cannot contain any fields which are not a method)
class Interface (iface :: k -> Type) where
  -- | @IBase iface k@ is the base monad for each method of the interface.
  type IBase iface :: k -> Type -> Type

  mapBase :: NT (IBase iface p) (IBase iface q) -> iface p -> iface q
  default mapBase ::
    ( Generic (iface p),
      Generic (iface q),
      LiftNT (Rep (iface p)) (Rep (iface q)),
      BaseFrom (Rep (iface p)) ~ IBase iface p,
      BaseTo (Rep (iface q)) ~ IBase iface q
    ) =>
    NT (IBase iface p) (IBase iface q) ->
    iface p ->
    iface q
  mapBase NT (IBase iface p) (IBase iface q)
nt iface p
s = Rep (iface q) Any -> iface q
forall a x. Generic a => Rep a x -> a
to (Rep (iface q) Any -> iface q) -> Rep (iface q) Any -> iface q
forall a b. (a -> b) -> a -> b
$ NT (BaseFrom (Rep (iface p))) (BaseTo (Rep (iface q)))
-> Rep (iface p) Any -> Rep (iface q) Any
forall k (f :: k -> *) (g :: k -> *) (p :: k).
LiftNT f g =>
NT (BaseFrom f) (BaseTo g) -> f p -> g p
liftNT NT (IBase iface p) (IBase iface q)
NT (BaseFrom (Rep (iface p))) (BaseTo (Rep (iface q)))
nt (Rep (iface p) Any -> Rep (iface q) Any)
-> Rep (iface p) Any -> Rep (iface q) Any
forall a b. (a -> b) -> a -> b
$ iface p -> Rep (iface p) Any
forall a x. Generic a => a -> Rep a x
from iface p
s

-- | Specilized version of @mapBase@ for 'RIO'.
mapBaseRIO :: (Interface iface, IBase iface ~ RIO) => (env -> env') -> iface env' -> iface env
mapBaseRIO :: (env -> env') -> iface env' -> iface env
mapBaseRIO env -> env'
f = NT (IBase iface env') (IBase iface env) -> iface env' -> iface env
forall k (iface :: k -> *) (p :: k) (q :: k).
Interface iface =>
NT (IBase iface p) (IBase iface q) -> iface p -> iface q
mapBase (\IBase iface env' a
m -> RIO env env
forall r (m :: * -> *). MonadReader r m => m r
ask RIO env env -> (env -> RIO env a) -> RIO env a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \env
env -> IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> RIO env a) -> IO a -> RIO env a
forall a b. (a -> b) -> a -> b
$ env' -> RIO env' a -> IO a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO (env -> env'
f env
env) RIO env' a
IBase iface env' a
m)