fused-effects TypedAlgebra for composing effects

TypedAlgebra.hs

{-# LANGUAGE
    FunctionalDependencies
  , UndecidableInstances
  #-}
module Control.Carrier.DependsOn where

import Control.Algebra
import Control.Applicative
import Control.Carrier.Error.Either
import Control.Effect.State
import Control.Monad.Base
import Control.Monad.Catch          hiding (Handler)
import Control.Monad.IO.Class       (MonadIO)
import Control.Monad.Logger         (MonadLogger)
import Control.Monad.Trans.Control
import Control.Monad.Trans.State    (StateT)
import Data.Kind

-- needs to define tree of effect carriers with their private dependencies
-- example:
--     (AwsClientC `DependsOn` HttpClientC :# ReaderC (HttpCtx AWS))
--  :# (HackageClientC `DependsOn` HttpClientC :# ReaderC (HttpCtx Hackage))

type CarrierKind = (Type -> Type) -> Type -> Type
type SigKind     = (Type -> Type) -> Type -> Type

class
     Algebra (addsSig :+: baseSig) (c m)
  => TypedAlgebra baseSig addsSig m c | c -> addsSig

instance Algebra sig m => TypedAlgebra sig (Error e) m (ErrorC e)
instance Algebra sig m => TypedAlgebra sig (State s) m (StateT s)

newtype DependsOn (t :: CarrierKind) (u :: CarrierKind) m a = DependsOnC { runDependsOnC :: t (u m) a }
  deriving newtype
    ( Functor, Applicative, Monad, MonadIO, MonadBase b, MonadBaseControl b
    , MonadThrow, MonadCatch, MonadMask, MonadLogger )

type DependsOnCons addsSigT addsSigU baseSig t u m =
  ( TypedAlgebra (addsSigU :+: baseSig) addsSigT (u m) t
  , TypedAlgebra baseSig                addsSigU m     u
  , Algebra baseSig m
  )

instance
  DependsOnCons addsSigT addsSigU baseSig t u m
  => Algebra (addsSigT :+: baseSig) (DependsOn t u m)
  where
    alg hdl sig ctx = case sig of
      L addsSig -> DependsOnC $ alg (runDependsOnC . hdl) (L addsSig)     ctx
      R baseSig -> DependsOnC $ alg (runDependsOnC . hdl) (R (R baseSig)) ctx
    {-# INLINE alg #-}

instance
  DependsOnCons addsSigT addsSigU baseSig t u m
  => TypedAlgebra baseSig addsSigT m (DependsOn t u)

newtype ((t :: CarrierKind) :# (u :: CarrierKind)) (m :: Type -> Type) a = ComposeC { runComposeC :: t (u m) a }
  deriving newtype
    ( Functor, Applicative, Monad, MonadFail, MonadIO, Alternative
    , MonadThrow, MonadCatch, MonadMask, MonadLogger )

type ComposeCCons addsSigU addsSigT baseSig t u m =
  ( TypedAlgebra (addsSigU :+: baseSig) addsSigT (u m) t
  , TypedAlgebra baseSig                addsSigU m     u
  , Algebra baseSig m
  )

instance
     ComposeCCons addsSigU addsSigT baseSig t u m
  => Algebra ((addsSigT :+: addsSigU) :+: baseSig) ((t :# u) m)
  where
    alg hdl sig ctx = case sig of
      L (L addsSigT) -> ComposeC $ alg (runComposeC . hdl) (L addsSigT)     ctx
      L (R addsSigU) -> ComposeC $ alg (runComposeC . hdl) (R (L addsSigU)) ctx
      R baseSig      -> ComposeC $ alg (runComposeC . hdl) (R (R baseSig))  ctx
    {-# INLINE alg #-}

instance
     ComposeCCons addsSigU addsSigT baseSig t u m
  => TypedAlgebra baseSig (addsSigT :+: addsSigU) m (t :# u)