{-# LANGUAGE AllowAmbiguousTypes #-}

{-# OPTIONS_HADDOCK not-home #-}

-- | Description: The auxiliary higher-order interpreter effect 'Tactics'
module Polysemy.Internal.Tactics
  ( Tactics (..)
  , getInitialStateT
  , getInspectorT
  , Inspector (..)
  , runT
  , runTSimple
  , bindT
  , bindTSimple
  , pureT
  , liftT
  , runTactics
  , Tactical
  , WithTactics
  ) where

import Polysemy.Internal
import Polysemy.Internal.Union


------------------------------------------------------------------------------
-- | 'Tactical' is an environment in which you're capable of explicitly
-- threading higher-order effect states. This is provided by the (internal)
-- effect @Tactics@, which is capable of rewriting monadic actions so they run
-- in the correct stateful environment.
--
-- Inside a 'Tactical', you're capable of running 'pureT', 'runT' and 'bindT'
-- which are the main tools for rewriting monadic stateful environments.
--
-- For example, consider trying to write an interpreter for
-- 'Polysemy.Resource.Resource', whose effect is defined as:
--
-- @
-- data 'Polysemy.Resource.Resource' m a where
--   'Polysemy.Resource.Bracket' :: m a -> (a -> m ()) -> (a -> m b) -> 'Polysemy.Resource.Resource' m b
-- @
--
-- Here we have an @m a@ which clearly needs to be run first, and then
-- subsequently call the @a -> m ()@ and @a -> m b@ arguments. In a 'Tactical'
-- environment, we can write the threading code thusly:
--
-- @
-- 'Polysemy.Resource.Bracket' alloc dealloc use -> do
--   alloc'   <- 'runT'  alloc
--   dealloc' <- 'bindT' dealloc
--   use'     <- 'bindT' use
-- @
--
-- where
--
-- @
-- alloc'   ::         'Polysemy.Sem' ('Polysemy.Resource.Resource' ': r) (f a1)
-- dealloc' :: f a1 -> 'Polysemy.Sem' ('Polysemy.Resource.Resource' ': r) (f ())
-- use'     :: f a1 -> 'Polysemy.Sem' ('Polysemy.Resource.Resource' ': r) (f x)
-- @
--
-- The @f@ type here is existential and corresponds to "whatever
-- state the other effects want to keep track of." @f@ is always
-- a 'Functor'.
--
-- @alloc'@, @dealloc'@ and @use'@ are now in a form that can be
-- easily consumed by your interpreter. At this point, simply bind
-- them in the desired order and continue on your merry way.
--
-- We can see from the types of @dealloc'@ and @use'@ that since they both
-- consume a @f a1@, they must run in the same stateful environment. This
-- means, for illustration, any 'Polysemy.State.put's run inside the @use@
-- block will not be visible inside of the @dealloc@ block.
--
-- Power users may explicitly use 'getInitialStateT' and 'bindT' to construct
-- whatever data flow they'd like; although this is usually unnecessary.
type Tactical e m r x = ∀ f. Functor f
                          => Sem (WithTactics e f m r) (f x)

