{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{- | The 'Algebra' class is the mechanism with which effects are interpreted.

An instance of the 'Algebra' class defines an interpretation of an effect signature atop a given monad.

@since 1.0.0.0
-}
module Control.Algebra
( Algebra(..)
, thread
, run
, Has
, send
  -- * Re-exports
, Handler
, (~<~)
, (:+:) (..)
) where

import           Control.Algebra.Handler
import           Control.Effect.Catch.Internal
import           Control.Effect.Choose.Internal
import           Control.Effect.Empty.Internal
import           Control.Effect.Error.Internal
import           Control.Effect.Lift.Internal
import           Control.Effect.NonDet.Internal
import           Control.Effect.Reader.Internal
import           Control.Effect.State.Internal
import           Control.Effect.Sum ((:+:)(..), Member(..), Members)
import           Control.Effect.Throw.Internal
import           Control.Effect.Writer.Internal
import qualified Control.Monad.Trans.Except as Except
import qualified Control.Monad.Trans.Identity as Identity
import qualified Control.Monad.Trans.Maybe as Maybe
import qualified Control.Monad.Trans.Reader as Reader
#if MIN_VERSION_transformers(0,5,6)
import qualified Control.Monad.Trans.RWS.CPS as RWS.CPS
#endif
import qualified Control.Monad.Trans.RWS.Lazy as RWS.Lazy
import qualified Control.Monad.Trans.RWS.Strict as RWS.Strict
import qualified Control.Monad.Trans.State.Lazy as State.Lazy
import qualified Control.Monad.Trans.State.Strict as State.Strict
#if MIN_VERSION_transformers(0,5,6)
import qualified Control.Monad.Trans.Writer.CPS as Writer.CPS
#endif
import qualified Control.Monad.Trans.Writer.Lazy as Writer.Lazy
import qualified Control.Monad.Trans.Writer.Strict as Writer.Strict
import           Data.Functor.Compose
import           Data.Functor.Identity
import           Data.List.NonEmpty (NonEmpty(..))
import           Data.Monoid

-- | The class of carriers (results) for algebras (effect handlers) over signatures (effects), whose actions are given by the 'alg' method.
--
-- @since 1.0.0.0
class Monad m => Algebra sig m | m -> sig where
  -- | Interpret an effect, running any nested actions using a 'Handler' starting from an initial state in @ctx@.
  --
  -- Instances receive a signature of effects containing actions in @n@ which can be lowered to @m@ using the passed 'Handler' and initial context. Continuations in @n@ can be handled after mapping into contexts returned from previous actions.
  --
  -- For example, considering the 'Algebra' instance for @'Either' e@:
  --
  -- > instance Algebra (Error e) (Either e) where
  -- >   alg hdl sig ctx = case sig of
  -- >     L (Throw e)   -> Left e
  -- >     R (Catch m h) -> either (hdl . (<$ ctx) . h) pure (hdl (m <$ ctx))
  --
  -- The 'Catch' case holds actions @m :: n x@ and @h :: e -> n x@ (for some existentially-quantified type @x@), and a continuation @k :: x -> n a@. The algebra must return @m (ctx a)@, so we have to ultimately use and lower the continuation in order to produce that type. The continuation takes an @x@, which we can get from either of the actions, after lowering them to values in @'Either' e@.
  --
  -- To that end, the algebra lifts both the action @m@ and the result of the error handler @h@ into the initial context @ctx@ before lowering them with @hdl@. The continuation @k@ is 'fmap'ed into the resulting context and then itself lowered with @hdl@.
  --
  -- By contrast, the 'Throw' case can simply return a value in 'Left', since there is no continuation to call—it represents an exceptional return—and @'Left' e :: forall a . Either e a@ (i.e. 'Left' is polymorphic in @a@).
  --
  -- Instances for monad transformers will most likely handle a signature containing multiple effects, with the tail of the signature handled by whatever monad the transformer wraps. In these cases, the tail of the signature can be delegated most conveniently using 'thread'; see the 'Algebra' instances for @transformers@ types such as 'Reader.ReaderT' and 'Except.ExceptT' for details.
  alg
    :: Functor ctx
    => Handler ctx n m -- ^ A 'Handler' lowering computations inside the effect into the carrier type @m@.
    -> sig n a         -- ^ The effect signature to be interpreted.
    -> ctx ()          -- ^ The initial state.
    -> m (ctx a)       -- ^ The interpretation of the effect in @m@.

-- | Thread a composed handler and input state through the algebra for some underlying signature.
--
-- @since 1.1.0.0
thread
  :: ( Functor ctx1
     , Functor ctx2
     , Algebra sig m
     )
  => Handler (Compose ctx1 ctx2) n m
  -> sig n a
  -> ctx1 (ctx2 ())
  -> m (ctx1 (ctx2 a))
thread hdl sig = fmap getCompose . alg hdl sig . Compose
{-# INLINE thread #-}


-- | Run an action exhausted of effects to produce its final result value.
--
-- @since 1.0.0.0
run :: Identity a -> a
run = runIdentity
{-# INLINE run #-}


-- | @m@ is a carrier for @sig@ containing @eff@.
--
-- Note that if @eff@ is a sum, it will be decomposed into multiple 'Member' constraints. While this technically allows one to combine multiple unrelated effects into a single 'Has' constraint, doing so has two significant drawbacks:
--
-- 1. Due to [a problem with recursive type families](https://gitlab.haskell.org/ghc/ghc/issues/8095), this can lead to significantly slower compiles.
--
-- 2. It defeats @ghc@’s warnings for redundant constraints, and thus can lead to a proliferation of redundant constraints as code is changed.
--
-- @since 1.0.0.0
type Has eff sig m = (Members eff sig, Algebra sig m)

-- | Construct a request for an effect to be interpreted by some handler later on.
--
-- @since 0.1.0.0
send :: (Member eff sig, Algebra sig m) => eff m a -> m a
send sig = runIdentity <$> alg (fmap Identity . runIdentity) (inj sig) (Identity ())
{-# INLINE send #-}


-- base

instance Algebra (Lift IO) IO where
  alg hdl (LiftWith with) = with hdl
  {-# INLINE alg #-}

instance Algebra (Lift Identity) Identity where
  alg hdl (LiftWith with) = with hdl
  {-# INLINE alg #-}

instance Algebra Choose NonEmpty where
  alg _ Choose ctx = (True <$ ctx) :| [ False <$ ctx ]
  {-# INLINE alg #-}

instance Algebra Empty Maybe where
  alg _ Empty _ = Nothing
  {-# INLINE alg #-}

instance Algebra (Error e) (Either e) where
  alg hdl sig ctx = case sig of
    L (Throw e)   -> Left e
    R (Catch m h) -> either (hdl . (<$ ctx) . h) pure (hdl (m <$ ctx))
  {-# INLINE alg #-}

instance Algebra (Reader r) ((->) r) where
  alg hdl sig ctx = case sig of
    Ask       -> (<$ ctx)
    Local f m -> hdl (m <$ ctx) . f
  {-# INLINE alg #-}

instance Algebra NonDet [] where
  alg _ sig ctx = case sig of
    L Empty  -> []
    R Choose -> [ True <$ ctx, False <$ ctx ]
  {-# INLINE alg #-}

instance Monoid w => Algebra (Writer w) ((,) w) where
  alg hdl sig ctx = case sig of
    Tell w     -> (w, ctx)
    Listen m   -> let (w, a) = hdl (m <$ ctx) in (w, (,) w <$> a)
    Censor f m -> let (w, a) = hdl (m <$ ctx) in (f w, a)
  {-# INLINE alg #-}


-- transformers

instance Algebra sig m => Algebra (Error e :+: sig) (Except.ExceptT e m) where
  alg hdl sig ctx = case sig of
    L (L (Throw e))   -> Except.throwE e
    L (R (Catch m h)) -> Except.catchE (hdl (m <$ ctx)) (hdl . (<$ ctx) . h)
    R other           -> Except.ExceptT $ thread (either (pure . Left) Except.runExceptT ~<~ hdl) other (Right ctx)
  {-# INLINE alg #-}


deriving instance Algebra sig m => Algebra sig (Identity.IdentityT m)

#if MIN_VERSION_base(4,12,0)
-- | This instance permits effectful actions to be lifted into the 'Ap' monad
-- given a monoidal return type, which can provide clarity when chaining calls
-- to 'mappend'.
--
-- > mappend <$> act1 <*> (mappend <$> act2 <*> act3)
--
-- is equivalent to
--
-- > getAp (act1 <> act2 <> act3)
--
-- @since 1.0.1.0
deriving instance Algebra sig m => Algebra sig (Ap m)
#endif

-- | This instance permits effectful actions to be lifted into the 'Alt' monad,
-- which eases the invocation of repeated alternation with 'Control.Applicative.<|>':
--
-- > a <|> b <|> c <|> d
--
-- is equivalent to
--
-- > getAlt (mconcat [a, b, c, d])
--
-- @since 1.0.1.0
deriving instance Algebra sig m => Algebra sig (Alt m)


instance Algebra sig m => Algebra (Empty :+: sig) (Maybe.MaybeT m) where
  alg hdl sig ctx = case sig of
    L Empty -> Maybe.MaybeT (pure Nothing)
    R other -> Maybe.MaybeT $ thread (maybe (pure Nothing) Maybe.runMaybeT ~<~ hdl) other (Just ctx)
  {-# INLINE alg #-}


instance Algebra sig m => Algebra (Reader r :+: sig) (Reader.ReaderT r m) where
  alg hdl sig ctx = case sig of
    L Ask         -> Reader.asks (<$ ctx)
    L (Local f m) -> Reader.local f (hdl (m <$ ctx))
    R other       -> Reader.ReaderT $ \ r -> alg ((`Reader.runReaderT` r) . hdl) other ctx
  {-# INLINE alg #-}


newtype RWSTF w s a = RWSTF { unRWSTF :: (a, s, w) }
  deriving (Functor)

toRWSTF :: Monoid w => w -> (a, s, w) -> RWSTF w s a
toRWSTF w (a, s, w') = RWSTF (a, s, mappend w w')
{-# INLINE toRWSTF #-}

newtype Swap s a = Swap { getSwap :: (a, s) }
  deriving (Functor)

swapAndLift :: Functor ctx => (ctx a, w) -> ctx (w, a)
swapAndLift p = (,) (snd p) <$> fst p
{-# INLINE swapAndLift #-}

#if MIN_VERSION_transformers(0,5,6)
instance (Algebra sig m, Monoid w) => Algebra (Reader r :+: Writer w :+: State s :+: sig) (RWS.CPS.RWST r w s m) where
  alg hdl sig ctx = case sig of
    L Ask              -> RWS.CPS.asks (<$ ctx)
    L (Local f m)      -> RWS.CPS.local f (hdl (m <$ ctx))
    R (L (Tell w))     -> ctx <$ RWS.CPS.tell w
    R (L (Listen m))   -> swapAndLift <$> RWS.CPS.listen (hdl (m <$ ctx))
    R (L (Censor f m)) -> RWS.CPS.censor f (hdl (m <$ ctx))
    R (R (L Get))      -> RWS.CPS.gets (<$ ctx)
    R (R (L (Put s)))  -> ctx <$ RWS.CPS.put s
    R (R (R other))    -> RWS.CPS.rwsT $ \ r s -> unRWSTF <$> thread ((\ (RWSTF (x, s, w)) -> toRWSTF w <$> RWS.CPS.runRWST x r s) ~<~ hdl) other (RWSTF (ctx, s, mempty))
  {-# INLINE alg #-}
#endif

instance (Algebra sig m, Monoid w) => Algebra (Reader r :+: Writer w :+: State s :+: sig) (RWS.Lazy.RWST r w s m) where
  alg hdl sig ctx = case sig of
    L Ask              -> RWS.Lazy.asks (<$ ctx)
    L (Local f m)      -> RWS.Lazy.local f (hdl (m <$ ctx))
    R (L (Tell w))     -> ctx <$ RWS.Lazy.tell w
    R (L (Listen m))   -> swapAndLift <$> RWS.Lazy.listen (hdl (m <$ ctx))
    R (L (Censor f m)) -> RWS.Lazy.censor f (hdl (m <$ ctx))
    R (R (L Get))      -> RWS.Lazy.gets (<$ ctx)
    R (R (L (Put s)))  -> ctx <$ RWS.Lazy.put s
    R (R (R other))    -> RWS.Lazy.RWST $ \ r s -> unRWSTF <$> thread ((\ (RWSTF (x, s, w)) -> toRWSTF w <$> RWS.Lazy.runRWST x r s) ~<~ hdl) other (RWSTF (ctx, s, mempty))
  {-# INLINE alg #-}

instance (Algebra sig m, Monoid w) => Algebra (Reader r :+: Writer w :+: State s :+: sig) (RWS.Strict.RWST r w s m) where
  alg hdl sig ctx = case sig of
    L Ask              -> RWS.Strict.asks (<$ ctx)
    L (Local f m)      -> RWS.Strict.local f (hdl (m <$ ctx))
    R (L (Tell w))     -> ctx <$ RWS.Strict.tell w
    R (L (Listen m))   -> swapAndLift <$> RWS.Strict.listen (hdl (m <$ ctx))
    R (L (Censor f m)) -> RWS.Strict.censor f (hdl (m <$ ctx))
    R (R (L Get))      -> RWS.Strict.gets (<$ ctx)
    R (R (L (Put s)))  -> ctx <$ RWS.Strict.put s
    R (R (R other))    -> RWS.Strict.RWST $ \ r s -> unRWSTF <$> thread ((\ (RWSTF (x, s, w)) -> toRWSTF w <$> RWS.Strict.runRWST x r s) ~<~ hdl) other (RWSTF (ctx, s, mempty))
  {-# INLINE alg #-}


instance Algebra sig m => Algebra (State s :+: sig) (State.Lazy.StateT s m) where
  alg hdl sig ctx = case sig of
    L Get     -> State.Lazy.gets (<$ ctx)
    L (Put s) -> ctx <$ State.Lazy.put s
    R other   -> State.Lazy.StateT $ \ s -> getSwap <$> thread (fmap Swap . uncurry State.Lazy.runStateT . getSwap ~<~ hdl) other (Swap (ctx, s))
  {-# INLINE alg #-}

instance Algebra sig m => Algebra (State s :+: sig) (State.Strict.StateT s m) where
  alg hdl sig ctx = case sig of
    L Get     -> State.Strict.gets (<$ ctx)
    L (Put s) -> ctx <$ State.Strict.put s
    R other   -> State.Strict.StateT $ \ s -> getSwap <$> thread (fmap Swap . uncurry State.Strict.runStateT . getSwap ~<~ hdl) other (Swap (ctx, s))
  {-# INLINE alg #-}


#if MIN_VERSION_transformers(0,5,6)
instance (Algebra sig m, Monoid w) => Algebra (Writer w :+: sig) (Writer.CPS.WriterT w m) where
  alg hdl sig ctx = case sig of
    L (Tell w)     -> ctx <$ Writer.CPS.tell w
    L (Listen m)   -> swapAndLift <$> Writer.CPS.listen (hdl (m <$ ctx))
    L (Censor f m) -> Writer.CPS.censor f (hdl (m <$ ctx))
    R other        -> Writer.CPS.writerT $ getSwap <$> thread ((\ (Swap (x, s)) -> Swap . fmap (mappend s) <$> Writer.CPS.runWriterT x) ~<~ hdl) other (Swap (ctx, mempty))
  {-# INLINE alg #-}
#endif

instance (Algebra sig m, Monoid w) => Algebra (Writer w :+: sig) (Writer.Lazy.WriterT w m) where
  alg hdl sig ctx = case sig of
    L (Tell w)     -> ctx <$ Writer.Lazy.tell w
    L (Listen m)   -> swapAndLift <$> Writer.Lazy.listen (hdl (m <$ ctx))
    L (Censor f m) -> Writer.Lazy.censor f (hdl (m <$ ctx))
    R other        -> Writer.Lazy.WriterT $ getSwap <$> thread ((\ (Swap (x, s)) -> Swap . fmap (mappend s) <$> Writer.Lazy.runWriterT x) ~<~ hdl) other (Swap (ctx, mempty))
  {-# INLINE alg #-}

instance (Algebra sig m, Monoid w) => Algebra (Writer w :+: sig) (Writer.Strict.WriterT w m) where
  alg hdl sig ctx = case sig of
    L (Tell w)     -> ctx <$ Writer.Strict.tell w
    L (Listen m)   -> swapAndLift <$> Writer.Strict.listen (hdl (m <$ ctx))
    L (Censor f m) -> Writer.Strict.censor f (hdl (m <$ ctx))
    R other        -> Writer.Strict.WriterT $ getSwap <$> thread ((\ (Swap (x, s)) -> Swap . fmap (mappend s) <$> Writer.Strict.runWriterT x) ~<~ hdl) other (Swap (ctx, mempty))
  {-# INLINE alg #-}