{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_HADDOCK not-home #-}
module Effectful.Internal.Env
  ( -- * The environment
    Env(..)
  , Ref(..)
  , Version
  , Storage(..)
  , AnyEffect
  , toAnyEffect
  , fromAnyEffect
  , AnyRelinker
  , toAnyRelinker
  , fromAnyRelinker

    -- ** Relinker
  , Relinker(..)
  , dummyRelinker

    -- * Dispatch
  , Dispatch(..)
  , SideEffects(..)
  , DispatchOf
  , EffectRep

    -- * Operations
  , emptyEnv
  , cloneEnv
  , restoreEnv
  , sizeEnv
  , tailEnv

    -- ** Modification of the effect stack
  , consEnv
  , unconsEnv
  , replaceEnv
  , unreplaceEnv
  , subsumeEnv
  , injectEnv

    -- ** Data retrieval and update
  , getEnv
  , putEnv
  , stateEnv
  , modifyEnv
  ) where

import Control.Monad
import Control.Monad.Primitive
import Data.IORef.Strict
import Data.Primitive.PrimArray
import Data.Primitive.SmallArray
import Data.Primitive.Types
import GHC.Exts ((*#), (+#))
import GHC.Stack

import Effectful.Internal.Effect
import Effectful.Internal.Utils

type role Env nominal

-- | A strict (WHNF), __thread local__, mutable, extensible record indexed by types
-- of kind 'Effect'.
--
-- __Warning: the environment is a mutable data structure and cannot be simultaneously used from multiple threads under any circumstances.__
--
-- In order to pass it to a different thread, you need to perform a deep copy
-- with the 'cloneEnv' funtion.
--
-- Offers very good performance characteristics for most often performed
-- operations:
--
-- - Extending: /@O(n)@/, where @n@ is the size of the effect stack.
--
-- - Shrinking: /@O(1)@/.
--
-- - Indexing via '(:>)': /@O(1)@/
--
-- - Modification of a specific element: /@O(1)@/.
--
-- - Getting a tail: /@O(1)@/.
--
-- - Cloning: /@O(N)@/, where @N@ is the size of the 'Storage'.
--
data Env (es :: [Effect]) = Env
  { forall (es :: [Effect]). Env es -> Int
envOffset  :: !Int
  , forall (es :: [Effect]). Env es -> PrimArray Ref
envRefs    :: !(PrimArray Ref)
  , forall (es :: [Effect]). Env es -> IORef' Storage
envStorage :: !(IORef' Storage)
  }

-- | Reference to the effect in 'Storage'.
data Ref = Ref !Int !Version

instance Prim Ref where
  sizeOf# :: Ref -> Int#
sizeOf# Ref
_ = Int#
2# Int# -> Int# -> Int#
*# Int -> Int#
forall a. Prim a => a -> Int#
sizeOf# (Int
forall a. HasCallStack => a
undefined :: Int)
  alignment# :: Ref -> Int#
alignment# Ref
_ = Int -> Int#
forall a. Prim a => a -> Int#
alignment# (Int
forall a. HasCallStack => a
undefined :: Int)
  indexByteArray# :: ByteArray# -> Int# -> Ref
indexByteArray# ByteArray#
arr Int#
i =
    let n :: Int#
n = Int#
2# Int# -> Int# -> Int#
*# Int#
i
        ref :: Int
ref = ByteArray# -> Int# -> Int
forall a. Prim a => ByteArray# -> Int# -> a
indexByteArray# ByteArray#
arr Int#
n
        version :: Version
version = ByteArray# -> Int# -> Version
forall a. Prim a => ByteArray# -> Int# -> a
indexByteArray# ByteArray#
arr (Int#
n Int# -> Int# -> Int#
+# Int#
1#)
    in Int -> Version -> Ref
Ref Int
ref Version
version
  readByteArray# :: forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, Ref #)
readByteArray# MutableByteArray# s
arr Int#
i State# s
s0 =
    let n :: Int#
n = Int#
2# Int# -> Int# -> Int#
*# Int#
i
        !(# State# s
s1, Int
ref #) = MutableByteArray# s -> Int# -> State# s -> (# State# s, Int #)
forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, Int #)
forall a s.
Prim a =>
MutableByteArray# s -> Int# -> State# s -> (# State# s, a #)
readByteArray# MutableByteArray# s
arr Int#
n State# s
s0
        !(# State# s
s2, Version
version #) = MutableByteArray# s -> Int# -> State# s -> (# State# s, Version #)
forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, Version #)
forall a s.
Prim a =>
MutableByteArray# s -> Int# -> State# s -> (# State# s, a #)
readByteArray# MutableByteArray# s
arr (Int#
n Int# -> Int# -> Int#
+# Int#
1#) State# s
s1
    in (# State# s
s2, Int -> Version -> Ref
Ref Int
ref Version
version #)
  writeByteArray# :: forall s.
MutableByteArray# s -> Int# -> Ref -> State# s -> State# s
writeByteArray# MutableByteArray# s
arr Int#
i (Ref Int
ref Version
version) State# s
s0 =
    let n :: Int#
n = Int#
2# Int# -> Int# -> Int#
*# Int#
i
        s1 :: State# s
s1 = MutableByteArray# s -> Int# -> Int -> State# s -> State# s
forall s.
MutableByteArray# s -> Int# -> Int -> State# s -> State# s
forall a s.
Prim a =>
MutableByteArray# s -> Int# -> a -> State# s -> State# s
writeByteArray# MutableByteArray# s
arr Int#
n Int
ref State# s
s0
        s2 :: State# s
s2 = MutableByteArray# s -> Int# -> Version -> State# s -> State# s
forall s.
MutableByteArray# s -> Int# -> Version -> State# s -> State# s
forall a s.
Prim a =>
MutableByteArray# s -> Int# -> a -> State# s -> State# s
writeByteArray# MutableByteArray# s
arr (Int#
n Int# -> Int# -> Int#
+# Int#
1#) Version
version State# s
s1
    in State# s
s2
  indexOffAddr# :: Addr# -> Int# -> Ref
indexOffAddr# Addr#
addr Int#
i =
    let n :: Int#
n = Int#
2# Int# -> Int# -> Int#
*# Int#
i
        ref :: Int
ref = Addr# -> Int# -> Int
forall a. Prim a => Addr# -> Int# -> a
indexOffAddr# Addr#
addr Int#
n
        version :: Version
version = Addr# -> Int# -> Version
forall a. Prim a => Addr# -> Int# -> a
indexOffAddr# Addr#
addr (Int#
n Int# -> Int# -> Int#
+# Int#
1#)
    in Int -> Version -> Ref
Ref Int
ref Version
version
  readOffAddr# :: forall s. Addr# -> Int# -> State# s -> (# State# s, Ref #)
readOffAddr# Addr#
addr Int#
i State# s
s0 =
    let n :: Int#
n = Int#
2# Int# -> Int# -> Int#
*# Int#
i
        !(# State# s
s1, Int
ref #) = Addr# -> Int# -> State# s -> (# State# s, Int #)
forall s. Addr# -> Int# -> State# s -> (# State# s, Int #)
forall a s.
Prim a =>
Addr# -> Int# -> State# s -> (# State# s, a #)
readOffAddr# Addr#
addr Int#
n State# s
s0
        !(# State# s
s2, Version
version #) = Addr# -> Int# -> State# s -> (# State# s, Version #)
forall s. Addr# -> Int# -> State# s -> (# State# s, Version #)
forall a s.
Prim a =>
Addr# -> Int# -> State# s -> (# State# s, a #)
readOffAddr# Addr#
addr (Int#
n Int# -> Int# -> Int#
+# Int#
1#) State# s
s1
    in (# State# s
s2, Int -> Version -> Ref
Ref Int
ref Version
version #)
  writeOffAddr# :: forall s. Addr# -> Int# -> Ref -> State# s -> State# s
writeOffAddr# Addr#
addr Int#
i (Ref Int
ref Version
version) State# s
s0 =
    let n :: Int#
n = Int#
2# Int# -> Int# -> Int#
*# Int#
i
        s1 :: State# s
s1 = Addr# -> Int# -> Int -> State# s -> State# s
forall s. Addr# -> Int# -> Int -> State# s -> State# s
forall a s. Prim a => Addr# -> Int# -> a -> State# s -> State# s
writeOffAddr# Addr#
addr Int#
n Int
ref State# s
s0
        s2 :: State# s
s2 = Addr# -> Int# -> Version -> State# s -> State# s
forall s. Addr# -> Int# -> Version -> State# s -> State# s
forall a s. Prim a => Addr# -> Int# -> a -> State# s -> State# s
writeOffAddr# Addr#
addr (Int#
n Int# -> Int# -> Int#
+# Int#
1#) Version
version State# s
s1
    in State# s
s2

-- | Version of the effect.
newtype Version = Version Int
  deriving newtype (Version -> Version -> Bool
(Version -> Version -> Bool)
-> (Version -> Version -> Bool) -> Eq Version
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Version -> Version -> Bool
== :: Version -> Version -> Bool
$c/= :: Version -> Version -> Bool
/= :: Version -> Version -> Bool
Eq, Eq Version
Eq Version =>
(Version -> Version -> Ordering)
-> (Version -> Version -> Bool)
-> (Version -> Version -> Bool)
-> (Version -> Version -> Bool)
-> (Version -> Version -> Bool)
-> (Version -> Version -> Version)
-> (Version -> Version -> Version)
-> Ord Version
Version -> Version -> Bool
Version -> Version -> Ordering
Version -> Version -> Version
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Version -> Version -> Ordering
compare :: Version -> Version -> Ordering
$c< :: Version -> Version -> Bool
< :: Version -> Version -> Bool
$c<= :: Version -> Version -> Bool
<= :: Version -> Version -> Bool
$c> :: Version -> Version -> Bool
> :: Version -> Version -> Bool
$c>= :: Version -> Version -> Bool
>= :: Version -> Version -> Bool
$cmax :: Version -> Version -> Version
max :: Version -> Version -> Version
$cmin :: Version -> Version -> Version
min :: Version -> Version -> Version
Ord, Addr# -> Int# -> Version
ByteArray# -> Int# -> Version
Proxy Version -> Int#
Version -> Int#
(Proxy Version -> Int#)
-> (Version -> Int#)
-> (Proxy Version -> Int#)
-> (Version -> Int#)
-> (ByteArray# -> Int# -> Version)
-> (forall s.
    MutableByteArray# s -> Int# -> State# s -> (# State# s, Version #))
-> (forall s.
    MutableByteArray# s -> Int# -> Version -> State# s -> State# s)
-> (forall s.
    MutableByteArray# s
    -> Int# -> Int# -> Version -> State# s -> State# s)
-> (Addr# -> Int# -> Version)
-> (forall s. Addr# -> Int# -> State# s -> (# State# s, Version #))
-> (forall s. Addr# -> Int# -> Version -> State# s -> State# s)
-> (forall s.
    Addr# -> Int# -> Int# -> Version -> State# s -> State# s)
-> Prim Version
forall s. Addr# -> Int# -> Int# -> Version -> State# s -> State# s
forall s. Addr# -> Int# -> State# s -> (# State# s, Version #)
forall s. Addr# -> Int# -> Version -> State# s -> State# s
forall s.
MutableByteArray# s
-> Int# -> Int# -> Version -> State# s -> State# s
forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, Version #)
forall s.
MutableByteArray# s -> Int# -> Version -> State# s -> State# s
forall a.
(Proxy a -> Int#)
-> (a -> Int#)
-> (Proxy a -> Int#)
-> (a -> Int#)
-> (ByteArray# -> Int# -> a)
-> (forall s.
    MutableByteArray# s -> Int# -> State# s -> (# State# s, a #))
-> (forall s.
    MutableByteArray# s -> Int# -> a -> State# s -> State# s)
-> (forall s.
    MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s)
-> (Addr# -> Int# -> a)
-> (forall s. Addr# -> Int# -> State# s -> (# State# s, a #))
-> (forall s. Addr# -> Int# -> a -> State# s -> State# s)
-> (forall s. Addr# -> Int# -> Int# -> a -> State# s -> State# s)
-> Prim a
$csizeOfType# :: Proxy Version -> Int#
sizeOfType# :: Proxy Version -> Int#
$csizeOf# :: Version -> Int#
sizeOf# :: Version -> Int#
$calignmentOfType# :: Proxy Version -> Int#
alignmentOfType# :: Proxy Version -> Int#
$calignment# :: Version -> Int#
alignment# :: Version -> Int#
$cindexByteArray# :: ByteArray# -> Int# -> Version
indexByteArray# :: ByteArray# -> Int# -> Version
$creadByteArray# :: forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, Version #)
readByteArray# :: forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, Version #)
$cwriteByteArray# :: forall s.
MutableByteArray# s -> Int# -> Version -> State# s -> State# s
writeByteArray# :: forall s.
MutableByteArray# s -> Int# -> Version -> State# s -> State# s
$csetByteArray# :: forall s.
MutableByteArray# s
-> Int# -> Int# -> Version -> State# s -> State# s
setByteArray# :: forall s.
MutableByteArray# s
-> Int# -> Int# -> Version -> State# s -> State# s
$cindexOffAddr# :: Addr# -> Int# -> Version
indexOffAddr# :: Addr# -> Int# -> Version
$creadOffAddr# :: forall s. Addr# -> Int# -> State# s -> (# State# s, Version #)
readOffAddr# :: forall s. Addr# -> Int# -> State# s -> (# State# s, Version #)
$cwriteOffAddr# :: forall s. Addr# -> Int# -> Version -> State# s -> State# s
writeOffAddr# :: forall s. Addr# -> Int# -> Version -> State# s -> State# s
$csetOffAddr# :: forall s. Addr# -> Int# -> Int# -> Version -> State# s -> State# s
setOffAddr# :: forall s. Addr# -> Int# -> Int# -> Version -> State# s -> State# s
Prim, Int -> Version -> ShowS
[Version] -> ShowS
Version -> String
(Int -> Version -> ShowS)
-> (Version -> String) -> ([Version] -> ShowS) -> Show Version
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Version -> ShowS
showsPrec :: Int -> Version -> ShowS
$cshow :: Version -> String
show :: Version -> String
$cshowList :: [Version] -> ShowS
showList :: [Version] -> ShowS
Show)

-- | A storage of effects.
data Storage = Storage
  { Storage -> Int
stSize      :: !Int
  , Storage -> Version
stVersion   :: !Version
  , Storage -> MutablePrimArray RealWorld Version
stVersions  :: !(MutablePrimArray RealWorld Version)
  , Storage -> SmallMutableArray RealWorld AnyEffect
stEffects   :: !(SmallMutableArray RealWorld AnyEffect)
  , Storage -> SmallMutableArray RealWorld AnyRelinker
stRelinkers :: !(SmallMutableArray RealWorld AnyRelinker)
  }

-- | Effect in 'Storage'.
newtype AnyEffect = AnyEffect Any

toAnyEffect :: EffectRep (DispatchOf e) e -> AnyEffect
toAnyEffect :: forall (e :: Effect). EffectRep (DispatchOf e) e -> AnyEffect
toAnyEffect = Any -> AnyEffect
AnyEffect (Any -> AnyEffect)
-> (EffectRep (DispatchOf e) e -> Any)
-> EffectRep (DispatchOf e) e
-> AnyEffect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectRep (DispatchOf e) e -> Any
forall a. a -> Any
toAny

fromAnyEffect :: AnyEffect -> EffectRep (DispatchOf e) e
fromAnyEffect :: forall (e :: Effect). AnyEffect -> EffectRep (DispatchOf e) e
fromAnyEffect (AnyEffect Any
e) = Any -> EffectRep (DispatchOf e) e
forall a. Any -> a
fromAny Any
e

-- | Relinker in 'Storage'.
newtype AnyRelinker = AnyRelinker Any

toAnyRelinker :: Relinker (EffectRep (DispatchOf e)) e -> AnyRelinker
toAnyRelinker :: forall (e :: Effect).
Relinker (EffectRep (DispatchOf e)) e -> AnyRelinker
toAnyRelinker = Any -> AnyRelinker
AnyRelinker (Any -> AnyRelinker)
-> (Relinker (EffectRep (DispatchOf e)) e -> Any)
-> Relinker (EffectRep (DispatchOf e)) e
-> AnyRelinker
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relinker (EffectRep (DispatchOf e)) e -> Any
forall a. a -> Any
toAny

fromAnyRelinker :: AnyRelinker -> Relinker (EffectRep (DispatchOf e)) e
fromAnyRelinker :: forall (e :: Effect).
AnyRelinker -> Relinker (EffectRep (DispatchOf e)) e
fromAnyRelinker (AnyRelinker Any
f) = Any -> Relinker (EffectRep (DispatchOf e)) e
forall a. Any -> a
fromAny Any
f

----------------------------------------
-- Relinker

-- | A function for relinking 'Env' objects stored in the handlers and/or making
-- a deep copy of the representation of the effect when cloning the environment.
newtype Relinker :: (Effect -> Type) -> Effect -> Type where
  Relinker
    :: (HasCallStack => (forall es. Env es -> IO (Env es)) -> rep e -> IO (rep e))
    -> Relinker rep e

-- | A dummy 'Relinker'.
dummyRelinker :: Relinker rep e
dummyRelinker :: forall (rep :: Effect -> Type) (e :: Effect). Relinker rep e
dummyRelinker = (HasCallStack =>
 (forall (es :: [Effect]). Env es -> IO (Env es))
 -> rep e -> IO (rep e))
-> Relinker rep e
forall (rep :: Effect -> Type) (e :: Effect).
(HasCallStack =>
 (forall (es :: [Effect]). Env es -> IO (Env es))
 -> rep e -> IO (rep e))
-> Relinker rep e
Relinker ((HasCallStack =>
  (forall (es :: [Effect]). Env es -> IO (Env es))
  -> rep e -> IO (rep e))
 -> Relinker rep e)
-> (HasCallStack =>
    (forall (es :: [Effect]). Env es -> IO (Env es))
    -> rep e -> IO (rep e))
-> Relinker rep e
forall a b. (a -> b) -> a -> b
$ \forall (es :: [Effect]). Env es -> IO (Env es)
_ -> rep e -> IO (rep e)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure

----------------------------------------
-- Dispatch

-- | A type of dispatch. For more information consult the documentation in
-- "Effectful.Dispatch.Dynamic" and "Effectful.Dispatch.Static".
data Dispatch = Dynamic | Static SideEffects

-- | Signifies whether core operations of a statically dispatched effect perform
-- side effects. If an effect is marked as such, the
-- 'Effectful.Dispatch.Static.runStaticRep' family of functions will require the
-- 'Effectful.IOE' effect to be in context via the
-- 'Effectful.Dispatch.Static.MaybeIOE' type family.
data SideEffects = NoSideEffects | WithSideEffects

-- | Dispatch types of effects.
type family DispatchOf (e :: Effect) :: Dispatch

-- | Internal representations of effects.
type family EffectRep (d :: Dispatch) :: Effect -> Type

----------------------------------------
-- Operations

-- | Create an empty environment.
emptyEnv :: HasCallStack => IO (Env '[])
emptyEnv :: HasCallStack => IO (Env '[])
emptyEnv = Int -> PrimArray Ref -> IORef' Storage -> Env '[]
forall (es :: [Effect]).
Int -> PrimArray Ref -> IORef' Storage -> Env es
Env Int
0
  (PrimArray Ref -> IORef' Storage -> Env '[])
-> IO (PrimArray Ref) -> IO (IORef' Storage -> Env '[])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutablePrimArray RealWorld Ref -> IO (PrimArray Ref)
MutablePrimArray (PrimState IO) Ref -> IO (PrimArray Ref)
forall (m :: Type -> Type) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray (MutablePrimArray RealWorld Ref -> IO (PrimArray Ref))
-> IO (MutablePrimArray RealWorld Ref) -> IO (PrimArray Ref)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> IO (MutablePrimArray (PrimState IO) Ref)
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
0)
  IO (IORef' Storage -> Env '[])
-> IO (IORef' Storage) -> IO (Env '[])
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Storage -> IO (IORef' Storage)
forall a. a -> IO (IORef' a)
newIORef' (Storage -> IO (IORef' Storage))
-> IO Storage -> IO (IORef' Storage)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Storage
HasCallStack => IO Storage
emptyStorage)

-- | Clone the environment to use it in a different thread.
cloneEnv :: HasCallStack => Env es -> IO (Env es)
cloneEnv :: forall (es :: [Effect]). HasCallStack => Env es -> IO (Env es)
cloneEnv (Env Int
offset PrimArray Ref
refs IORef' Storage
storage0) = do
  Storage Int
storageSize Version
version MutablePrimArray RealWorld Version
vs0 SmallMutableArray RealWorld AnyEffect
es0 SmallMutableArray RealWorld AnyRelinker
fs0 <- IORef' Storage -> IO Storage
forall a. IORef' a -> IO a
readIORef' IORef' Storage
storage0
  Int
vsSize <- MutablePrimArray (PrimState IO) Version -> IO Int
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a -> m Int
getSizeofMutablePrimArray  MutablePrimArray RealWorld Version
MutablePrimArray (PrimState IO) Version
vs0
  Int
esSize <- SmallMutableArray (PrimState IO) AnyEffect -> IO Int
forall (m :: Type -> Type) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m Int
getSizeofSmallMutableArray SmallMutableArray RealWorld AnyEffect
SmallMutableArray (PrimState IO) AnyEffect
es0
  Int
fsSize <- SmallMutableArray (PrimState IO) AnyRelinker -> IO Int
forall (m :: Type -> Type) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m Int
getSizeofSmallMutableArray SmallMutableArray RealWorld AnyRelinker
SmallMutableArray (PrimState IO) AnyRelinker
fs0
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Int
vsSize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
esSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"vsSize (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
vsSize String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") /= esSize (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
esSize String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Int
esSize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
fsSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"esSize (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
esSize String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") /= fsSize (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fsSize String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  MutablePrimArray RealWorld Version
vs <- MutablePrimArray (PrimState IO) Version
-> Int -> Int -> IO (MutablePrimArray (PrimState IO) Version)
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> Int -> m (MutablePrimArray (PrimState m) a)
cloneMutablePrimArray  MutablePrimArray RealWorld Version
MutablePrimArray (PrimState IO) Version
vs0 Int
0 Int
vsSize
  SmallMutableArray RealWorld AnyEffect
es <- SmallMutableArray (PrimState IO) AnyEffect
-> Int -> Int -> IO (SmallMutableArray (PrimState IO) AnyEffect)
forall (m :: Type -> Type) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a
-> Int -> Int -> m (SmallMutableArray (PrimState m) a)
cloneSmallMutableArray SmallMutableArray RealWorld AnyEffect
SmallMutableArray (PrimState IO) AnyEffect
es0 Int
0 Int
esSize
  SmallMutableArray RealWorld AnyRelinker
fs <- SmallMutableArray (PrimState IO) AnyRelinker
-> Int -> Int -> IO (SmallMutableArray (PrimState IO) AnyRelinker)
forall (m :: Type -> Type) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a
-> Int -> Int -> m (SmallMutableArray (PrimState m) a)
cloneSmallMutableArray SmallMutableArray RealWorld AnyRelinker
SmallMutableArray (PrimState IO) AnyRelinker
fs0 Int
0 Int
fsSize
  IORef' Storage
storage <- Storage -> IO (IORef' Storage)
forall a. a -> IO (IORef' a)
newIORef' (Storage -> IO (IORef' Storage)) -> Storage -> IO (IORef' Storage)
forall a b. (a -> b) -> a -> b
$ Int
-> Version
-> MutablePrimArray RealWorld Version
-> SmallMutableArray RealWorld AnyEffect
-> SmallMutableArray RealWorld AnyRelinker
-> Storage
Storage Int
storageSize Version
version MutablePrimArray RealWorld Version
vs SmallMutableArray RealWorld AnyEffect
es SmallMutableArray RealWorld AnyRelinker
fs
  let relinkEffects :: Int -> IO ()
relinkEffects = \case
        Int
0 -> () -> IO ()
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
        Int
k -> do
          let i :: Int
i = Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
          Relinker HasCallStack =>
(forall (es :: [Effect]). Env es -> IO (Env es))
-> EffectRep (DispatchOf Any) Any
-> IO (EffectRep (DispatchOf Any) Any)
relinker <- AnyRelinker -> Relinker (EffectRep (DispatchOf Any)) Any
forall (e :: Effect).
AnyRelinker -> Relinker (EffectRep (DispatchOf e)) e
fromAnyRelinker (AnyRelinker -> Relinker (EffectRep (DispatchOf Any)) Any)
-> IO AnyRelinker -> IO (Relinker (EffectRep (DispatchOf Any)) Any)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SmallMutableArray (PrimState IO) AnyRelinker
-> Int -> IO AnyRelinker
forall (m :: Type -> Type) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> m a
readSmallArray SmallMutableArray RealWorld AnyRelinker
SmallMutableArray (PrimState IO) AnyRelinker
fs Int
i
          SmallMutableArray (PrimState IO) AnyEffect -> Int -> IO AnyEffect
forall (m :: Type -> Type) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> m a
readSmallArray SmallMutableArray RealWorld AnyEffect
SmallMutableArray (PrimState IO) AnyEffect
es Int
i
            IO AnyEffect
-> (AnyEffect -> IO (EffectRep (DispatchOf Any) Any))
-> IO (EffectRep (DispatchOf Any) Any)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack =>
(forall (es :: [Effect]). Env es -> IO (Env es))
-> EffectRep (DispatchOf Any) Any
-> IO (EffectRep (DispatchOf Any) Any)
(forall (es :: [Effect]). Env es -> IO (Env es))
-> EffectRep (DispatchOf Any) Any
-> IO (EffectRep (DispatchOf Any) Any)
relinker (IORef' Storage -> Env es -> IO (Env es)
forall (es :: [Effect]). IORef' Storage -> Env es -> IO (Env es)
relinkEnv IORef' Storage
storage) (EffectRep (DispatchOf Any) Any
 -> IO (EffectRep (DispatchOf Any) Any))
-> (AnyEffect -> EffectRep (DispatchOf Any) Any)
-> AnyEffect
-> IO (EffectRep (DispatchOf Any) Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnyEffect -> EffectRep (DispatchOf Any) Any
forall (e :: Effect). AnyEffect -> EffectRep (DispatchOf e) e
fromAnyEffect
            IO (EffectRep (DispatchOf Any) Any)
-> (EffectRep (DispatchOf Any) Any -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= SmallMutableArray RealWorld AnyEffect -> Int -> AnyEffect -> IO ()
forall a. SmallMutableArray RealWorld a -> Int -> a -> IO ()
writeSmallArray' SmallMutableArray RealWorld AnyEffect
es Int
i (AnyEffect -> IO ())
-> (EffectRep (DispatchOf Any) Any -> AnyEffect)
-> EffectRep (DispatchOf Any) Any
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectRep (DispatchOf Any) Any -> AnyEffect
forall (e :: Effect). EffectRep (DispatchOf e) e -> AnyEffect
toAnyEffect
          Int -> IO ()
relinkEffects Int
i
  Int -> IO ()
relinkEffects Int
storageSize
  Env es -> IO (Env es)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Env es -> IO (Env es)) -> Env es -> IO (Env es)
forall a b. (a -> b) -> a -> b
$ Int -> PrimArray Ref -> IORef' Storage -> Env es
forall (es :: [Effect]).
Int -> PrimArray Ref -> IORef' Storage -> Env es
Env Int
offset PrimArray Ref
refs IORef' Storage
storage
{-# NOINLINE cloneEnv #-}

-- | Restore the environment from its clone.
--
-- @since 2.2.0.0
restoreEnv
  :: HasCallStack
  => Env es -- ^ Destination.
  -> Env es -- ^ Source.
  -> IO ()
restoreEnv :: forall (es :: [Effect]). HasCallStack => Env es -> Env es -> IO ()
restoreEnv Env es
dest Env es
src = do
  Storage
destStorage <- IORef' Storage -> IO Storage
forall a. IORef' a -> IO a
readIORef' (Env es -> IORef' Storage
forall (es :: [Effect]). Env es -> IORef' Storage
envStorage Env es
dest)
  Storage
srcStorage  <- IORef' Storage -> IO Storage
forall a. IORef' a -> IO a
readIORef' (Env es -> IORef' Storage
forall (es :: [Effect]). Env es -> IORef' Storage
envStorage Env es
src)
  let destStorageSize :: Int
destStorageSize = Storage -> Int
stSize Storage
destStorage
      srcStorageSize :: Int
srcStorageSize  = Storage -> Int
stSize Storage
srcStorage
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Int
destStorageSize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
srcStorageSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"destStorageSize (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
destStorageSize
         String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") /= srcStorageSize (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
srcStorageSize String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  IORef' Storage -> Storage -> IO ()
forall a. IORef' a -> a -> IO ()
writeIORef' (Env es -> IORef' Storage
forall (es :: [Effect]). Env es -> IORef' Storage
envStorage Env es
dest) (Storage -> IO ()) -> Storage -> IO ()
forall a b. (a -> b) -> a -> b
$ Storage
srcStorage
    -- Decreasing the counter allows leakage of unsafeCoerce (see unsafeCoerce2
    -- in the EnvTests module).
    { stVersion = max (stVersion destStorage) (stVersion srcStorage)
    }
{-# NOINLINE restoreEnv #-}

-- | Get the current size of the environment.
sizeEnv :: Env es -> IO Int
sizeEnv :: forall (es :: [Effect]). Env es -> IO Int
sizeEnv (Env Int
offset PrimArray Ref
refs IORef' Storage
_) = do
  Int -> IO Int
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ PrimArray Ref -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Ref
refs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offset

-- | Access the tail of the environment.
tailEnv :: Env (e : es) -> IO (Env es)
tailEnv :: forall (e :: Effect) (es :: [Effect]). Env (e : es) -> IO (Env es)
tailEnv (Env Int
offset PrimArray Ref
refs IORef' Storage
storage) = do
  Env es -> IO (Env es)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Env es -> IO (Env es)) -> Env es -> IO (Env es)
forall a b. (a -> b) -> a -> b
$ Int -> PrimArray Ref -> IORef' Storage -> Env es
forall (es :: [Effect]).
Int -> PrimArray Ref -> IORef' Storage -> Env es
Env (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) PrimArray Ref
refs IORef' Storage
storage

----------------------------------------
-- Extending and shrinking

-- | Extend the environment with a new data type.
consEnv
  :: HasCallStack
  => EffectRep (DispatchOf e) e
  -- ^ The representation of the effect.
  -> Relinker (EffectRep (DispatchOf e)) e
  -> Env es
  -> IO (Env (e : es))
consEnv :: forall (e :: Effect) (es :: [Effect]).
HasCallStack =>
EffectRep (DispatchOf e) e
-> Relinker (EffectRep (DispatchOf e)) e
-> Env es
-> IO (Env (e : es))
consEnv EffectRep (DispatchOf e) e
e Relinker (EffectRep (DispatchOf e)) e
f (Env Int
offset PrimArray Ref
refs0 IORef' Storage
storage) = do
  let size :: Int
size = PrimArray Ref -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Ref
refs0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offset
  MutablePrimArray RealWorld Ref
mrefs <- Int -> IO (MutablePrimArray (PrimState IO) Ref)
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  MutablePrimArray (PrimState IO) Ref
-> Int -> PrimArray Ref -> Int -> Int -> IO ()
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray RealWorld Ref
MutablePrimArray (PrimState IO) Ref
mrefs Int
1 PrimArray Ref
refs0 Int
offset Int
size
  Ref
ref <- IORef' Storage
-> EffectRep (DispatchOf e) e
-> Relinker (EffectRep (DispatchOf e)) e
-> IO Ref
forall (e :: Effect).
HasCallStack =>
IORef' Storage
-> EffectRep (DispatchOf e) e
-> Relinker (EffectRep (DispatchOf e)) e
-> IO Ref
insertEffect IORef' Storage
storage EffectRep (DispatchOf e) e
e Relinker (EffectRep (DispatchOf e)) e
f
  MutablePrimArray (PrimState IO) Ref -> Int -> Ref -> IO ()
forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld Ref
MutablePrimArray (PrimState IO) Ref
mrefs Int
0 Ref
ref
  PrimArray Ref
refs <- MutablePrimArray (PrimState IO) Ref -> IO (PrimArray Ref)
forall (m :: Type -> Type) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld Ref
MutablePrimArray (PrimState IO) Ref
mrefs
  Env (e : es) -> IO (Env (e : es))
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Env (e : es) -> IO (Env (e : es)))
-> Env (e : es) -> IO (Env (e : es))
forall a b. (a -> b) -> a -> b
$ Int -> PrimArray Ref -> IORef' Storage -> Env (e : es)
forall (es :: [Effect]).
Int -> PrimArray Ref -> IORef' Storage -> Env es
Env Int
0 PrimArray Ref
refs IORef' Storage
storage
{-# NOINLINE consEnv #-}

-- | Shrink the environment by one data type.
--
-- /Note:/ after calling this function @e@ from the input environment is no
-- longer usable.
unconsEnv :: HasCallStack => Env (e : es) -> IO ()
unconsEnv :: forall (e :: Effect) (es :: [Effect]).
HasCallStack =>
Env (e : es) -> IO ()
unconsEnv (Env Int
_ PrimArray Ref
refs IORef' Storage
storage) = do
  HasCallStack => IORef' Storage -> Ref -> IO ()
IORef' Storage -> Ref -> IO ()
deleteEffect IORef' Storage
storage (PrimArray Ref -> Int -> Ref
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Ref
refs Int
0)
{-# NOINLINE unconsEnv #-}

----------------------------------------

-- | Replace a specific effect in the stack with a new value.
--
-- /Note:/ unlike in 'putEnv' the value in not changed in place, so only the new
-- environment will see it.
replaceEnv
  :: forall e es. (HasCallStack, e :> es)
  => EffectRep (DispatchOf e) e
  -- ^ The representation of the effect.
  -> Relinker (EffectRep (DispatchOf e)) e
  -> Env es
  -> IO (Env es)
replaceEnv :: forall (e :: Effect) (es :: [Effect]).
(HasCallStack, e :> es) =>
EffectRep (DispatchOf e) e
-> Relinker (EffectRep (DispatchOf e)) e -> Env es -> IO (Env es)
replaceEnv EffectRep (DispatchOf e) e
e Relinker (EffectRep (DispatchOf e)) e
f (Env Int
offset PrimArray Ref
refs0 IORef' Storage
storage) = do
  let size :: Int
size = PrimArray Ref -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Ref
refs0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offset
  MutablePrimArray RealWorld Ref
mrefs <- Int -> IO (MutablePrimArray (PrimState IO) Ref)
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
size
  MutablePrimArray (PrimState IO) Ref
-> Int -> PrimArray Ref -> Int -> Int -> IO ()
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray RealWorld Ref
MutablePrimArray (PrimState IO) Ref
mrefs Int
0 PrimArray Ref
refs0 Int
offset Int
size
  Ref
ref <- IORef' Storage
-> EffectRep (DispatchOf e) e
-> Relinker (EffectRep (DispatchOf e)) e
-> IO Ref
forall (e :: Effect).
HasCallStack =>
IORef' Storage
-> EffectRep (DispatchOf e) e
-> Relinker (EffectRep (DispatchOf e)) e
-> IO Ref
insertEffect IORef' Storage
storage EffectRep (DispatchOf e) e
e Relinker (EffectRep (DispatchOf e)) e
f
  MutablePrimArray (PrimState IO) Ref -> Int -> Ref -> IO ()
forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld Ref
MutablePrimArray (PrimState IO) Ref
mrefs (forall (e :: Effect) (es :: [Effect]). (e :> es) => Int
reifyIndex @e @es) Ref
ref
  PrimArray Ref
refs <- MutablePrimArray (PrimState IO) Ref -> IO (PrimArray Ref)
forall (m :: Type -> Type) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld Ref
MutablePrimArray (PrimState IO) Ref
mrefs
  Env es -> IO (Env es)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Env es -> IO (Env es)) -> Env es -> IO (Env es)
forall a b. (a -> b) -> a -> b
$ Int -> PrimArray Ref -> IORef' Storage -> Env es
forall (es :: [Effect]).
Int -> PrimArray Ref -> IORef' Storage -> Env es
Env Int
0 PrimArray Ref
refs IORef' Storage
storage
{-# NOINLINE replaceEnv #-}

-- | Remove a reference to the replaced effect.
--
-- /Note:/ after calling this function the input environment is no longer
-- usable.
unreplaceEnv :: forall e es. (HasCallStack, e :> es) => Env es -> IO ()
unreplaceEnv :: forall (e :: Effect) (es :: [Effect]).
(HasCallStack, e :> es) =>
Env es -> IO ()
unreplaceEnv (Env Int
offset PrimArray Ref
refs IORef' Storage
storage) = do
  HasCallStack => IORef' Storage -> Ref -> IO ()
IORef' Storage -> Ref -> IO ()
deleteEffect IORef' Storage
storage (Ref -> IO ()) -> Ref -> IO ()
forall a b. (a -> b) -> a -> b
$ PrimArray Ref -> Int -> Ref
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Ref
refs (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ forall (e :: Effect) (es :: [Effect]). (e :> es) => Int
reifyIndex @e @es)
{-# NOINLINE unreplaceEnv #-}

----------------------------------------

-- | Reference an existing effect from the top of the stack.
subsumeEnv :: forall e es. e :> es => Env es -> IO (Env (e : es))
subsumeEnv :: forall (e :: Effect) (es :: [Effect]).
(e :> es) =>
Env es -> IO (Env (e : es))
subsumeEnv (Env Int
offset PrimArray Ref
refs0 IORef' Storage
storage) = do
  let size :: Int
size = PrimArray Ref -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Ref
refs0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offset
  MutablePrimArray RealWorld Ref
mrefs <- Int -> IO (MutablePrimArray (PrimState IO) Ref)
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  MutablePrimArray (PrimState IO) Ref
-> Int -> PrimArray Ref -> Int -> Int -> IO ()
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray RealWorld Ref
MutablePrimArray (PrimState IO) Ref
mrefs Int
1 PrimArray Ref
refs0 Int
offset Int
size
  MutablePrimArray (PrimState IO) Ref -> Int -> Ref -> IO ()
forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld Ref
MutablePrimArray (PrimState IO) Ref
mrefs Int
0 (Ref -> IO ()) -> Ref -> IO ()
forall a b. (a -> b) -> a -> b
$ PrimArray Ref -> Int -> Ref
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Ref
refs0 (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ forall (e :: Effect) (es :: [Effect]). (e :> es) => Int
reifyIndex @e @es)
  PrimArray Ref
refs <- MutablePrimArray (PrimState IO) Ref -> IO (PrimArray Ref)
forall (m :: Type -> Type) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld Ref
MutablePrimArray (PrimState IO) Ref
mrefs
  Env (e : es) -> IO (Env (e : es))
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Env (e : es) -> IO (Env (e : es)))
-> Env (e : es) -> IO (Env (e : es))
forall a b. (a -> b) -> a -> b
$ Int -> PrimArray Ref -> IORef' Storage -> Env (e : es)
forall (es :: [Effect]).
Int -> PrimArray Ref -> IORef' Storage -> Env es
Env Int
0 PrimArray Ref
refs IORef' Storage
storage
{-# NOINLINE subsumeEnv #-}

----------------------------------------

-- | Construct an environment containing a permutation (with possible
-- duplicates) of a subset of effects from the input environment.
injectEnv :: forall subEs es. Subset subEs es => Env es -> IO (Env subEs)
injectEnv :: forall (subEs :: [Effect]) (es :: [Effect]).
Subset subEs es =>
Env es -> IO (Env subEs)
injectEnv (Env Int
offset PrimArray Ref
refs0 IORef' Storage
storage) = do
  let subEs :: [Int]
subEs      = forall (subEs :: [Effect]) (es :: [Effect]).
Subset subEs es =>
[Int]
reifyIndices @subEs @es
      subEsSize :: Int
subEsSize  = [Int] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Int]
subEs
      prefixSize :: Int
prefixSize = forall (es :: [Effect]). KnownPrefix es => Int
prefixLength @es
      suffixSize :: Int
suffixSize = if forall (subEs :: [Effect]) (es :: [Effect]).
Subset subEs es =>
Bool
subsetFullyKnown @subEs @es
                   then Int
0
                   else PrimArray Ref -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Ref
refs0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
prefixSize
  MutablePrimArray RealWorld Ref
mrefs <- Int -> IO (MutablePrimArray (PrimState IO) Ref)
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray (Int
subEsSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
suffixSize)
  MutablePrimArray (PrimState IO) Ref
-> Int -> PrimArray Ref -> Int -> Int -> IO ()
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray RealWorld Ref
MutablePrimArray (PrimState IO) Ref
mrefs Int
subEsSize PrimArray Ref
refs0 (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
prefixSize) Int
suffixSize
  let writeRefs :: Int -> [Int] -> IO ()
writeRefs Int
i = \case
        []       -> () -> IO ()
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
        (Int
x : [Int]
xs) -> do
          MutablePrimArray (PrimState IO) Ref -> Int -> Ref -> IO ()
forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld Ref
MutablePrimArray (PrimState IO) Ref
mrefs Int
i (Ref -> IO ()) -> Ref -> IO ()
forall a b. (a -> b) -> a -> b
$ PrimArray Ref -> Int -> Ref
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Ref
refs0 (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x)
          Int -> [Int] -> IO ()
writeRefs (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Int]
xs
  Int -> [Int] -> IO ()
writeRefs Int
0 [Int]
subEs
  PrimArray Ref
refs <- MutablePrimArray (PrimState IO) Ref -> IO (PrimArray Ref)
forall (m :: Type -> Type) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld Ref
MutablePrimArray (PrimState IO) Ref
mrefs
  Env subEs -> IO (Env subEs)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Env subEs -> IO (Env subEs)) -> Env subEs -> IO (Env subEs)
forall a b. (a -> b) -> a -> b
$ Int -> PrimArray Ref -> IORef' Storage -> Env subEs
forall (es :: [Effect]).
Int -> PrimArray Ref -> IORef' Storage -> Env es
Env Int
0 PrimArray Ref
refs IORef' Storage
storage
{-# NOINLINE injectEnv #-}

----------------------------------------
-- Data retrieval and update

-- | Extract a specific data type from the environment.
getEnv
  :: forall e es. (HasCallStack, e :> es)
  => Env es -- ^ The environment.
  -> IO (EffectRep (DispatchOf e) e)
getEnv :: forall (e :: Effect) (es :: [Effect]).
(HasCallStack, e :> es) =>
Env es -> IO (EffectRep (DispatchOf e) e)
getEnv Env es
env = do
  (Int
i, SmallMutableArray RealWorld AnyEffect
es) <- forall (e :: Effect) (es :: [Effect]).
(HasCallStack, e :> es) =>
Env es -> IO (Int, SmallMutableArray RealWorld AnyEffect)
getLocation @e Env es
env
  AnyEffect -> EffectRep (DispatchOf e) e
forall (e :: Effect). AnyEffect -> EffectRep (DispatchOf e) e
fromAnyEffect (AnyEffect -> EffectRep (DispatchOf e) e)
-> IO AnyEffect -> IO (EffectRep (DispatchOf e) e)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SmallMutableArray (PrimState IO) AnyEffect -> Int -> IO AnyEffect
forall (m :: Type -> Type) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> m a
readSmallArray SmallMutableArray RealWorld AnyEffect
SmallMutableArray (PrimState IO) AnyEffect
es Int
i

-- | Replace the data type in the environment with a new value (in place).
putEnv
  :: forall e es. (HasCallStack, e :> es)
  => Env es -- ^ The environment.
  -> EffectRep (DispatchOf e) e
  -> IO ()
putEnv :: forall (e :: Effect) (es :: [Effect]).
(HasCallStack, e :> es) =>
Env es -> EffectRep (DispatchOf e) e -> IO ()
putEnv Env es
env EffectRep (DispatchOf e) e
e = do
  (Int
i, SmallMutableArray RealWorld AnyEffect
es) <- forall (e :: Effect) (es :: [Effect]).
(HasCallStack, e :> es) =>
Env es -> IO (Int, SmallMutableArray RealWorld AnyEffect)
getLocation @e Env es
env
  SmallMutableArray RealWorld AnyEffect -> Int -> AnyEffect -> IO ()
forall a. SmallMutableArray RealWorld a -> Int -> a -> IO ()
writeSmallArray' SmallMutableArray RealWorld AnyEffect
es Int
i (EffectRep (DispatchOf e) e -> AnyEffect
forall (e :: Effect). EffectRep (DispatchOf e) e -> AnyEffect
toAnyEffect EffectRep (DispatchOf e) e
e)

-- | Modify the data type in the environment and return a value (in place).
stateEnv
  :: forall e es a. (HasCallStack, e :> es)
  => Env es -- ^ The environment.
  -> (EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e))
  -> IO a
stateEnv :: forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, e :> es) =>
Env es
-> (EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e))
-> IO a
stateEnv Env es
env EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e)
f = do
  (Int
i, SmallMutableArray RealWorld AnyEffect
es) <- forall (e :: Effect) (es :: [Effect]).
(HasCallStack, e :> es) =>
Env es -> IO (Int, SmallMutableArray RealWorld AnyEffect)
getLocation @e Env es
env
  (a
a, EffectRep (DispatchOf e) e
e) <- EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e)
f (EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e))
-> (AnyEffect -> EffectRep (DispatchOf e) e)
-> AnyEffect
-> (a, EffectRep (DispatchOf e) e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnyEffect -> EffectRep (DispatchOf e) e
forall (e :: Effect). AnyEffect -> EffectRep (DispatchOf e) e
fromAnyEffect (AnyEffect -> (a, EffectRep (DispatchOf e) e))
-> IO AnyEffect -> IO (a, EffectRep (DispatchOf e) e)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SmallMutableArray (PrimState IO) AnyEffect -> Int -> IO AnyEffect
forall (m :: Type -> Type) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> m a
readSmallArray SmallMutableArray RealWorld AnyEffect
SmallMutableArray (PrimState IO) AnyEffect
es Int
i
  SmallMutableArray RealWorld AnyEffect -> Int -> AnyEffect -> IO ()
forall a. SmallMutableArray RealWorld a -> Int -> a -> IO ()
writeSmallArray' SmallMutableArray RealWorld AnyEffect
es Int
i (EffectRep (DispatchOf e) e -> AnyEffect
forall (e :: Effect). EffectRep (DispatchOf e) e -> AnyEffect
toAnyEffect EffectRep (DispatchOf e) e
e)
  a -> IO a
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
a

-- | Modify the data type in the environment (in place).
modifyEnv
  :: forall e es. (HasCallStack, e :> es)
  => Env es -- ^ The environment.
  -> (EffectRep (DispatchOf e) e -> (EffectRep (DispatchOf e) e))
  -> IO ()
modifyEnv :: forall (e :: Effect) (es :: [Effect]).
(HasCallStack, e :> es) =>
Env es
-> (EffectRep (DispatchOf e) e -> EffectRep (DispatchOf e) e)
-> IO ()
modifyEnv Env es
env EffectRep (DispatchOf e) e -> EffectRep (DispatchOf e) e
f = do
  (Int
i, SmallMutableArray RealWorld AnyEffect
es) <- forall (e :: Effect) (es :: [Effect]).
(HasCallStack, e :> es) =>
Env es -> IO (Int, SmallMutableArray RealWorld AnyEffect)
getLocation @e Env es
env
  EffectRep (DispatchOf e) e
e <- EffectRep (DispatchOf e) e -> EffectRep (DispatchOf e) e
f (EffectRep (DispatchOf e) e -> EffectRep (DispatchOf e) e)
-> (AnyEffect -> EffectRep (DispatchOf e) e)
-> AnyEffect
-> EffectRep (DispatchOf e) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnyEffect -> EffectRep (DispatchOf e) e
forall (e :: Effect). AnyEffect -> EffectRep (DispatchOf e) e
fromAnyEffect (AnyEffect -> EffectRep (DispatchOf e) e)
-> IO AnyEffect -> IO (EffectRep (DispatchOf e) e)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SmallMutableArray (PrimState IO) AnyEffect -> Int -> IO AnyEffect
forall (m :: Type -> Type) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> m a
readSmallArray SmallMutableArray RealWorld AnyEffect
SmallMutableArray (PrimState IO) AnyEffect
es Int
i
  SmallMutableArray RealWorld AnyEffect -> Int -> AnyEffect -> IO ()
forall a. SmallMutableArray RealWorld a -> Int -> a -> IO ()
writeSmallArray' SmallMutableArray RealWorld AnyEffect
es Int
i (EffectRep (DispatchOf e) e -> AnyEffect
forall (e :: Effect). EffectRep (DispatchOf e) e -> AnyEffect
toAnyEffect EffectRep (DispatchOf e) e
e)

-- | Determine location of the effect in the environment.
getLocation
  :: forall e es. (HasCallStack, e :> es)
  => Env es
  -> IO (Int, SmallMutableArray RealWorld AnyEffect)
getLocation :: forall (e :: Effect) (es :: [Effect]).
(HasCallStack, e :> es) =>
Env es -> IO (Int, SmallMutableArray RealWorld AnyEffect)
getLocation (Env Int
offset PrimArray Ref
refs IORef' Storage
storage) = do
  Storage Int
_ Version
_ MutablePrimArray RealWorld Version
vs SmallMutableArray RealWorld AnyEffect
es SmallMutableArray RealWorld AnyRelinker
_ <- IORef' Storage -> IO Storage
forall a. IORef' a -> IO a
readIORef' IORef' Storage
storage
  Version
storageVersion <- MutablePrimArray (PrimState IO) Version -> Int -> IO Version
forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld Version
MutablePrimArray (PrimState IO) Version
vs Int
ref
  -- If version of the reference is different than version in the storage, it
  -- means that the effect in the storage is not the one that was initially
  -- referenced.
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Version
version Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
storageVersion) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"version (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Show a => a -> String
show Version
version String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") /= storageVersion ("
         String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Show a => a -> String
show Version
storageVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")\n"
         String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"If you're attempting to run an unlifting function outside "
         String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"of the scope of effects it captures, have a look at "
         String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"UnliftingStrategy (SeqForkUnlift)."
  (Int, SmallMutableArray RealWorld AnyEffect)
-> IO (Int, SmallMutableArray RealWorld AnyEffect)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Int
ref, SmallMutableArray RealWorld AnyEffect
es)
  where
    Ref Int
ref Version
version = PrimArray Ref -> Int -> Ref
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Ref
refs (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ forall (e :: Effect) (es :: [Effect]). (e :> es) => Int
reifyIndex @e @es)

----------------------------------------
-- Internal helpers

-- | Create an empty storage.
emptyStorage :: HasCallStack => IO Storage
emptyStorage :: HasCallStack => IO Storage
emptyStorage = Int
-> Version
-> MutablePrimArray RealWorld Version
-> SmallMutableArray RealWorld AnyEffect
-> SmallMutableArray RealWorld AnyRelinker
-> Storage
Storage Int
0 Version
initialVersion
  (MutablePrimArray RealWorld Version
 -> SmallMutableArray RealWorld AnyEffect
 -> SmallMutableArray RealWorld AnyRelinker
 -> Storage)
-> IO (MutablePrimArray RealWorld Version)
-> IO
     (SmallMutableArray RealWorld AnyEffect
      -> SmallMutableArray RealWorld AnyRelinker -> Storage)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO (MutablePrimArray (PrimState IO) Version)
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
0
  IO
  (SmallMutableArray RealWorld AnyEffect
   -> SmallMutableArray RealWorld AnyRelinker -> Storage)
-> IO (SmallMutableArray RealWorld AnyEffect)
-> IO (SmallMutableArray RealWorld AnyRelinker -> Storage)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Int -> AnyEffect -> IO (SmallMutableArray (PrimState IO) AnyEffect)
forall (m :: Type -> Type) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
newSmallArray Int
0 AnyEffect
HasCallStack => AnyEffect
undefinedEffect
  IO (SmallMutableArray RealWorld AnyRelinker -> Storage)
-> IO (SmallMutableArray RealWorld AnyRelinker) -> IO Storage
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Int
-> AnyRelinker -> IO (SmallMutableArray (PrimState IO) AnyRelinker)
forall (m :: Type -> Type) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
newSmallArray Int
0 AnyRelinker
HasCallStack => AnyRelinker
undefinedRelinker

-- | Insert an effect into the storage and return its reference.
insertEffect
  :: HasCallStack
  => IORef' Storage
  -> EffectRep (DispatchOf e) e
  -- ^ The representation of the effect.
  -> Relinker (EffectRep (DispatchOf e)) e
  -> IO Ref
insertEffect :: forall (e :: Effect).
HasCallStack =>
IORef' Storage
-> EffectRep (DispatchOf e) e
-> Relinker (EffectRep (DispatchOf e)) e
-> IO Ref
insertEffect IORef' Storage
storage EffectRep (DispatchOf e) e
e Relinker (EffectRep (DispatchOf e)) e
f = do
  Storage Int
size Version
version MutablePrimArray RealWorld Version
vs0 SmallMutableArray RealWorld AnyEffect
es0 SmallMutableArray RealWorld AnyRelinker
fs0 <- IORef' Storage -> IO Storage
forall a. IORef' a -> IO a
readIORef' IORef' Storage
storage
  Int
len0 <- SmallMutableArray (PrimState IO) AnyEffect -> IO Int
forall (m :: Type -> Type) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m Int
getSizeofSmallMutableArray SmallMutableArray RealWorld AnyEffect
SmallMutableArray (PrimState IO) AnyEffect
es0
  case Int
size Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Int
len0 of
    Ordering
GT -> String -> IO Ref
forall a. HasCallStack => String -> a
error (String -> IO Ref) -> String -> IO Ref
forall a b. (a -> b) -> a -> b
$ String
"size (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
size String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") > len0 (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len0 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    Ordering
LT -> do
      MutablePrimArray (PrimState IO) Version -> Int -> Version -> IO ()
forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray   MutablePrimArray RealWorld Version
MutablePrimArray (PrimState IO) Version
vs0 Int
size Version
version
      SmallMutableArray RealWorld AnyEffect -> Int -> AnyEffect -> IO ()
forall a. SmallMutableArray RealWorld a -> Int -> a -> IO ()
writeSmallArray' SmallMutableArray RealWorld AnyEffect
es0 Int
size (EffectRep (DispatchOf e) e -> AnyEffect
forall (e :: Effect). EffectRep (DispatchOf e) e -> AnyEffect
toAnyEffect EffectRep (DispatchOf e) e
e)
      SmallMutableArray RealWorld AnyRelinker
-> Int -> AnyRelinker -> IO ()
forall a. SmallMutableArray RealWorld a -> Int -> a -> IO ()
writeSmallArray' SmallMutableArray RealWorld AnyRelinker
fs0 Int
size (Relinker (EffectRep (DispatchOf e)) e -> AnyRelinker
forall (e :: Effect).
Relinker (EffectRep (DispatchOf e)) e -> AnyRelinker
toAnyRelinker Relinker (EffectRep (DispatchOf e)) e
f)
      IORef' Storage -> Storage -> IO ()
forall a. IORef' a -> a -> IO ()
writeIORef' IORef' Storage
storage (Storage -> IO ()) -> Storage -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
-> Version
-> MutablePrimArray RealWorld Version
-> SmallMutableArray RealWorld AnyEffect
-> SmallMutableArray RealWorld AnyRelinker
-> Storage
Storage (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Version -> Version
bumpVersion Version
version) MutablePrimArray RealWorld Version
vs0 SmallMutableArray RealWorld AnyEffect
es0 SmallMutableArray RealWorld AnyRelinker
fs0
      Ref -> IO Ref
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Ref -> IO Ref) -> Ref -> IO Ref
forall a b. (a -> b) -> a -> b
$ Int -> Version -> Ref
Ref Int
size Version
version
    Ordering
EQ -> do
      let len :: Int
len = Int -> Int
doubleCapacity Int
len0
      MutablePrimArray RealWorld Version
vs <- Int -> IO (MutablePrimArray (PrimState IO) Version)
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
len
      SmallMutableArray RealWorld AnyEffect
es <- Int -> AnyEffect -> IO (SmallMutableArray (PrimState IO) AnyEffect)
forall (m :: Type -> Type) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
newSmallArray Int
len AnyEffect
HasCallStack => AnyEffect
undefinedEffect
      SmallMutableArray RealWorld AnyRelinker
fs <- Int
-> AnyRelinker -> IO (SmallMutableArray (PrimState IO) AnyRelinker)
forall (m :: Type -> Type) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
newSmallArray Int
len AnyRelinker
HasCallStack => AnyRelinker
undefinedRelinker
      MutablePrimArray (PrimState IO) Version
-> Int
-> MutablePrimArray (PrimState IO) Version
-> Int
-> Int
-> IO ()
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> MutablePrimArray (PrimState m) a -> Int -> Int -> m ()
copyMutablePrimArray  MutablePrimArray RealWorld Version
MutablePrimArray (PrimState IO) Version
vs Int
0 MutablePrimArray RealWorld Version
MutablePrimArray (PrimState IO) Version
vs0 Int
0 Int
size
      SmallMutableArray (PrimState IO) AnyEffect
-> Int
-> SmallMutableArray (PrimState IO) AnyEffect
-> Int
-> Int
-> IO ()
forall (m :: Type -> Type) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a
-> Int -> SmallMutableArray (PrimState m) a -> Int -> Int -> m ()
copySmallMutableArray SmallMutableArray RealWorld AnyEffect
SmallMutableArray (PrimState IO) AnyEffect
es Int
0 SmallMutableArray RealWorld AnyEffect
SmallMutableArray (PrimState IO) AnyEffect
es0 Int
0 Int
size
      SmallMutableArray (PrimState IO) AnyRelinker
-> Int
-> SmallMutableArray (PrimState IO) AnyRelinker
-> Int
-> Int
-> IO ()
forall (m :: Type -> Type) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a
-> Int -> SmallMutableArray (PrimState m) a -> Int -> Int -> m ()
copySmallMutableArray SmallMutableArray RealWorld AnyRelinker
SmallMutableArray (PrimState IO) AnyRelinker
fs Int
0 SmallMutableArray RealWorld AnyRelinker
SmallMutableArray (PrimState IO) AnyRelinker
fs0 Int
0 Int
size
      MutablePrimArray (PrimState IO) Version -> Int -> Version -> IO ()
forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray   MutablePrimArray RealWorld Version
MutablePrimArray (PrimState IO) Version
vs Int
size Version
version
      SmallMutableArray RealWorld AnyEffect -> Int -> AnyEffect -> IO ()
forall a. SmallMutableArray RealWorld a -> Int -> a -> IO ()
writeSmallArray' SmallMutableArray RealWorld AnyEffect
es Int
size (EffectRep (DispatchOf e) e -> AnyEffect
forall (e :: Effect). EffectRep (DispatchOf e) e -> AnyEffect
toAnyEffect EffectRep (DispatchOf e) e
e)
      SmallMutableArray RealWorld AnyRelinker
-> Int -> AnyRelinker -> IO ()
forall a. SmallMutableArray RealWorld a -> Int -> a -> IO ()
writeSmallArray' SmallMutableArray RealWorld AnyRelinker
fs Int
size (Relinker (EffectRep (DispatchOf e)) e -> AnyRelinker
forall (e :: Effect).
Relinker (EffectRep (DispatchOf e)) e -> AnyRelinker
toAnyRelinker Relinker (EffectRep (DispatchOf e)) e
f)
      IORef' Storage -> Storage -> IO ()
forall a. IORef' a -> a -> IO ()
writeIORef' IORef' Storage
storage (Storage -> IO ()) -> Storage -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
-> Version
-> MutablePrimArray RealWorld Version
-> SmallMutableArray RealWorld AnyEffect
-> SmallMutableArray RealWorld AnyRelinker
-> Storage
Storage (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Version -> Version
bumpVersion Version
version) MutablePrimArray RealWorld Version
vs SmallMutableArray RealWorld AnyEffect
es SmallMutableArray RealWorld AnyRelinker
fs
      Ref -> IO Ref
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Ref -> IO Ref) -> Ref -> IO Ref
forall a b. (a -> b) -> a -> b
$ Int -> Version -> Ref
Ref Int
size Version
version

-- | Given a reference to an effect from the top of the stack, delete it from
-- the storage.
deleteEffect :: HasCallStack => IORef' Storage -> Ref -> IO ()
deleteEffect :: HasCallStack => IORef' Storage -> Ref -> IO ()
deleteEffect IORef' Storage
storage (Ref Int
ref Version
version) = do
  Storage Int
size Version
currentVersion MutablePrimArray RealWorld Version
vs SmallMutableArray RealWorld AnyEffect
es SmallMutableArray RealWorld AnyRelinker
fs <- IORef' Storage -> IO Storage
forall a. IORef' a -> IO a
readIORef' IORef' Storage
storage
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Int
ref Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"ref (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ref String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") /= size - 1 (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  Version
storageVersion <- MutablePrimArray (PrimState IO) Version -> Int -> IO Version
forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld Version
MutablePrimArray (PrimState IO) Version
vs Int
ref
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Version
version Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
storageVersion) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"version (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Show a => a -> String
show Version
version String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") /= storageVersion ("
         String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Show a => a -> String
show Version
storageVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")\n"
  MutablePrimArray (PrimState IO) Version -> Int -> Version -> IO ()
forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray  MutablePrimArray RealWorld Version
MutablePrimArray (PrimState IO) Version
vs Int
ref Version
undefinedVersion
  SmallMutableArray (PrimState IO) AnyEffect
-> Int -> AnyEffect -> IO ()
forall (m :: Type -> Type) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
writeSmallArray SmallMutableArray RealWorld AnyEffect
SmallMutableArray (PrimState IO) AnyEffect
es Int
ref AnyEffect
HasCallStack => AnyEffect
undefinedEffect
  SmallMutableArray (PrimState IO) AnyRelinker
-> Int -> AnyRelinker -> IO ()
forall (m :: Type -> Type) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
writeSmallArray SmallMutableArray RealWorld AnyRelinker
SmallMutableArray (PrimState IO) AnyRelinker
fs Int
ref AnyRelinker
HasCallStack => AnyRelinker
undefinedRelinker
  IORef' Storage -> Storage -> IO ()
forall a. IORef' a -> a -> IO ()
writeIORef' IORef' Storage
storage (Storage -> IO ()) -> Storage -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
-> Version
-> MutablePrimArray RealWorld Version
-> SmallMutableArray RealWorld AnyEffect
-> SmallMutableArray RealWorld AnyRelinker
-> Storage
Storage (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Version
currentVersion MutablePrimArray RealWorld Version
vs SmallMutableArray RealWorld AnyEffect
es SmallMutableArray RealWorld AnyRelinker
fs

-- | Relink the environment to use the new storage.
relinkEnv :: IORef' Storage -> Env es -> IO (Env es)
relinkEnv :: forall (es :: [Effect]). IORef' Storage -> Env es -> IO (Env es)
relinkEnv IORef' Storage
storage (Env Int
offset PrimArray Ref
refs IORef' Storage
_) = Env es -> IO (Env es)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Env es -> IO (Env es)) -> Env es -> IO (Env es)
forall a b. (a -> b) -> a -> b
$ Int -> PrimArray Ref -> IORef' Storage -> Env es
forall (es :: [Effect]).
Int -> PrimArray Ref -> IORef' Storage -> Env es
Env Int
offset PrimArray Ref
refs IORef' Storage
storage

-- | Double the capacity of an array.
doubleCapacity :: Int -> Int
doubleCapacity :: Int -> Int
doubleCapacity Int
n = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2

undefinedVersion :: Version
undefinedVersion :: Version
undefinedVersion = Int -> Version
Version Int
0

initialVersion :: Version
initialVersion :: Version
initialVersion = Int -> Version
Version Int
1

bumpVersion :: Version -> Version
bumpVersion :: Version -> Version
bumpVersion (Version Int
n) = Int -> Version
Version (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

undefinedEffect :: HasCallStack => AnyEffect
undefinedEffect :: HasCallStack => AnyEffect
undefinedEffect = EffectRep (DispatchOf Any) Any -> AnyEffect
forall (e :: Effect). EffectRep (DispatchOf e) e -> AnyEffect
toAnyEffect (EffectRep (DispatchOf Any) Any -> AnyEffect)
-> (String -> EffectRep (DispatchOf Any) Any)
-> String
-> AnyEffect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EffectRep (DispatchOf Any) Any
forall a. String -> a
errorWithoutStackTrace (String -> AnyEffect) -> String -> AnyEffect
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
  [ String
"Undefined effect"
  , String
"Created at: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack
  ]

undefinedRelinker :: HasCallStack => AnyRelinker
undefinedRelinker :: HasCallStack => AnyRelinker
undefinedRelinker = Relinker (EffectRep (DispatchOf Any)) Any -> AnyRelinker
forall (e :: Effect).
Relinker (EffectRep (DispatchOf e)) e -> AnyRelinker
toAnyRelinker (Relinker (EffectRep (DispatchOf Any)) Any -> AnyRelinker)
-> Relinker (EffectRep (DispatchOf Any)) Any -> AnyRelinker
forall a b. (a -> b) -> a -> b
$ (HasCallStack =>
 (forall (es :: [Effect]). Env es -> IO (Env es))
 -> EffectRep (DispatchOf Any) Any
 -> IO (EffectRep (DispatchOf Any) Any))
-> Relinker (EffectRep (DispatchOf Any)) Any
forall (rep :: Effect -> Type) (e :: Effect).
(HasCallStack =>
 (forall (es :: [Effect]). Env es -> IO (Env es))
 -> rep e -> IO (rep e))
-> Relinker rep e
Relinker ((HasCallStack =>
  (forall (es :: [Effect]). Env es -> IO (Env es))
  -> EffectRep (DispatchOf Any) Any
  -> IO (EffectRep (DispatchOf Any) Any))
 -> Relinker (EffectRep (DispatchOf Any)) Any)
-> (HasCallStack =>
    (forall (es :: [Effect]). Env es -> IO (Env es))
    -> EffectRep (DispatchOf Any) Any
    -> IO (EffectRep (DispatchOf Any) Any))
-> Relinker (EffectRep (DispatchOf Any)) Any
forall a b. (a -> b) -> a -> b
$ \forall (es :: [Effect]). Env es -> IO (Env es)
_ EffectRep (DispatchOf Any) Any
_ -> do
  String -> IO (EffectRep (DispatchOf Any) Any)
forall a. String -> a
errorWithoutStackTrace (String -> IO (EffectRep (DispatchOf Any) Any))
-> String -> IO (EffectRep (DispatchOf Any) Any)
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
    [ String
"Undefined relinker"
    , String
"Created at: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
creationCallStack
    , String
"Called at: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack
    ]
  where
    creationCallStack :: CallStack
creationCallStack = CallStack
HasCallStack => CallStack
callStack

-- | A strict version of 'writeSmallArray'.
writeSmallArray' :: SmallMutableArray RealWorld a -> Int -> a -> IO ()
writeSmallArray' :: forall a. SmallMutableArray RealWorld a -> Int -> a -> IO ()
writeSmallArray' SmallMutableArray RealWorld a
arr Int
i a
a = a
a a -> IO () -> IO ()
forall a b. a -> b -> b
`seq` SmallMutableArray (PrimState IO) a -> Int -> a -> IO ()
forall (m :: Type -> Type) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
writeSmallArray SmallMutableArray RealWorld a
SmallMutableArray (PrimState IO) a
arr Int
i a
a

#if !MIN_VERSION_primitive(0,9,0)
getSizeofSmallMutableArray :: SmallMutableArray RealWorld a -> IO Int
getSizeofSmallMutableArray arr = pure $! sizeofSmallMutableArray arr
#endif