{-# LANGUAGE TemplateHaskell #-}
module Polysemy.Final
  (
    -- * Effect
    Final(..)
  , ThroughWeavingToFinal

    -- * Actions
  , withWeavingToFinal
  , withStrategicToFinal
  , embedFinal

    -- * Combinators for Interpreting to the Final Monad
  , interpretFinal

    -- * Strategy
    -- | Strategy is a domain-specific language very similar to @Tactics@
    -- (see 'Polysemy.Tactical'), and is used to describe how higher-order
    -- effects are threaded down to the final monad.
    --
    -- Much like @Tactics@, computations can be run and threaded
    -- through the use of 'runS' and 'bindS', and first-order constructors
    -- may use 'pureS'. In addition, 'liftS' may be used to
    -- lift actions of the final monad.
    --
    -- Unlike @Tactics@, the final return value within a 'Strategic'
    -- must be a monadic value of the target monad
    -- with the functorial state wrapped inside of it.
  , Strategic
  , WithStrategy
  , pureS
  , liftS
  , runS
  , bindS
  , getInspectorS
  , getInitialStateS

    -- * Interpretations
  , runFinal
  , finalToFinal

  -- * Interpretations for Other Effects
  , embedToFinal
  ) where

import Polysemy.Internal
import Polysemy.Internal.Combinators
import Polysemy.Internal.Union
import Polysemy.Internal.Strategy
import Polysemy.Internal.TH.Effect

-----------------------------------------------------------------------------
-- | This represents a function which produces
-- an action of the final monad @m@ given:
--
--   * The initial effectful state at the moment the action
--     is to be executed.
--
--   * A way to convert @z@ (which is typically @'Sem' r@) to @m@ by
--     threading the effectful state through.
--
--   * An inspector that is able to view some value within the
--     effectful state if the effectful state contains any values.
--
-- A @'Polysemy.Internal.Union.Weaving'@ provides these components,
-- hence the name 'ThroughWeavingToFinal'.
--
-- @since 1.2.0.0
type ThroughWeavingToFinal m z a =
     forall f
   . Functor f
  => f ()
  -> (forall x. f (z x) -> m (f x))
  -> (forall x. f x -> Maybe x)
  -> m (f a)

-----------------------------------------------------------------------------
-- | An effect for embedding higher-order actions in the final target monad
-- of the effect stack.
--
-- This is very useful for writing interpreters that interpret higher-order
-- effects in terms of the final monad.
--
-- 'Final' is more powerful than 'Embed', but is also less flexible
-- to interpret (compare 'Polysemy.Embed.runEmbedded' with 'finalToFinal').
-- If you only need the power of 'embed', then you should use 'Embed' instead.
--
-- /Beware/: 'Final' actions are interpreted as actions of the final monad,
-- and the effectful state visible to
-- 'withWeavingToFinal' \/ 'withStrategicToFinal'
-- \/ 'interpretFinal'
-- is that of /all interpreters run in order to produce the final monad/.
--
-- This means that any interpreter built using 'Final' will /not/
-- respect local/global state semantics based on the order of
-- interpreters run. You should signal interpreters that make use of
-- 'Final' by adding a @-'Final'@ suffix to the names of these.
--
-- State semantics of effects that are /not/
-- interpreted in terms of the final monad will always
-- appear local to effects that are interpreted in terms of the final monad.
--
-- State semantics between effects that are interpreted in terms of the final monad
-- depend on the final monad. For example, if the final monad is a monad transformer
-- stack, then state semantics will depend on the order monad transformers are stacked.
--
-- @since 1.2.0.0
newtype Final m z a where
  WithWeavingToFinal
    :: ThroughWeavingToFinal m z a
    -> Final m z a

makeSem_ ''Final

-----------------------------------------------------------------------------
-- | Allows for embedding higher-order actions of the final monad
-- by providing the means of explicitly threading effects through @'Sem' r@
-- to the final monad.
--
-- Consider using 'withStrategicToFinal' instead,
-- which provides a more user-friendly interface, but is also slightly weaker.
--
-- You are discouraged from using 'withWeavingToFinal' directly
-- in application code, as it ties your application code directly to
-- the final monad.
--
-- @since 1.2.0.0
withWeavingToFinal
  :: forall m r a
   . Member (Final m) r
  => ThroughWeavingToFinal m (Sem r) a
  -> Sem r a


-----------------------------------------------------------------------------
-- | 'withWeavingToFinal' admits an implementation of 'embed'.
--
-- Just like 'embed', you are discouraged from using this in application code.
--
-- @since 1.2.0.0
embedFinal :: (Member (Final m) r, Functor m) => m a -> Sem r a
embedFinal :: m a -> Sem r a
embedFinal m a
m = ThroughWeavingToFinal m (Sem r) a -> Sem r a
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Final m) r =>
ThroughWeavingToFinal m (Sem r) a -> Sem r a
withWeavingToFinal (ThroughWeavingToFinal m (Sem r) a -> Sem r a)
-> ThroughWeavingToFinal m (Sem r) a -> Sem r a
forall a b. (a -> b) -> a -> b
$ \f ()
s forall x. f (Sem r x) -> m (f x)
_ forall x. f x -> Maybe x
_ -> (a -> f () -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s) (a -> f a) -> m a -> m (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
m
{-# INLINE embedFinal #-}

-----------------------------------------------------------------------------
-- | Allows for embedding higher-order actions of the final monad
-- by providing the means of explicitly threading effects through @'Sem' r@
-- to the final monad. This is done through the use of the 'Strategic'
-- environment, which provides 'runS' and 'bindS'.
--
-- You are discouraged from using 'withStrategicToFinal' in application code,
-- as it ties your application code directly to the final monad.
--
-- @since 1.2.0.0
withStrategicToFinal :: Member (Final m) r
                     => Strategic m (Sem r) a
                     -> Sem r a
withStrategicToFinal :: Strategic m (Sem r) a -> Sem r a
withStrategicToFinal Strategic m (Sem r) a
strat = ThroughWeavingToFinal m (Sem r) a -> Sem r a
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Final m) r =>
ThroughWeavingToFinal m (Sem r) a -> Sem r a
withWeavingToFinal (Sem '[Strategy m f (Sem r)] (m (f a))
-> f ()
-> (forall x. f (Sem r x) -> m (f x))
-> (forall x. f x -> Maybe x)
-> m (f a)
forall (f :: * -> *) (m :: * -> *) (n :: * -> *) a.
Functor f =>
Sem '[Strategy m f n] a
-> f ()
-> (forall x. f (n x) -> m (f x))
-> (forall x. f x -> Maybe x)
-> a
runStrategy Sem '[Strategy m f (Sem r)] (m (f a))
Strategic m (Sem r) a
strat)
{-# INLINE withStrategicToFinal #-}

------------------------------------------------------------------------------
-- | Like 'interpretH', but may be used to
-- interpret higher-order effects in terms of the final monad.
--
-- 'interpretFinal' requires less boilerplate than using 'interpretH'
-- together with 'withStrategicToFinal' \/ 'withWeavingToFinal',
-- but is also less powerful.
-- 'interpretFinal' does not provide any means of executing actions
-- of @'Sem' r@ as you interpret each action, and the provided interpreter
-- is automatically recursively used to process higher-order occurences of
-- @'Sem' (e ': r)@ to @'Sem' r@.
--
-- If you need greater control of how the effect is interpreted,
-- use 'interpretH' together with 'withStrategicToFinal' \/
-- 'withWeavingToFinal' instead.
--
-- /Beware/: Effects that aren't interpreted in terms of the final
-- monad will have local state semantics in regards to effects
-- interpreted using 'interpretFinal'. See 'Final'.
--
-- @since 1.2.0.0
interpretFinal
    :: forall m e r a
     . Member (Final m) r
    => (forall x rInitial. e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
       -- ^ A natural transformation from the handled effect to the final monad.
    -> Sem (e ': r) a
    -> Sem r a
interpretFinal :: (forall x (rInitial :: [(* -> *) -> * -> *]).
 e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (e : r) a -> Sem r a
interpretFinal forall x (rInitial :: [(* -> *) -> * -> *]).
e (Sem rInitial) x -> Strategic m (Sem rInitial) x
n =
  let
    go :: Sem (e ': r) x -> Sem r x
    go :: Sem (e : r) x -> Sem r x
go = (forall x. Union (e : r) (Sem (e : r)) x -> Union r (Sem r) x)
-> Sem (e : r) x -> Sem r x
forall (r :: [(* -> *) -> * -> *]) (r' :: [(* -> *) -> * -> *]) a.
(forall x. Union r (Sem r) x -> Union r' (Sem r') x)
-> Sem r a -> Sem r' a
hoistSem ((forall x. Union (e : r) (Sem (e : r)) x -> Union r (Sem r) x)
 -> Sem (e : r) x -> Sem r x)
-> (forall x. Union (e : r) (Sem (e : r)) x -> Union r (Sem r) x)
-> Sem (e : r) x
-> Sem r x
forall a b. (a -> b) -> a -> b
$ \Union (e : r) (Sem (e : r)) x
u -> case Union (e : r) (Sem (e : r)) x
-> Either (Union r (Sem (e : r)) x) (Weaving e (Sem (e : r)) x)
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
       (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (e : r) (Sem (e : r)) x
u of
      Right (Weaving e (Sem rInitial) a
e f ()
s forall x. f (Sem rInitial x) -> Sem (e : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
ins) ->
        Weaving (Final m) (Sem r) x -> Union r (Sem r) x
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
       (m :: * -> *) a.
Member e r =>
Weaving e m a -> Union r m a
injWeaving (Weaving (Final m) (Sem r) x -> Union r (Sem r) x)
-> Weaving (Final m) (Sem r) x -> Union r (Sem r) x
forall a b. (a -> b) -> a -> b
$
          Final m (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> Sem r (f x))
-> (f a -> x)
-> (forall x. f x -> Maybe x)
-> Weaving (Final m) (Sem r) x
forall (f :: * -> *) (e :: (* -> *) -> * -> *)
       (rInitial :: [(* -> *) -> * -> *]) a resultType (mAfter :: * -> *).
Functor f =>
e (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> mAfter (f x))
-> (f a -> resultType)
-> (forall x. f x -> Maybe x)
-> Weaving e mAfter resultType
Weaving
            (ThroughWeavingToFinal m (Sem rInitial) a
-> Final m (Sem rInitial) a
forall (m :: * -> *) (z :: * -> *) a.
ThroughWeavingToFinal m z a -> Final m z a
WithWeavingToFinal (Sem '[Strategy m f (Sem rInitial)] (m (f a))
-> f ()
-> (forall x. f (Sem rInitial x) -> m (f x))
-> (forall x. f x -> Maybe x)
-> m (f a)
forall (f :: * -> *) (m :: * -> *) (n :: * -> *) a.
Functor f =>
Sem '[Strategy m f n] a
-> f ()
-> (forall x. f (n x) -> m (f x))
-> (forall x. f x -> Maybe x)
-> a
runStrategy (e (Sem rInitial) a -> Strategic m (Sem rInitial) a
forall x (rInitial :: [(* -> *) -> * -> *]).
e (Sem rInitial) x -> Strategic m (Sem rInitial) x
n e (Sem rInitial) a
e)))
            f ()
s
            (Sem (e : r) (f x) -> Sem r (f x)
forall x. Sem (e : r) x -> Sem r x
go (Sem (e : r) (f x) -> Sem r (f x))
-> (f (Sem rInitial x) -> Sem (e : r) (f x))
-> f (Sem rInitial x)
-> Sem r (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Sem rInitial x) -> Sem (e : r) (f x)
forall x. f (Sem rInitial x) -> Sem (e : r) (f x)
wv)
            f a -> x
ex
            forall x. f x -> Maybe x
ins
      Left Union r (Sem (e : r)) x
g -> (forall x. Sem (e : r) x -> Sem r x)
-> Union r (Sem (e : r)) x -> Union r (Sem r) x
forall (m :: * -> *) (n :: * -> *) (r :: [(* -> *) -> * -> *]) a.
(forall x. m x -> n x) -> Union r m a -> Union r n a
hoist forall x. Sem (e : r) x -> Sem r x
go Union r (Sem (e : r)) x
g
    {-# INLINE go #-}
  in
    Sem (e : r) a -> Sem r a
forall x. Sem (e : r) x -> Sem r x
go
{-# INLINE interpretFinal #-}

------------------------------------------------------------------------------
-- | Lower a 'Sem' containing only a single lifted, final 'Monad' into that
-- monad.
--
-- If you also need to process an @'Embed' m@ effect, use this together with
-- 'embedToFinal'.
--
-- @since 1.2.0.0
runFinal :: Monad m => Sem '[Final m] a -> m a
runFinal :: Sem '[Final m] a -> m a
runFinal = (forall x. Union '[Final m] (Sem '[Final m]) x -> m x)
-> Sem '[Final m] a -> m a
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Monad m =>
(forall x. Union r (Sem r) x -> m x) -> Sem r a -> m a
usingSem ((forall x. Union '[Final m] (Sem '[Final m]) x -> m x)
 -> Sem '[Final m] a -> m a)
-> (forall x. Union '[Final m] (Sem '[Final m]) x -> m x)
-> Sem '[Final m] a
-> m a
forall a b. (a -> b) -> a -> b
$ \Union '[Final m] (Sem '[Final m]) x
u -> case Union '[Final m] (Sem '[Final m]) x
-> Weaving (Final m) (Sem '[Final m]) x
forall (e :: (* -> *) -> * -> *) (m :: * -> *) a.
Union '[e] m a -> Weaving e m a
extract Union '[Final m] (Sem '[Final m]) x
u of
  Weaving (WithWeavingToFinal wav) f ()
s forall x. f (Sem rInitial x) -> Sem '[Final m] (f x)
wv f a -> x
ex forall x. f x -> Maybe x
ins ->
    f a -> x
ex (f a -> x) -> m (f a) -> m x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f ()
-> (forall x. f (Sem rInitial x) -> m (f x))
-> (forall x. f x -> Maybe x)
-> m (f a)
ThroughWeavingToFinal m (Sem rInitial) a
wav f ()
s (Sem '[Final m] (f x) -> m (f x)
forall (m :: * -> *) a. Monad m => Sem '[Final m] a -> m a
runFinal (Sem '[Final m] (f x) -> m (f x))
-> (f (Sem rInitial x) -> Sem '[Final m] (f x))
-> f (Sem rInitial x)
-> m (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Sem rInitial x) -> Sem '[Final m] (f x)
forall x. f (Sem rInitial x) -> Sem '[Final m] (f x)
wv) forall x. f x -> Maybe x
ins
{-# INLINE runFinal #-}

------------------------------------------------------------------------------
-- | Given natural transformations between @m1@ and @m2@, run a @'Final' m1@
-- effect by transforming it into a @'Final' m2@ effect.
--
-- @since 1.2.0.0
finalToFinal :: forall m1 m2 r a
              . Member (Final m2) r
             => (forall x. m1 x -> m2 x)
             -> (forall x. m2 x -> m1 x)
             -> Sem (Final m1 ': r) a
             -> Sem r a
finalToFinal :: (forall x. m1 x -> m2 x)
-> (forall x. m2 x -> m1 x) -> Sem (Final m1 : r) a -> Sem r a
finalToFinal forall x. m1 x -> m2 x
to forall x. m2 x -> m1 x
from =
  let
    go :: Sem (Final m1 ': r) x -> Sem r x
    go :: Sem (Final m1 : r) x -> Sem r x
go = (forall x.
 Union (Final m1 : r) (Sem (Final m1 : r)) x -> Union r (Sem r) x)
-> Sem (Final m1 : r) x -> Sem r x
forall (r :: [(* -> *) -> * -> *]) (r' :: [(* -> *) -> * -> *]) a.
(forall x. Union r (Sem r) x -> Union r' (Sem r') x)
-> Sem r a -> Sem r' a
hoistSem ((forall x.
  Union (Final m1 : r) (Sem (Final m1 : r)) x -> Union r (Sem r) x)
 -> Sem (Final m1 : r) x -> Sem r x)
-> (forall x.
    Union (Final m1 : r) (Sem (Final m1 : r)) x -> Union r (Sem r) x)
-> Sem (Final m1 : r) x
-> Sem r x
forall a b. (a -> b) -> a -> b
$ \Union (Final m1 : r) (Sem (Final m1 : r)) x
u -> case Union (Final m1 : r) (Sem (Final m1 : r)) x
-> Either
     (Union r (Sem (Final m1 : r)) x)
     (Weaving (Final m1) (Sem (Final m1 : r)) x)
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
       (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (Final m1 : r) (Sem (Final m1 : r)) x
u of
      Right (Weaving (WithWeavingToFinal wav) f ()
s forall x. f (Sem rInitial x) -> Sem (Final m1 : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
ins) ->
        Weaving (Final m2) (Sem r) x -> Union r (Sem r) x
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
       (m :: * -> *) a.
Member e r =>
Weaving e m a -> Union r m a
injWeaving (Weaving (Final m2) (Sem r) x -> Union r (Sem r) x)
-> Weaving (Final m2) (Sem r) x -> Union r (Sem r) x
forall a b. (a -> b) -> a -> b
$
          Final m2 (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> Sem r (f x))
-> (f a -> x)
-> (forall x. f x -> Maybe x)
-> Weaving (Final m2) (Sem r) x
forall (f :: * -> *) (e :: (* -> *) -> * -> *)
       (rInitial :: [(* -> *) -> * -> *]) a resultType (mAfter :: * -> *).
Functor f =>
e (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> mAfter (f x))
-> (f a -> resultType)
-> (forall x. f x -> Maybe x)
-> Weaving e mAfter resultType
Weaving
            (ThroughWeavingToFinal m2 (Sem rInitial) a
-> Final m2 (Sem rInitial) a
forall (m :: * -> *) (z :: * -> *) a.
ThroughWeavingToFinal m z a -> Final m z a
WithWeavingToFinal (ThroughWeavingToFinal m2 (Sem rInitial) a
 -> Final m2 (Sem rInitial) a)
-> ThroughWeavingToFinal m2 (Sem rInitial) a
-> Final m2 (Sem rInitial) a
forall a b. (a -> b) -> a -> b
$ \f ()
s' forall x. f (Sem rInitial x) -> m2 (f x)
wv' forall x. f x -> Maybe x
ins' ->
              m1 (f a) -> m2 (f a)
forall x. m1 x -> m2 x
to (m1 (f a) -> m2 (f a)) -> m1 (f a) -> m2 (f a)
forall a b. (a -> b) -> a -> b
$ f ()
-> (forall x. f (Sem rInitial x) -> m1 (f x))
-> (forall x. f x -> Maybe x)
-> m1 (f a)
ThroughWeavingToFinal m1 (Sem rInitial) a
wav f ()
s' (m2 (f x) -> m1 (f x)
forall x. m2 x -> m1 x
from (m2 (f x) -> m1 (f x))
-> (f (Sem rInitial x) -> m2 (f x))
-> f (Sem rInitial x)
-> m1 (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Sem rInitial x) -> m2 (f x)
forall x. f (Sem rInitial x) -> m2 (f x)
wv') forall x. f x -> Maybe x
ins'
            )
            f ()
s
            (Sem (Final m1 : r) (f x) -> Sem r (f x)
forall x. Sem (Final m1 : r) x -> Sem r x
go (Sem (Final m1 : r) (f x) -> Sem r (f x))
-> (f (Sem rInitial x) -> Sem (Final m1 : r) (f x))
-> f (Sem rInitial x)
-> Sem r (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Sem rInitial x) -> Sem (Final m1 : r) (f x)
forall x. f (Sem rInitial x) -> Sem (Final m1 : r) (f x)
wv)
            f a -> x
ex
            forall x. f x -> Maybe x
ins
      Left Union r (Sem (Final m1 : r)) x
g -> (forall x. Sem (Final m1 : r) x -> Sem r x)
-> Union r (Sem (Final m1 : r)) x -> Union r (Sem r) x
forall (m :: * -> *) (n :: * -> *) (r :: [(* -> *) -> * -> *]) a.
(forall x. m x -> n x) -> Union r m a -> Union r n a
hoist forall x. Sem (Final m1 : r) x -> Sem r x
go Union r (Sem (Final m1 : r)) x
g
    {-# INLINE go #-}
  in
    Sem (Final m1 : r) a -> Sem r a
forall x. Sem (Final m1 : r) x -> Sem r x
go
{-# INLINE finalToFinal #-}

------------------------------------------------------------------------------
-- | Transform an @'Embed' m@ effect into a @'Final' m@ effect
--
-- @since 1.2.0.0
embedToFinal :: (Member (Final m) r, Functor m)
             => Sem (Embed m ': r) a
             -> Sem r a
embedToFinal :: Sem (Embed m : r) a -> Sem r a
embedToFinal = (forall (rInitial :: [(* -> *) -> * -> *]) x.
 Embed m (Sem rInitial) x -> Sem r x)
-> Sem (Embed m : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: [(* -> *) -> * -> *]) x.
  Embed m (Sem rInitial) x -> Sem r x)
 -> Sem (Embed m : r) a -> Sem r a)
-> (forall (rInitial :: [(* -> *) -> * -> *]) x.
    Embed m (Sem rInitial) x -> Sem r x)
-> Sem (Embed m : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \(Embed m) -> m x -> Sem r x
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
embedFinal m x
m
{-# INLINE embedToFinal #-}