{-# LANGUAGE AllowAmbiguousTypes #-}
{-# OPTIONS_HADDOCK not-home #-}
-- |
-- Copyright: (c) 2021 Xy Ren
-- License: BSD3
-- Maintainer: xy.r@outlook.com
-- Stability: unstable
-- Portability: non-portable (GHC only)
--
-- Operations on the effect environment type t'Env'. These operations are more flexible than the public API; you may
-- want to use these in conjunction with the effect stack manipulation operations in "Cleff.Internal.Stack".
--
-- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be
-- extra careful if you're to depend on this module.
module Cleff.Internal.Env
  ( Env
  , Handling
  , Handler
  , esSend
  , empty
  , read
  , adjust
  , overwriteLocal
  , overwriteGlobal
  , overwriteSelfGlobal
  , extend
  , update
  ) where

import           Cleff.Internal.Monad
import           Cleff.Internal.Stack (Stack)
import qualified Cleff.Internal.Stack as Stack
import           Data.Any             (fromAny, pattern Any)
import qualified Data.RadixVec        as Vec
import           Prelude              hiding (read)
import           Unsafe.Coerce        (unsafeCoerce)

-- | The internal representation of effect handlers. This is just a natural transformation from the effect type
-- @e ('Eff' es)@ to the effect monad @'Eff' es@ for any effect stack @es@.
--
-- In interpreting functions (see "Cleff.Internal.Interpret"), the user-facing 'Cleff.Handler' type is transformed into
-- this type.
newtype InternalHandler e = InternalHandler (∀ es. e (Eff es) ~> Eff es)

-- | The send-site environment.
data SendSite esSend e = SendSite
  {-# UNPACK #-} !(Env esSend) -- ^ The send-site 'Env'.
  {-# UNPACK #-} !(HandlerPtr e) -- ^ The pointer to the current effect handler.

-- | The typeclass that denotes a handler scope, handling effect @e@ sent from the effect stack @esSend@ in the
-- effect stack @es@.
--
-- You should not define instances for this typeclass whatsoever.
class Handling esSend e es | esSend -> e es where
  -- @esSend@ is existential so it uniquely determines the other two variables. As handling scopes can nest, the other
  -- two variables cannot determine anything.

  -- | Obtain the send-site environment.
  sendSite :: SendSite esSend e
  sendSite = [Char] -> SendSite esSend e
forall a. HasCallStack => [Char] -> a
error
    [Char]
"Cleff.Internal.Env.sendSite: Attempting to access the send site without a reflected value. This is perhaps \
    \because you are trying to define an instance for the 'Handling' typeclass, which you should not be doing \
    \whatsoever. If that or other shenanigans seem unlikely, please report this as a bug."

-- | Get the pointer to the current effect handler itself.
hdlPtr :: ∀ esSend e es. Handling esSend e es => HandlerPtr e
hdlPtr :: HandlerPtr e
hdlPtr = let SendSite Env esSend
_ HandlerPtr e
ptr = forall k (esSend :: [Effect]) (e :: Effect) (es :: k).
Handling esSend e es =>
SendSite esSend e
forall (e :: Effect) (es :: k).
Handling esSend e es =>
SendSite esSend e
sendSite @esSend in HandlerPtr e
ptr

-- | Get the send-site 'Env'.
esSend :: Handling esSend e es => Env esSend
esSend :: Env esSend
esSend = let SendSite Env esSend
env HandlerPtr e
_ = SendSite esSend e
forall k (esSend :: [Effect]) (e :: Effect) (es :: k).
Handling esSend e es =>
SendSite esSend e
sendSite in Env esSend
env

-- | Newtype wrapper for instantiating the 'Handling' typeclass locally, a la the reflection trick. We do not use
-- the @reflection@ library directly so as not to expose this piece of implementation detail to the user.
newtype InstHandling esSend e es a = InstHandling (Handling esSend e es => a)

-- | Instantiate an 'Handling' typeclass, /i.e./ pass an implicit send-site environment in. This function shouldn't
-- be directly used anyhow.
instHandling :: ∀ esSend e es a. (Handling esSend e es => a) -> SendSite esSend e -> a
instHandling :: (Handling esSend e es => a) -> SendSite esSend e -> a
instHandling Handling esSend e es => a
x = InstHandling esSend e es a -> SendSite esSend e -> a
forall a b. a -> b
unsafeCoerce ((Handling esSend e es => a) -> InstHandling esSend e es a
forall k (esSend :: [Effect]) (e :: Effect) (es :: k) a.
(Handling esSend e es => a) -> InstHandling esSend e es a
InstHandling Handling esSend e es => a
x :: InstHandling esSend e es a)

-- | The type of an /effect handler/, which is a function that transforms an effect @e@ from an arbitrary effect stack
-- into computations in the effect stack @es@.
type Handler e es = ∀ esSend. Handling esSend e es => e (Eff esSend) ~> Eff es

-- | Transform a 'Handler' into an 'InternalHandler' given a pointer that is going to point to the 'InternalHandler'
-- and the current 'Env'.
mkInternalHandler :: HandlerPtr e -> Env es -> Handler e es -> InternalHandler e
mkInternalHandler :: HandlerPtr e -> Env es -> Handler e es -> InternalHandler e
mkInternalHandler HandlerPtr e
ptr Env es
es Handler e es
handle = (forall (es :: [Effect]). e (Eff es) ~> Eff es)
-> InternalHandler e
forall (e :: Effect).
(forall (es :: [Effect]). e (Eff es) ~> Eff es)
-> InternalHandler e
InternalHandler \e (Eff es) a
e -> (Env es -> IO a) -> Eff es a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
Eff \Env es
ess ->
  Eff es a -> Env es -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff ((Handling es e es => e (Eff es) a -> Eff es a)
-> SendSite es e -> e (Eff es) a -> Eff es a
forall k (esSend :: [Effect]) (e :: Effect) (es :: k) a.
(Handling esSend e es => a) -> SendSite esSend e -> a
instHandling Handling es e es => e (Eff es) a -> Eff es a
Handler e es
handle (Env es -> HandlerPtr e -> SendSite es e
forall (esSend :: [Effect]) (e :: Effect).
Env esSend -> HandlerPtr e -> SendSite esSend e
SendSite Env es
ess HandlerPtr e
ptr) e (Eff es) a
e) (Env es -> Env es -> Env es
forall (es :: [Effect]) (es' :: [Effect]).
Env es' -> Env es -> Env es
update Env es
ess Env es
es)

-- | Create an empty 'Env' with no address allocated.
empty :: Env '[]
empty :: Env '[]
empty = Stack '[] -> RadixVec Any -> Env '[]
forall (es :: [Effect]). Stack es -> RadixVec Any -> Env es
Env Stack '[]
Stack.empty RadixVec Any
forall a. RadixVec a
Vec.empty

-- | Read the handler a pointer points to. \( O(1) \).
read :: ∀ e es. e :> es => Env es -> ∀ es'. e (Eff es') ~> Eff es'
read :: Env es -> forall (es' :: [Effect]). e (Eff es') ~> Eff es'
read (Env Stack es
stack RadixVec Any
heap) = Any -> e (Eff es') a -> Eff es' a
forall a. Any -> a
fromAny (Any -> e (Eff es') a -> Eff es' a)
-> Any -> e (Eff es') a -> Eff es' a
forall a b. (a -> b) -> a -> b
$ Int -> RadixVec Any -> Any
forall a. Int -> RadixVec a -> a
Vec.lookup (HandlerPtr e -> Int
forall (e :: Effect). HandlerPtr e -> Int
unHandlerPtr (Stack es -> HandlerPtr e
forall (e :: Effect) (es :: [Effect]).
(e :> es) =>
Stack es -> HandlerPtr e
Stack.index @e Stack es
stack)) RadixVec Any
heap

-- | Adjust the effect stack via an function over 'Stack'.
adjust :: ∀ es' es. (Stack es -> Stack es') -> Env es -> Env es'
adjust :: (Stack es -> Stack es') -> Env es -> Env es'
adjust Stack es -> Stack es'
f = \(Env Stack es
stack RadixVec Any
heap) -> Stack es' -> RadixVec Any -> Env es'
forall (es :: [Effect]). Stack es -> RadixVec Any -> Env es
Env (Stack es -> Stack es'
f Stack es
stack) RadixVec Any
heap

-- | Replace the handler a pointer points to. \( O(1) \).
overwriteGlobal :: ∀ e es es'. e :> es => Env es' -> Handler e es' -> Env es -> Env es
overwriteGlobal :: Env es' -> Handler e es' -> Env es -> Env es
overwriteGlobal Env es'
es Handler e es'
hdl (Env Stack es
stack RadixVec Any
heap) = Stack es -> RadixVec Any -> Env es
forall (es :: [Effect]). Stack es -> RadixVec Any -> Env es
Env Stack es
stack (RadixVec Any -> Env es) -> RadixVec Any -> Env es
forall a b. (a -> b) -> a -> b
$
  Int -> Any -> RadixVec Any -> RadixVec Any
forall a. Int -> a -> RadixVec a -> RadixVec a
Vec.update Int
m (InternalHandler e -> Any
forall a. a -> Any
Any (InternalHandler e -> Any) -> InternalHandler e -> Any
forall a b. (a -> b) -> a -> b
$ HandlerPtr e -> Env es' -> Handler e es' -> InternalHandler e
forall (e :: Effect) (es :: [Effect]).
HandlerPtr e -> Env es -> Handler e es -> InternalHandler e
mkInternalHandler HandlerPtr e
ptr Env es'
es Handler e es'
hdl) RadixVec Any
heap
  where ptr :: HandlerPtr e
ptr@(HandlerPtr Int
m) = Stack es -> HandlerPtr e
forall (e :: Effect) (es :: [Effect]).
(e :> es) =>
Stack es -> HandlerPtr e
Stack.index @e Stack es
stack

-- | Replace the handler a pointer points to. \( O(1) \).
overwriteSelfGlobal :: ∀ e es es' esSend. Handling esSend e es => Env es' -> Handler e es' -> Env esSend -> Env esSend
overwriteSelfGlobal :: Env es' -> Handler e es' -> Env esSend -> Env esSend
overwriteSelfGlobal Env es'
es Handler e es'
hdl (Env Stack esSend
stack RadixVec Any
heap) = Stack esSend -> RadixVec Any -> Env esSend
forall (es :: [Effect]). Stack es -> RadixVec Any -> Env es
Env Stack esSend
stack (RadixVec Any -> Env esSend) -> RadixVec Any -> Env esSend
forall a b. (a -> b) -> a -> b
$
  Int -> Any -> RadixVec Any -> RadixVec Any
forall a. Int -> a -> RadixVec a -> RadixVec a
Vec.update Int
ix (InternalHandler e -> Any
forall a. a -> Any
Any (InternalHandler e -> Any) -> InternalHandler e -> Any
forall a b. (a -> b) -> a -> b
$ HandlerPtr e -> Env es' -> Handler e es' -> InternalHandler e
forall (e :: Effect) (es :: [Effect]).
HandlerPtr e -> Env es -> Handler e es -> InternalHandler e
mkInternalHandler HandlerPtr e
ptr Env es'
es Handler e es'
hdl) RadixVec Any
heap
  where ptr :: HandlerPtr e
ptr@(HandlerPtr Int
ix) = forall k (esSend :: [Effect]) (e :: Effect) (es :: k).
Handling esSend e es =>
HandlerPtr e
forall (e :: Effect) (es :: k).
Handling esSend e es =>
HandlerPtr e
hdlPtr @esSend

-- | Replace the handler pointer of an effect in the stack. \( O(n) \).
overwriteLocal :: ∀ e es es'. e :> es => Env es' -> Handler e es' -> Env es -> Env es
overwriteLocal :: Env es' -> Handler e es' -> Env es -> Env es
overwriteLocal Env es'
es Handler e es'
hdl (Env Stack es
stack RadixVec Any
heap) = Stack es -> RadixVec Any -> Env es
forall (es :: [Effect]). Stack es -> RadixVec Any -> Env es
Env
  (HandlerPtr e -> Stack es -> Stack es
forall (e :: Effect) (es :: [Effect]).
(e :> es) =>
HandlerPtr e -> Stack es -> Stack es
Stack.update @e HandlerPtr e
ptr Stack es
stack)
  (RadixVec Any -> Any -> RadixVec Any
forall a. RadixVec a -> a -> RadixVec a
Vec.snoc RadixVec Any
heap (Any -> RadixVec Any) -> Any -> RadixVec Any
forall a b. (a -> b) -> a -> b
$ InternalHandler e -> Any
forall a. a -> Any
Any (InternalHandler e -> Any) -> InternalHandler e -> Any
forall a b. (a -> b) -> a -> b
$ HandlerPtr e -> Env es' -> Handler e es' -> InternalHandler e
forall (e :: Effect) (es :: [Effect]).
HandlerPtr e -> Env es -> Handler e es -> InternalHandler e
mkInternalHandler HandlerPtr e
ptr Env es'
es Handler e es'
hdl)
  where ptr :: HandlerPtr e
ptr = Int -> HandlerPtr e
forall (e :: Effect). Int -> HandlerPtr e
HandlerPtr (RadixVec Any -> Int
forall a. RadixVec a -> Int
Vec.size RadixVec Any
heap)

-- | Add a new effect to the stack with its corresponding handler pointer. \( O(n) \).
extend :: ∀ e es es'. Env es' -> Handler e es' -> Env es -> Env (e : es)
extend :: Env es' -> Handler e es' -> Env es -> Env (e : es)
extend Env es'
es Handler e es'
hdl (Env Stack es
stack RadixVec Any
heap) = Stack (e : es) -> RadixVec Any -> Env (e : es)
forall (es :: [Effect]). Stack es -> RadixVec Any -> Env es
Env
  (HandlerPtr e -> Stack es -> Stack (e : es)
forall (e :: Effect) (es :: [Effect]).
HandlerPtr e -> Stack es -> Stack (e : es)
Stack.cons HandlerPtr e
ptr Stack es
stack)
  (RadixVec Any -> Any -> RadixVec Any
forall a. RadixVec a -> a -> RadixVec a
Vec.snoc RadixVec Any
heap (Any -> RadixVec Any) -> Any -> RadixVec Any
forall a b. (a -> b) -> a -> b
$ InternalHandler e -> Any
forall a. a -> Any
Any (InternalHandler e -> Any) -> InternalHandler e -> Any
forall a b. (a -> b) -> a -> b
$ HandlerPtr e -> Env es' -> Handler e es' -> InternalHandler e
forall (e :: Effect) (es :: [Effect]).
HandlerPtr e -> Env es -> Handler e es -> InternalHandler e
mkInternalHandler HandlerPtr e
ptr Env es'
es Handler e es'
hdl)
  where ptr :: HandlerPtr e
ptr = Int -> HandlerPtr e
forall (e :: Effect). Int -> HandlerPtr e
HandlerPtr (RadixVec Any -> Int
forall a. RadixVec a -> Int
Vec.size RadixVec Any
heap)

-- | Use the state of LHS as a newer version for RHS. \( O(1) \).
update :: ∀ es es'. Env es' -> Env es -> Env es
update :: Env es' -> Env es -> Env es
update (Env Stack es'
_ RadixVec Any
heap) (Env Stack es
stack RadixVec Any
_) = Stack es -> RadixVec Any -> Env es
forall (es :: [Effect]). Stack es -> RadixVec Any -> Env es
Env Stack es
stack RadixVec Any
heap