{-# LANGUAGE AllowAmbiguousTypes #-}

{-# OPTIONS_HADDOCK not-home #-}

module Polysemy.Internal.Tactics
  ( Tactics (..)
  , getInitialStateT
  , getInspectorT
  , Inspector (..)
  , runT
  , bindT
  , 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)

type WithTactics e f m r = Tactics f m (e ': r) ': r

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))
  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 :: Sem (WithTactics e f m r) (f ())
getInitialStateT = Tactics f m (e : r) (Sem (WithTactics e f m r)) (f ())
-> Sem (WithTactics e f m r) (f ())
forall (e :: Effect) (r :: [Effect]) a.
Member e r =>
e (Sem r) a -> Sem r a
send @(Tactics _ m (e ': r)) Tactics f m (e : r) (Sem (WithTactics e f m r)) (f ())
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 :: Sem (WithTactics e f m r) (Inspector f)
getInspectorT = Tactics f m (e : r) (Sem (WithTactics e f m r)) (Inspector f)
-> Sem (WithTactics e f m r) (Inspector f)
forall (e :: Effect) (r :: [Effect]) a.
Member e r =>
e (Sem r) a -> Sem r a
send @(Tactics _ m (e ': r)) Tactics f m (e : r) (Sem (WithTactics e f m r)) (Inspector f)
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
  { 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 :: a -> Tactical e m r a
pureT :: a -> Tactical e m r a
pureT a
a = do
  f ()
istate <- Sem (WithTactics e f m r) (f ())
forall (f :: * -> *) (m :: * -> *) (r :: [Effect]) (e :: Effect).
Sem (WithTactics e f m r) (f ())
getInitialStateT
  f a -> Sem (WithTactics e f m r) (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> Sem (WithTactics e f m r) (f a))
-> f a -> Sem (WithTactics e f m r) (f a)
forall a b. (a -> b) -> a -> b
$ a
a a -> f () -> f 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 :: m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT m a
na = do
  f ()
istate <- Sem (WithTactics e f m r) (f ())
forall (f :: * -> *) (m :: * -> *) (r :: [Effect]) (e :: Effect).
Sem (WithTactics e f m r) (f ())
getInitialStateT
  f () -> Sem (e : r) (f a)
na'    <- (() -> m a)
-> Sem (WithTactics e f m r) (f () -> Sem (e : r) (f a))
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 (m a -> () -> m a
forall a b. a -> b -> a
const m a
na)
  Sem (e : r) (f a) -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sem (e : r) (f a)
 -> Sem (WithTactics e f m r) (Sem (e : r) (f a)))
-> Sem (e : r) (f a)
-> Sem (WithTactics e f m r) (Sem (e : r) (f a))
forall a b. (a -> b) -> a -> b
$ f () -> Sem (e : r) (f a)
na' f ()
istate
{-# INLINE runT #-}


------------------------------------------------------------------------------
-- | 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 :: (a -> m b) -> Sem (WithTactics e f m r) (f a -> Sem (e : r) (f b))
bindT a -> m b
f = Tactics
  f m (e : r) (Sem (WithTactics e f m r)) (f a -> Sem (e : r) (f b))
-> Sem (WithTactics e f m r) (f a -> Sem (e : r) (f b))
forall (e :: Effect) (r :: [Effect]) a.
Member e r =>
e (Sem r) a -> Sem r a
send (Tactics
   f m (e : r) (Sem (WithTactics e f m r)) (f a -> Sem (e : r) (f b))
 -> Sem (WithTactics e f m r) (f a -> Sem (e : r) (f b)))
-> Tactics
     f m (e : r) (Sem (WithTactics e f m r)) (f a -> Sem (e : r) (f b))
-> Sem (WithTactics e f m r) (f a -> Sem (e : r) (f b))
forall a b. (a -> b) -> a -> b
$ (a -> m b)
-> Tactics
     f m (e : r) (Sem (WithTactics e f m r)) (f a -> Sem (e : r) (f 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 #-}


------------------------------------------------------------------------------
-- | 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 :: Sem r a -> Sem (WithTactics e f m r) (f a)
liftT Sem r a
m = do
  a
a <- Sem r a -> Sem (WithTactics e f m r) a
forall (e :: Effect) (r :: [Effect]) a. Sem r a -> Sem (e : r) a
raise Sem r a
m
  a -> Tactical e m r a
forall a (e :: Effect) (m :: * -> *) (r :: [Effect]).
a -> Tactical e m r 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)
   -> Sem (Tactics f m r2 ': r) a
   -> Sem r a
runTactics :: f ()
-> (forall x. f (m x) -> Sem r2 (f x))
-> (forall x. f x -> Maybe 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 (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 x.
 Union (Tactics f m r2 : r) (Sem (Tactics f m r2 : r)) x -> Sem r x)
-> Sem r a
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 x.
  Union (Tactics f m r2 : r) (Sem (Tactics f m r2 : r)) x -> Sem r x)
 -> Sem r a)
-> (forall x.
    Union (Tactics f m r2 : r) (Sem (Tactics f m r2 : r)) x -> Sem r x)
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \Union (Tactics f m r2 : r) (Sem (Tactics f m r2 : r)) x
u ->
  case Union (Tactics f m r2 : r) (Sem (Tactics f m r2 : r)) x
-> Either
     (Union r (Sem (Tactics f m r2 : r)) x)
     (Weaving (Tactics f m r2) (Sem (Tactics f m r2 : r)) x)
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 -> Union r (Sem r) x -> Sem r x
forall (r :: [Effect]) a. Union r (Sem r) a -> Sem r a
liftSem (Union r (Sem r) x -> Sem r x) -> Union r (Sem r) x -> Sem r x
forall a b. (a -> b) -> a -> b
$ (forall x. Sem (Tactics f m r2 : r) x -> Sem r x)
-> Union r (Sem (Tactics f m r2 : r)) x -> Union r (Sem r) x
forall (m :: * -> *) (n :: * -> *) (r :: [Effect]) a.
(forall x. m x -> n x) -> Union r m a -> Union r n a
hoist (f ()
-> (forall x. f (m x) -> Sem r2 (f x))
-> (forall x. f x -> Maybe x)
-> Sem (Tactics f m r2 : r) x
-> Sem r x
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)
-> 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) 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
_) ->
      x -> Sem r x
forall (f :: * -> *) a. Applicative f => a -> f a
pure (x -> Sem r x) -> x -> Sem r x
forall a b. (a -> b) -> a -> b
$ f a -> x
y (f a -> x) -> f a -> x
forall a b. (a -> b) -> a -> b
$ f ()
s f () -> f () -> f (f ())
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
      x -> Sem r x
forall (f :: * -> *) a. Applicative f => a -> f a
pure (x -> Sem r x) -> x -> Sem r x
forall a b. (a -> b) -> a -> b
$ f a -> x
y (f a -> x) -> f a -> x
forall a b. (a -> b) -> a -> b
$ (f (m b) -> Sem r2 (f b)
forall x. f (m x) -> Sem r2 (f x)
d (f (m b) -> Sem r2 (f b))
-> (f a -> f (m b)) -> f a -> Sem r2 (f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m b) -> f a -> f (m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> m b
na) (f a -> Sem r2 (f b)) -> f () -> f (f a -> Sem r2 (f b))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s'
    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
      x -> Sem r x
forall (f :: * -> *) a. Applicative f => a -> f a
pure (x -> Sem r x) -> x -> Sem r x
forall a b. (a -> b) -> a -> b
$ f a -> x
y (f a -> x) -> f a -> x
forall a b. (a -> b) -> a -> b
$ (forall x. f x -> Maybe x) -> Inspector f
forall (f :: * -> *). (forall x. f x -> Maybe x) -> Inspector f
Inspector forall x. f x -> Maybe x
v Inspector f -> f () -> f (Inspector f)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s'
{-# INLINE runTactics #-}