------------------------------------------------------------------------------
-- | Convenience type alias, see 'Tactical'.
type WithTactics e f m r = Tactics f m (e ': r) ': r

------------------------------------------------------------------------------
-- | See 'Tactical'.
data Tactics f n r m a where
  GetInitialState      :: Tactics f n r m (f ())
  HoistInterpretation  :: (a -> n b) -> Tactics f n r m (f a -> Sem r (f b))
  HoistInterpretationH :: (a -> n b) -> f a -> Tactics f n r m (f b)
  GetInspector         :: Tactics f n r m (Inspector f)


------------------------------------------------------------------------------
-- | Get the stateful environment of the world at the moment the effect @e@ is
-- to be run. Prefer 'pureT', 'runT' or 'bindT' instead of using this function
-- directly.
getInitialStateT :: forall f m r e. Sem (WithTactics e f m r) (f ())
getInitialStateT :: forall (f :: * -> *) (m :: * -> *) (r :: [Effect]) (e :: Effect).
Sem (WithTactics e f m r) (f ())
getInitialStateT = forall (e :: Effect) (r :: [Effect]) a.
Member e r =>
e (Sem r) a -> Sem r a
send @(Tactics _ m (e ': r)) forall {k} (f :: * -> *) (n :: * -> *) (r :: [Effect]) (m :: k).
Tactics f n r m (f ())
GetInitialState


------------------------------------------------------------------------------
-- | Get a natural transformation capable of potentially inspecting values
-- inside of @f@. Binding the result of 'getInspectorT' produces a function that
-- can sometimes peek inside values returned by 'bindT'.
--
-- This is often useful for running callback functions that are not managed by
-- polysemy code.
--
-- ==== Example
--
-- We can use the result of 'getInspectorT' to "undo" 'pureT' (or any of the other
-- 'Tactical' functions):
--
-- @
-- ins <- 'getInspectorT'
-- fa <- 'pureT' "hello"
-- fb <- 'pureT' True
-- let a = 'inspect' ins fa   -- Just "hello"
--     b = 'inspect' ins fb   -- Just True
-- @
getInspectorT :: forall e f m r. Sem (WithTactics e f m r) (Inspector f)
getInspectorT :: forall (e :: Effect) (f :: * -> *) (m :: * -> *) (r :: [Effect]).
Sem (WithTactics e f m r) (Inspector f)
getInspectorT = forall (e :: Effect) (r :: [Effect]) a.
Member e r =>
e (Sem r) a -> Sem r a
send @(Tactics _ m (e ': r)) forall {k} (f :: * -> *) (n :: * -> *) (r :: [Effect]) (m :: k).
Tactics f n r m (Inspector f)
GetInspector


------------------------------------------------------------------------------
-- | A container for 'inspect'. See the documentation for 'getInspectorT'.
newtype Inspector f = Inspector
  { forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect :: forall x. f x -> Maybe x
    -- ^ See the documentation for 'getInspectorT'.
  }


------------------------------------------------------------------------------
-- | Lift a value into 'Tactical'.
pureT :: Functor f => a -> Sem (WithTactics e f m r) (f a)
pureT :: forall (f :: * -> *) a (e :: Effect) (m :: * -> *) (r :: [Effect]).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT a
a = do
  f ()
istate <- forall (f :: * -> *) (m :: * -> *) (r :: [Effect]) (e :: Effect).
Sem (WithTactics e f m r) (f ())
getInitialStateT
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ a
a forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
istate


------------------------------------------------------------------------------
-- | Run a monadic action in a 'Tactical' environment. The stateful environment
-- used will be the same one that the effect is initally run in. Use 'bindT' if
-- you'd prefer to explicitly manage your stateful environment.
runT
    :: m a
      -- ^ The monadic action to lift. This is usually a parameter in your
      -- effect.
    -> Sem (WithTactics e f m r)
                (Sem (e ': r) (f a))
runT :: forall (m :: * -> *) a (e :: Effect) (f :: * -> *) (r :: [Effect]).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT m a
na = do
  f ()
istate <- forall (f :: * -> *) (m :: * -> *) (r :: [Effect]) (e :: Effect).
Sem (WithTactics e f m r) (f ())
getInitialStateT
  f () -> Sem (e : r) (f a)
na'    <- forall a (m :: * -> *) b (e :: Effect) (f :: * -> *)
       (r :: [Effect]).
(a -> m b) -> Sem (WithTactics e f m r) (f a -> Sem (e : r) (f b))
bindT (forall a b. a -> b -> a
const m a
na)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ f () -> Sem (e : r) (f a)
na' f ()
istate
{-# INLINE runT #-}

------------------------------------------------------------------------------
-- | Run a monadic action in a 'Tactical' environment. The stateful environment
-- used will be the same one that the effect is initally run in.
-- Use 'bindTSimple' if you'd prefer to explicitly manage your stateful
-- environment.
--
-- This is a less flexible but significantly simpler variant of 'runT'.
-- Instead of returning a 'Sem' action corresponding to the provided action,
-- 'runTSimple' runs the action immediately.
--
-- @since 1.5.0.0
runTSimple :: m a
              -- ^ The monadic action to lift. This is usually a parameter in your
              -- effect.
           -> Tactical e m r a
runTSimple :: forall (m :: * -> *) a (e :: Effect) (r :: [Effect]).
m a -> Tactical e m r a
runTSimple m a
na = do
  f ()
istate <- forall (f :: * -> *) (m :: * -> *) (r :: [Effect]) (e :: Effect).
Sem (WithTactics e f m r) (f ())
getInitialStateT
  forall (m :: * -> *) (f :: * -> *) (r :: [Effect]) (e :: Effect) a
       b.
(a -> m b) -> f a -> Sem (WithTactics e f m r) (f b)
bindTSimple (forall a b. a -> b -> a
const m a
na) f ()
istate
{-# INLINE runTSimple #-}


------------------------------------------------------------------------------
-- | Lift a kleisli action into the stateful environment. You can use
-- 'bindT' to get an effect parameter of the form @a -> m b@ into something
-- that can be used after calling 'runT' on an effect parameter @m a@.
bindT
    :: (a -> m b)
       -- ^ The monadic continuation to lift. This is usually a parameter in
       -- your effect.
       --
       -- Continuations lifted via 'bindT' will run in the same environment
       -- which produced the @a@.
    -> Sem (WithTactics e f m r)
                (f a -> Sem (e ': r) (f b))
bindT :: forall a (m :: * -> *) b (e :: Effect) (f :: * -> *)
       (r :: [Effect]).
(a -> m b) -> Sem (WithTactics e f m r) (f a -> Sem (e : r) (f b))
bindT a -> m b
f = forall (e :: Effect) (r :: [Effect]) a.
Member e r =>
e (Sem r) a -> Sem r a
send forall a b. (a -> b) -> a -> b
$ forall {k} a (n :: * -> *) b (f :: * -> *) (r :: [Effect])
       (m :: k).
(a -> n b) -> Tactics f n r m (f a -> Sem r (f b))
HoistInterpretation a -> m b
f
{-# INLINE bindT #-}

------------------------------------------------------------------------------
-- | Lift a kleisli action into the stateful environment.
-- You can use 'bindTSimple' to execute an effect parameter of the form
-- @a -> m b@ by providing the result of a `runTSimple` or another
-- `bindTSimple`.
--
-- This is a less flexible but significantly simpler variant of 'bindT'.
-- Instead of returning a 'Sem' kleisli action corresponding to the
-- provided kleisli action, 'bindTSimple' runs the kleisli action immediately.
--
-- @since 1.5.0.0
bindTSimple
    :: forall m f r e a b
     . (a -> m b)
       -- ^ The monadic continuation to lift. This is usually a parameter in
       -- your effect.
       --
       -- Continuations executed via 'bindTSimple' will run in the same
       -- environment which produced the @a@.
    -> f a
    -> Sem (WithTactics e f m r) (f b)
bindTSimple :: forall (m :: * -> *) (f :: * -> *) (r :: [Effect]) (e :: Effect) a
       b.
(a -> m b) -> f a -> Sem (WithTactics e f m r) (f b)
bindTSimple a -> m b
f f a
s = forall (e :: Effect) (r :: [Effect]) a.
Member e r =>
e (Sem r) a -> Sem r a
send @(Tactics _ _ (e ': r)) forall a b. (a -> b) -> a -> b
$ forall {k} a (n :: * -> *) b (f :: * -> *) (r :: [Effect])
       (m :: k).
(a -> n b) -> f a -> Tactics f n r m (f b)
HoistInterpretationH a -> m b
f f a
s
{-# INLINE bindTSimple #-}


------------------------------------------------------------------------------
-- | Internal function to create first-order interpreter combinators out of
-- higher-order ones.
liftT
    :: forall m f r e a
     . Functor f
    => Sem r a
    -> Sem (WithTactics e f m r) (f a)
liftT :: forall (m :: * -> *) (f :: * -> *) (r :: [Effect]) (e :: Effect) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT Sem r a
m = do
  a
a <- forall (e :: Effect) (r :: [Effect]) a. Sem r a -> Sem (e : r) a
raise Sem r a
m
  forall (f :: * -> *) a (e :: Effect) (m :: * -> *) (r :: [Effect]).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT a
a
{-# INLINE liftT #-}


------------------------------------------------------------------------------
-- | Run the 'Tactics' effect.
runTactics
   :: Functor f
   => f ()
   -> (∀ x. f (m x) -> Sem r2 (f x))
   -> (∀ x. f x -> Maybe x)
   -> (∀ x. f (m x) -> Sem r (f x))
   -> Sem (Tactics f m r2 ': r) a
   -> Sem r a
runTactics :: forall (f :: * -> *) (m :: * -> *) (r2 :: [Effect]) (r :: [Effect])
       a.
Functor f =>
f ()
-> (forall x. f (m x) -> Sem r2 (f x))
-> (forall x. f x -> Maybe x)
-> (forall x. f (m x) -> Sem r (f x))
-> Sem (Tactics f m r2 : r) a
-> Sem r a
runTactics f ()
s forall x. f (m x) -> Sem r2 (f x)
d forall x. f x -> Maybe x
v forall x. f (m x) -> Sem r (f x)
d' (Sem forall (m :: * -> *).
Monad m =>
(forall x.
 Union (Tactics f m r2 : r) (Sem (Tactics f m r2 : r)) x -> m x)
-> m a
m) = forall (r :: [Effect]) a.
(forall (m :: * -> *).
 Monad m =>
 (forall x. Union r (Sem r) x -> m x) -> m a)
-> Sem r a
Sem forall a b. (a -> b) -> a -> b
$ \forall x. Union r (Sem r) x -> m x
k -> forall (m :: * -> *).
Monad m =>
(forall x.
 Union (Tactics f m r2 : r) (Sem (Tactics f m r2 : r)) x -> m x)
-> m a
m forall a b. (a -> b) -> a -> b
$ \Union (Tactics f m r2 : r) (Sem (Tactics f m r2 : r)) x
u ->
  case forall (e :: Effect) (r :: [Effect]) (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (Tactics f m r2 : r) (Sem (Tactics f m r2 : r)) x
u of
    Left Union r (Sem (Tactics f m r2 : r)) x
x -> forall x. Union r (Sem r) x -> m x
k forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *) (r :: [Effect]) a.
(forall x. m x -> n x) -> Union r m a -> Union r n a
hoist (forall (f :: * -> *) (m :: * -> *) (r2 :: [Effect]) (r :: [Effect])
       a.
Functor f =>
f ()
-> (forall x. f (m x) -> Sem r2 (f x))
-> (forall x. f x -> Maybe x)
-> (forall x. f (m x) -> Sem r (f x))
-> Sem (Tactics f m r2 : r) a
-> Sem r a
runTactics f ()
s forall x. f (m x) -> Sem r2 (f x)
d forall x. f x -> Maybe x
v forall x. f (m x) -> Sem r (f x)
d') Union r (Sem (Tactics f m r2 : r)) x
x
    Right (Weaving Tactics f m r2 (Sem rInitial) a
GetInitialState f ()
s' forall x. f (Sem rInitial x) -> Sem (Tactics f m r2 : r) (f x)
_ f a -> x
y forall x. f x -> Maybe x
_) ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ f a -> x
y forall a b. (a -> b) -> a -> b
$ f ()
s forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s'
    Right (Weaving (HoistInterpretation a -> m b
na) f ()
s' forall x. f (Sem rInitial x) -> Sem (Tactics f m r2 : r) (f x)
_ f a -> x
y forall x. f x -> Maybe x
_) -> do
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ f a -> x
y forall a b. (a -> b) -> a -> b
$ (forall x. f (m x) -> Sem r2 (f x)
d forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> m b
na) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s'
    Right (Weaving (HoistInterpretationH a -> m b
na f a
fa) f ()
s' forall x. f (Sem rInitial x) -> Sem (Tactics f m r2 : r) (f x)
_ f a -> x
y forall x. f x -> Maybe x
_) -> do
      (f a -> x
y forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s')) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: [Effect]) a.
Sem r a
-> forall (m :: * -> *).
   Monad m =>
   (forall x. Union r (Sem r) x -> m x) -> m a
runSem (forall x. f (m x) -> Sem r (f x)
d' (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> m b
na f a
fa)) forall x. Union r (Sem r) x -> m x
k
    Right (Weaving Tactics f m r2 (Sem rInitial) a
GetInspector f ()
s' forall x. f (Sem rInitial x) -> Sem (Tactics f m r2 : r) (f x)
_ f a -> x
y forall x. f x -> Maybe x
_) -> do
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ f a -> x
y forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). (forall x. f x -> Maybe x) -> Inspector f
Inspector forall x. f x -> Maybe x
v forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s'
{-# INLINE runTactics #-}