effectful-core 1.2.0.0 → 2.0.0.0
raw patch · 13 files changed
+174/−212 lines, 13 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Effectful.Dispatch.Static.Primitive: checkSizeEnv :: Env es -> IO ()
- Effectful.Dispatch.Static.Primitive: forkEnv :: Env es -> IO (Env es)
- Effectful.Internal.Env: References :: !Int -> !MutablePrimArray RealWorld Int -> References
- Effectful.Internal.Env: [envSize] :: Env (es :: [Effect]) -> !Int
- Effectful.Internal.Env: [refIndices] :: References -> !MutablePrimArray RealWorld Int
- Effectful.Internal.Env: [refSize] :: References -> !Int
- Effectful.Internal.Env: checkSizeEnv :: Env es -> IO ()
- Effectful.Internal.Env: data References
- Effectful.Internal.Env: forkEnv :: Env es -> IO (Env es)
- Effectful.Internal.Env: unsubsumeEnv :: e :> es => Env (e : es) -> IO ()
+ Effectful.Internal.Env: [envOffset] :: Env (es :: [Effect]) -> !Int
+ Effectful.Internal.Env: [stVersion] :: Storage -> !Int
+ Effectful.Internal.Env: [stVersions] :: Storage -> !MutablePrimArray RealWorld Int
- Effectful.Dispatch.Static.Primitive: modifyEnv :: forall e es. e :> es => Env es -> (EffectRep (DispatchOf e) e -> EffectRep (DispatchOf e) e) -> IO ()
+ Effectful.Dispatch.Static.Primitive: modifyEnv :: forall e es. e :> es => Env es -> (EffectRep (DispatchOf e) e -> IO (EffectRep (DispatchOf e) e)) -> IO ()
- Effectful.Dispatch.Static.Primitive: stateEnv :: forall e es a. e :> es => Env es -> (EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e)) -> IO a
+ Effectful.Dispatch.Static.Primitive: stateEnv :: forall e es a. e :> es => Env es -> (EffectRep (DispatchOf e) e -> IO (a, EffectRep (DispatchOf e) e)) -> IO a
- Effectful.Internal.Env: Env :: !Int -> !IORef References -> !IORef Storage -> Env (es :: [Effect])
+ Effectful.Internal.Env: Env :: !Int -> !PrimArray Int -> !IORef Storage -> Env (es :: [Effect])
- Effectful.Internal.Env: Storage :: !Int -> !SmallMutableArray RealWorld Any -> !SmallMutableArray RealWorld Any -> Storage
+ Effectful.Internal.Env: Storage :: !Int -> !Int -> !MutablePrimArray RealWorld Int -> !SmallMutableArray RealWorld Any -> !SmallMutableArray RealWorld Any -> Storage
- Effectful.Internal.Env: [envRefs] :: Env (es :: [Effect]) -> !IORef References
+ Effectful.Internal.Env: [envRefs] :: Env (es :: [Effect]) -> !PrimArray Int
- Effectful.Internal.Env: modifyEnv :: forall e es. e :> es => Env es -> (EffectRep (DispatchOf e) e -> EffectRep (DispatchOf e) e) -> IO ()
+ Effectful.Internal.Env: modifyEnv :: forall e es. e :> es => Env es -> (EffectRep (DispatchOf e) e -> IO (EffectRep (DispatchOf e) e)) -> IO ()
- Effectful.Internal.Env: stateEnv :: forall e es a. e :> es => Env es -> (EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e)) -> IO a
+ Effectful.Internal.Env: stateEnv :: forall e es a. e :> es => Env es -> (EffectRep (DispatchOf e) e -> IO (a, EffectRep (DispatchOf e) e)) -> IO a
- Effectful.Internal.Monad: modifyEnv :: forall e es. e :> es => Env es -> (EffectRep (DispatchOf e) e -> EffectRep (DispatchOf e) e) -> IO ()
+ Effectful.Internal.Monad: modifyEnv :: forall e es. e :> es => Env es -> (EffectRep (DispatchOf e) e -> IO (EffectRep (DispatchOf e) e)) -> IO ()
- Effectful.Internal.Monad: stateEnv :: forall e es a. e :> es => Env es -> (EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e)) -> IO a
+ Effectful.Internal.Monad: stateEnv :: forall e es a. e :> es => Env es -> (EffectRep (DispatchOf e) e -> IO (a, EffectRep (DispatchOf e) e)) -> IO a
Files
- CHANGELOG.md +7/−0
- effectful-core.cabal +2/−2
- src/Effectful/Dispatch/Dynamic.hs +38/−16
- src/Effectful/Dispatch/Static/Primitive.hs +0/−2
- src/Effectful/Error/Static.hs +0/−1
- src/Effectful/Internal/Env.hs +111/−173
- src/Effectful/Internal/Monad.hs +6/−11
- src/Effectful/Internal/Unlift.hs +2/−3
- src/Effectful/Reader/Dynamic.hs +2/−0
- src/Effectful/Reader/Static.hs +2/−0
- src/Effectful/Writer/Static/Local.hs +2/−2
- src/Effectful/Writer/Static/Shared.hs +1/−1
- utils/Effectful/Internal/Utils.hs +1/−1
CHANGELOG.md view
@@ -1,3 +1,10 @@+# effectful-core-2.0.0.0 (2022-08-12)+* Make storage references in the environment immutable.+* Remove `checkSizeEnv` and `forkEnv` from+ `Effectful.Dispatch.Static.Primitive`.+* Add internal versioning of effects to prevent leakage of `unsafeCoerce`.+* Make `interpose` and `impose` properly interact with other handlers.+ # effectful-core-1.2.0.0 (2022-07-28) * Change `SuffixOf` to `SharedSuffix` and make it behave as advertised. * Add `raiseWith`.
effectful-core.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 build-type: Simple name: effectful-core-version: 1.2.0.0+version: 2.0.0.0 license: BSD-3-Clause license-file: LICENSE category: Control@@ -21,7 +21,7 @@ CHANGELOG.md README.md -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.3 || ==9.4.1+tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.1 bug-reports: https://github.com/haskell-effectful/effectful/issues source-repository head
src/Effectful/Dispatch/Dynamic.hs view
@@ -353,8 +353,7 @@ -> Eff (e : es) a -> Eff es a interpret handler m = unsafeEff $ \es -> do- les <- forkEnv es- (`unEff` es) $ runHandler (Handler les handler) m+ (`unEff` es) $ runHandler (Handler es handler) m -- | Interpret an effect using other, private effects. --@@ -368,9 +367,8 @@ -> Eff (e : es) a -> Eff es b reinterpret runHandlerEs handler m = unsafeEff $ \es -> do- les0 <- forkEnv es- (`unEff` les0) . runHandlerEs . unsafeEff $ \les -> do- (`unEff` es) $ runHandler (Handler les handler) m+ (`unEff` es) . runHandlerEs . unsafeEff $ \handlerEs -> do+ (`unEff` es) $ runHandler (Handler handlerEs handler) m -- | Replace the handler of an existing effect with a new one. --@@ -406,11 +404,22 @@ -- ^ The effect handler. -> Eff es a -> Eff es a-interpose handler m = unsafeEff $ \es0 -> do- les <- forkEnv es0- bracket (replaceEnv (Handler les handler) relinkHandler es0)- (unreplaceEnv @e)- (\es -> unEff m es)+interpose handler m = unsafeEff $ \es -> do+ bracket (do+ origHandler <- getEnv @e es+ replaceEnv origHandler relinkHandler es+ )+ (\newEs -> do+ -- Restore the original handler.+ putEnv es =<< getEnv @e newEs+ unreplaceEnv @e newEs+ )+ (\newEs -> do+ -- Replace the original handler with a new one. Note that 'newEs'+ -- will still see the original handler.+ putEnv es (Handler newEs handler)+ unEff m es+ ) -- | Replace the handler of an existing effect with a new one that uses other, -- private effects.@@ -424,12 +433,24 @@ -- ^ The effect handler. -> Eff es a -> Eff es b-impose runHandlerEs handler m = unsafeEff $ \es0 -> do- les0 <- forkEnv es0- (`unEff` les0) . runHandlerEs . unsafeEff $ \les -> do- bracket (replaceEnv (Handler les handler) relinkHandler es0)- (unreplaceEnv @e)- (\es -> unEff m es)+impose runHandlerEs handler m = unsafeEff $ \es -> do+ bracket (do+ origHandler <- getEnv @e es+ replaceEnv origHandler relinkHandler es+ )+ (\newEs -> do+ -- Restore the original handler.+ putEnv es =<< getEnv @e newEs+ unreplaceEnv @e newEs+ )+ (\newEs -> do+ (`unEff` newEs) . runHandlerEs . unsafeEff $ \handlerEs -> do+ -- Replace the original handler with a new one. Note that+ -- 'newEs' (and thus 'handlerEs') wil still see the original+ -- handler.+ putEnv es (Handler handlerEs handler)+ unEff m es+ ) ---------------------------------------- -- Unlifts@@ -658,6 +679,7 @@ -- ...Running local actions in monomorphic effect stacks is not supported... -- ... --+-- @since 1.2.0.0 class SharedSuffix (es1 :: [Effect]) (es2 :: [Effect]) instance {-# INCOHERENT #-} SharedSuffix es es
src/Effectful/Dispatch/Static/Primitive.hs view
@@ -31,9 +31,7 @@ -- ** Utils , emptyEnv , cloneEnv- , forkEnv , sizeEnv- , checkSizeEnv , tailEnv ) where
src/Effectful/Error/Static.hs view
@@ -156,7 +156,6 @@ catchError m handler = unsafeEff $ \es -> do Error eid <- getEnv @(Error e) es catchErrorIO eid (unEff m es) $ \cs e -> do- checkSizeEnv es unEff (handler cs e) es -- | The same as @'flip' 'catchError'@, which is useful in situations where the
src/Effectful/Internal/Env.hs view
@@ -3,7 +3,6 @@ module Effectful.Internal.Env ( -- * The environment Env(..)- , References(..) , Storage(..) -- ** Relinker@@ -19,9 +18,7 @@ -- * Operations , emptyEnv , cloneEnv- , forkEnv , sizeEnv- , checkSizeEnv , tailEnv -- ** Modification of the effect stack@@ -30,7 +27,6 @@ , replaceEnv , unreplaceEnv , subsumeEnv- , unsubsumeEnv , injectEnv -- ** Data retrieval and update@@ -55,9 +51,6 @@ -- | A strict (WHNF), __thread local__, mutable, extensible record indexed by types -- of kind 'Effect'. ----- Supports forking, i.e. introduction of local branches for encapsulation of--- effects specific to effect handlers.--- -- __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@@ -66,7 +59,7 @@ -- Offers very good performance characteristics for most often performed -- operations: ----- - Extending: /@O(1)@/ (amortized).+-- - Extending: /@O(n)@/, where @n@ is the size of the effect stack. -- -- - Shrinking: /@O(1)@/. --@@ -74,29 +67,21 @@ -- -- - Modification of a specific element: /@O(1)@/. ----- - Forking: /@O(n)@/, where @n@ is the size of the effect stack.+-- - Getting a tail: /@O(1)@/. ----- - Cloning: /@O(N + Σ(n_i))@/, where @N@ is the size of the 'Storage', while--- @i@ ranges over handlers of dynamically dispatched effects in the 'Storage'--- and @n_i@ is the size of the effect stack of @i@-th handler.+-- - Cloning: /@O(N)@/, where @N@ is the size of the 'Storage'. -- data Env (es :: [Effect]) = Env- { envSize :: !Int- , envRefs :: !(IORef References)+ { envOffset :: !Int+ , envRefs :: !(PrimArray Int) , envStorage :: !(IORef Storage) } --- | An array of references to effects in the 'Storage'.-data References = References- { refSize :: !Int- , refIndices :: !(MutablePrimArray RealWorld Int)- }- -- | A storage of effects.------ Shared between all forks of the environment within the same thread. data Storage = Storage { stSize :: !Int+ , stVersion :: !Int+ , stVersions :: !(MutablePrimArray RealWorld Int) , stEffects :: !(SmallMutableArray RealWorld Any) , stRelinkers :: !(SmallMutableArray RealWorld Any) }@@ -140,25 +125,25 @@ -- | Create an empty environment. emptyEnv :: IO (Env '[])-emptyEnv = Env <$> pure 0- <*> (newIORef . References 0 =<< newPrimArray 0)+emptyEnv = Env 0+ <$> (unsafeFreezePrimArray =<< newPrimArray 0) <*> (newIORef =<< emptyStorage) -- | Clone the environment to use it in a different thread. cloneEnv :: Env es -> IO (Env es)-cloneEnv (Env size mrefs0 storage0) = do- References n refs0 <- readIORef mrefs0- errorWhenDifferent size n- mrefs <- newIORef . References n- =<< cloneMutablePrimArray refs0 0 (sizeofMutablePrimArray refs0)- Storage storageSize es0 fs0 <- readIORef storage0- let esSize = sizeofSmallMutableArray es0+cloneEnv (Env offset refs storage0) = do+ Storage storageSize version vs0 es0 fs0 <- readIORef storage0+ let vsSize = sizeofMutablePrimArray vs0+ esSize = sizeofSmallMutableArray es0 fsSize = sizeofSmallMutableArray fs0+ when (vsSize /= esSize) $ do+ error $ "vsSize (" ++ show vsSize ++ ") /= esSize (" ++ show esSize ++ ")" when (esSize /= fsSize) $ do error $ "esSize (" ++ show esSize ++ ") /= fsSize (" ++ show fsSize ++ ")"+ vs <- cloneMutablePrimArray vs0 0 vsSize es <- cloneSmallMutableArray es0 0 esSize- fs <- cloneSmallMutableArray fs0 0 esSize- storage <- newIORef $ Storage storageSize es fs+ fs <- cloneSmallMutableArray fs0 0 fsSize+ storage <- newIORef $ Storage storageSize version vs es fs let relinkEffects = \case 0 -> pure () k -> do@@ -169,83 +154,55 @@ >>= writeSmallArray es i . toAny relinkEffects i relinkEffects storageSize- pure $ Env size mrefs storage+ pure $ Env offset refs storage {-# NOINLINE cloneEnv #-} --- | Create a fork of the environment.------ Forked environment can be updated independently of the original one within--- the same thread.-forkEnv :: Env es -> IO (Env es)-forkEnv (Env size mrefs0 storage) = do- References n refs0 <- readIORef mrefs0- errorWhenDifferent size n- mrefs <- newIORef . References size- =<< cloneMutablePrimArray refs0 0 (sizeofMutablePrimArray refs0)- pure $ Env size mrefs storage-{-# NOINLINE forkEnv #-}---- | Check that the size of the environment is internally consistent.-checkSizeEnv :: Env es -> IO ()-checkSizeEnv (Env size mrefs _) = do- References n _ <- readIORef mrefs- errorWhenDifferent size n-{-# NOINLINE checkSizeEnv #-}- -- | Get the current size of the environment. sizeEnv :: Env es -> IO Int-sizeEnv env = pure $ envSize env+sizeEnv (Env offset refs _) = do+ pure $ (sizeofPrimArray refs - offset) `div` 2 -- | Access the tail of the environment. tailEnv :: Env (e : es) -> IO (Env es)-tailEnv (Env size mrefs0 storage) = do- References n refs0 <- readIORef mrefs0- errorWhenDifferent size n- mrefs <- newIORef . References (size - 1)- =<< cloneMutablePrimArray refs0 0 (sizeofMutablePrimArray refs0)- pure $ Env (size - 1) mrefs storage-{-# NOINLINE tailEnv #-}+tailEnv (Env offset refs storage) = do+ pure $ Env (offset + 2) refs storage ---------------------------------------- -- Extending and shrinking --- | Extend the environment with a new data type (in place).+-- | Extend the environment with a new data type. consEnv :: EffectRep (DispatchOf e) e -- ^ The representation of the effect. -> Relinker (EffectRep (DispatchOf e)) e -> Env es -> IO (Env (e : es))-consEnv e f (Env size mrefs storage) = do- References n refs0 <- readIORef mrefs- errorWhenDifferent size n- len0 <- getSizeofMutablePrimArray refs0- refs <- case size `compare` len0 of- GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"- LT -> pure refs0- EQ -> resizeMutablePrimArray refs0 (doubleCapacity len0)- ref <- insertEffect storage e f- writePrimArray refs size ref- writeIORef mrefs $! References (size + 1) refs- pure $ Env (size + 1) mrefs storage+consEnv e f (Env offset refs0 storage) = do+ let size = sizeofPrimArray refs0 - offset+ mrefs <- newPrimArray (size + 2)+ copyPrimArray mrefs 2 refs0 offset size+ (ref, version) <- insertEffect storage e f+ writePrimArray mrefs 0 ref+ writePrimArray mrefs 1 version+ refs <- unsafeFreezePrimArray mrefs+ pure $ Env 0 refs storage {-# NOINLINE consEnv #-} --- | Shrink the environment by one data type (in place).+-- | Shrink the environment by one data type. -- -- /Note:/ after calling this function the input environment is no longer -- usable. unconsEnv :: Env (e : es) -> IO ()-unconsEnv (Env size mrefs storage) = do- References n refs <- readIORef mrefs- errorWhenDifferent size n- ref <- readPrimArray refs (size - 1)- deleteEffect storage ref- writeIORef mrefs $! References (size - 1) refs+unconsEnv (Env _ refs storage) = do+ deleteEffect storage (indexPrimArray refs 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. e :> es => EffectRep (DispatchOf e) e@@ -253,17 +210,16 @@ -> Relinker (EffectRep (DispatchOf e)) e -> Env es -> IO (Env es)-replaceEnv e f (Env size mrefs0 storage) = do- References n refs0 <- readIORef mrefs0- errorWhenDifferent size n- len0 <- getSizeofMutablePrimArray refs0- when (size > len0) $ do- error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"- refs <- cloneMutablePrimArray refs0 0 len0- ref <- insertEffect storage e f- writePrimArray refs (mkIndex (reifyIndex @e @es) size) ref- mrefs <- newIORef $ References n refs- pure $ Env size mrefs storage+replaceEnv e f (Env offset refs0 storage) = do+ let size = sizeofPrimArray refs0 - offset+ mrefs <- newPrimArray size+ copyPrimArray mrefs 0 refs0 offset size+ (ref, version) <- insertEffect storage e f+ let i = 2 * reifyIndex @e @es+ writePrimArray mrefs i ref+ writePrimArray mrefs (i + 1) version+ refs <- unsafeFreezePrimArray mrefs+ pure $ Env 0 refs storage {-# NOINLINE replaceEnv #-} -- | Remove a reference to the replaced effect.@@ -271,59 +227,43 @@ -- /Note:/ after calling this function the input environment is no longer -- usable. unreplaceEnv :: forall e es. e :> es => Env es -> IO ()-unreplaceEnv (Env size mrefs storage) = do- References n refs <- readIORef mrefs- errorWhenDifferent size n- ref <- readPrimArray refs $ mkIndex (reifyIndex @e @es) size- deleteEffect storage ref+unreplaceEnv (Env offset refs storage) = do+ deleteEffect storage $ indexPrimArray refs (offset + 2 * reifyIndex @e @es) {-# NOINLINE unreplaceEnv #-} ---------------------------------------- --- | Reference an existing effect from the top of the stack (in place).+-- | Reference an existing effect from the top of the stack. subsumeEnv :: forall e es. e :> es => Env es -> IO (Env (e : es))-subsumeEnv (Env size mrefs storage) = do- References n refs0 <- readIORef mrefs- errorWhenDifferent size n- len0 <- getSizeofMutablePrimArray refs0- refs <- case size `compare` len0 of- GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"- LT -> pure refs0- EQ -> resizeMutablePrimArray refs0 (doubleCapacity len0)- ref <- readPrimArray refs $ mkIndex (reifyIndex @e @es) size- writePrimArray refs size ref- writeIORef mrefs $! References (size + 1) refs- pure $ Env (size + 1) mrefs storage+subsumeEnv (Env offset refs0 storage) = do+ let size = sizeofPrimArray refs0 - offset+ mrefs <- newPrimArray (size + 2)+ copyPrimArray mrefs 2 refs0 offset size+ let ix = offset + 2 * reifyIndex @e @es+ writePrimArray mrefs 0 $ indexPrimArray refs0 ix+ writePrimArray mrefs 1 $ indexPrimArray refs0 (ix + 1)+ refs <- unsafeFreezePrimArray mrefs+ pure $ Env 0 refs storage {-# NOINLINE subsumeEnv #-} --- | Remove a reference to an existing effect from the top of the stack.------ /Note:/ after calling this function the input environment is no longer--- usable.-unsubsumeEnv :: e :> es => Env (e : es) -> IO ()-unsubsumeEnv (Env size mrefs _) = do- References n refs <- readIORef mrefs- errorWhenDifferent size n- writeIORef mrefs $! References (size - 1) refs-{-# NOINLINE unsubsumeEnv #-}- ---------------------------------------- -- | Construct an environment containing a permutation (with possible -- duplicates) of a subset of effects from the input environment. injectEnv :: forall xs es. Subset xs es => Env es -> IO (Env xs)-injectEnv (Env size0 mrefs0 storage) = do- References n0 refs0 <- readIORef mrefs0- errorWhenDifferent size0 n0- let makeRefs k acc = \case- [] -> unsafeThawPrimArray $ primArrayFromListN k acc+injectEnv (Env offset refs0 storage) = do+ let xs = reifyIndices @xs @es+ mrefs <- newPrimArray (2 * length xs)+ let writeRefs i = \case+ [] -> pure () (e : es) -> do- i <- readPrimArray refs0 $ mkIndex e size0- makeRefs (k + 1) (i : acc) es- refs <- makeRefs 0 [] (reifyIndices @xs @es)- size <- getSizeofMutablePrimArray refs- mrefs <- newIORef $ References size refs- pure $ Env size mrefs storage+ let ix = offset + 2 * e+ writePrimArray mrefs i $ indexPrimArray refs0 ix+ writePrimArray mrefs (i + 1) $ indexPrimArray refs0 (ix + 1)+ writeRefs (i + 2) es+ writeRefs 0 xs+ refs <- unsafeFreezePrimArray mrefs+ pure $ Env 0 refs storage {-# NOINLINE injectEnv #-} ----------------------------------------@@ -348,15 +288,15 @@ (i, es) <- getLocation @e env e `seq` writeSmallArray es i (toAny e) --- | Modify the data type in the environment (in place) and return a value.+-- | Modify the data type in the environment and return a value (in place). stateEnv :: forall e es a. e :> es => Env es -- ^ The environment.- -> (EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e))+ -> (EffectRep (DispatchOf e) e -> IO (a, EffectRep (DispatchOf e) e)) -> IO a stateEnv env f = do (i, es) <- getLocation @e env- (a, e) <- f . fromAny <$> readSmallArray es i+ (a, e) <- f . fromAny =<< readSmallArray es i e `seq` writeSmallArray es i (toAny e) pure a @@ -364,11 +304,11 @@ modifyEnv :: forall e es. e :> es => Env es -- ^ The environment.- -> (EffectRep (DispatchOf e) e -> EffectRep (DispatchOf e) e)+ -> (EffectRep (DispatchOf e) e -> IO (EffectRep (DispatchOf e) e)) -> IO () modifyEnv env f = do (i, es) <- getLocation @e env- e <- f . fromAny <$> readSmallArray es i+ e <- f . fromAny =<< readSmallArray es i e `seq` writeSmallArray es i (toAny e) -- | Determine location of the effect in the environment.@@ -376,23 +316,27 @@ :: forall e es. e :> es => Env es -> IO (Int, SmallMutableArray RealWorld Any)-getLocation (Env size mrefs storage) = do- refs <- refIndices <$> readIORef mrefs- i <- readPrimArray refs $ mkIndex (reifyIndex @e @es) size- es <- stEffects <$> readIORef storage+getLocation (Env offset refs storage) = do+ let ix = offset + 2 * reifyIndex @e @es+ i = indexPrimArray refs ix+ Storage _ _ vs es _ <- readIORef storage+ let version = indexPrimArray refs (ix + 1)+ storageVersion <- readPrimArray vs i+ -- 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.+ when (version /= storageVersion) $ do+ error $ "version (" ++ show version ++ ") /= storageVersion ("+ ++ show storageVersion ++ ")" pure (i, es) --- | Get the index of a reference to an effect.-mkIndex :: Int -> Int -> Int-mkIndex ix size = size - ix - 1- ---------------------------------------- -- Internal helpers -- | Create an empty storage. emptyStorage :: IO Storage-emptyStorage = Storage- <$> pure 0+emptyStorage = Storage 0 (noVersion + 1)+ <$> newPrimArray 0 <*> newSmallArray 0 undefinedData <*> newSmallArray 0 undefinedData @@ -402,60 +346,54 @@ -> EffectRep (DispatchOf e) e -- ^ The representation of the effect. -> Relinker (EffectRep (DispatchOf e)) e- -> IO Int+ -> IO (Int, Int) insertEffect storage e f = do- Storage size es0 fs0 <- readIORef storage+ Storage size version vs0 es0 fs0 <- readIORef storage let len0 = sizeofSmallMutableArray es0 case size `compare` len0 of GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")" LT -> do+ writePrimArray vs0 size version e `seq` writeSmallArray es0 size (toAny e) f `seq` writeSmallArray fs0 size (toAny f)- writeIORef storage $! Storage (size + 1) es0 fs0- pure size+ writeIORef storage $! Storage (size + 1) (version + 1) vs0 es0 fs0+ pure (size, version) EQ -> do let len = doubleCapacity len0+ vs <- newPrimArray len es <- newSmallArray len undefinedData fs <- newSmallArray len undefinedData+ copyMutablePrimArray vs 0 vs0 0 size copySmallMutableArray es 0 es0 0 size copySmallMutableArray fs 0 fs0 0 size+ writePrimArray vs size version e `seq` writeSmallArray es size (toAny e) f `seq` writeSmallArray fs size (toAny f)- writeIORef storage $! Storage (size + 1) es fs- pure size+ writeIORef storage $! Storage (size + 1) (version + 1) vs es fs+ pure (size, version) --- | Given a reference to an effect, delete it from the storage.------ /Note:/ the reference needs to point to the end of the storage. Normally it's--- not a problem as it turns out effects are put and taken from the storage in--- the same order across all forks, unless someone tries to do something--- unexpected.+-- | Given a reference to an effect from the top of the stack, delete it from+-- the storage. deleteEffect :: IORef Storage -> Int -> IO () deleteEffect storage ref = do- Storage size es fs <- readIORef storage+ Storage size version vs es fs <- readIORef storage when (ref /= size - 1) $ do error $ "ref (" ++ show ref ++ ") /= size - 1 (" ++ show (size - 1) ++ ")"+ writePrimArray vs ref noVersion writeSmallArray es ref undefinedData writeSmallArray fs ref undefinedData- writeIORef storage $! Storage (size - 1) es fs+ writeIORef storage $! Storage (size - 1) version vs es fs -- | Relink the environment to use the new storage. relinkEnv :: IORef Storage -> Env es -> IO (Env es)-relinkEnv storage (Env size mrefs0 _) = do- References n refs0 <- readIORef mrefs0- mrefs <- newIORef . References n- =<< cloneMutablePrimArray refs0 0 (sizeofMutablePrimArray refs0)- pure $ Env size mrefs storage---- | Throw an error if array sizes do not agree.-errorWhenDifferent :: HasCallStack => Int -> Int -> IO ()-errorWhenDifferent size n- | size /= n = error $ "size (" ++ show size ++ ") /= n (" ++ show n ++ ")"- | otherwise = pure ()+relinkEnv storage (Env offset refs _) = pure $ Env offset refs storage -- | Double the capacity of an array. doubleCapacity :: Int -> Int doubleCapacity n = max 1 n * 2++noVersion :: Int+noVersion = 0 undefinedData :: HasCallStack => a undefinedData = error "undefined data"
src/Effectful/Internal/Monad.hs view
@@ -230,7 +230,6 @@ instance C.MonadCatch (Eff es) where catch m handler = unsafeEff $ \es -> do unEff m es `E.catch` \e -> do- checkSizeEnv es unEff (handler e) es instance C.MonadMask (Eff es) where@@ -243,7 +242,6 @@ generalBracket acquire release use = unsafeEff $ \es -> E.mask $ \unmask -> do resource <- unEff acquire es b <- unmask (unEff (use resource) es) `E.catch` \e -> do- checkSizeEnv es _ <- unEff (release resource $ C.ExitCaseException e) es E.throwIO e c <- unEff (release resource $ C.ExitCaseSuccess b) es@@ -325,6 +323,8 @@ -- | Lift an 'Eff' computation into an effect stack with one more effect and -- create an unlifting function with the given strategy.+--+-- @since 1.2.0.0 raiseWith :: HasCallStack => UnliftStrategy@@ -343,10 +343,7 @@ -- | Eliminate a duplicate effect from the top of the effect stack. subsume :: e :> es => Eff (e : es) a -> Eff es a-subsume m = unsafeEff $ \es0 -> do- E.bracket (subsumeEnv es0)- unsubsumeEnv- (\es -> unEff m es)+subsume m = unsafeEff $ \es -> unEff m =<< subsumeEnv es -- | Allow for running an effect stack @xs@ within @es@ as long as @xs@ is a -- permutation (with possible duplicates) of a subset of @es@.@@ -477,7 +474,7 @@ => (StaticRep e -> (a, StaticRep e)) -- ^ The function to modify the representation. -> Eff es a-stateStaticRep f = unsafeEff $ \es -> stateEnv es f+stateStaticRep f = unsafeEff $ \es -> stateEnv es (pure . f) -- | Apply the monadic function to the current representation of the effect and -- return a value.@@ -487,9 +484,7 @@ -- ^ The function to modify the representation. -> Eff es a stateStaticRepM f = unsafeEff $ \es -> E.mask $ \unmask -> do- (a, s) <- (\s0 -> unmask $ unEff (f s0) es) =<< getEnv es- putEnv es s- pure a+ stateEnv es $ unmask . (`unEff` es) . f -- | Execute a computation with a temporarily modified representation of the -- effect.@@ -500,6 +495,6 @@ -> Eff es a -> Eff es a localStaticRep f m = unsafeEff $ \es -> do- E.bracket (stateEnv es $ \s -> (s, f s))+ E.bracket (stateEnv es $ \s -> pure (s, f s)) (\s -> putEnv es s) (\_ -> unEff m es)
src/Effectful/Internal/Unlift.hs view
@@ -39,9 +39,8 @@ -- 'Effectful.withEffToIO', 'Effectful.withRunInIO' or the -- 'Effectful.Dispatch.Dynamic.localUnlift' family. ----- /Warning:/ unlifting functions should not be used outside of continuations--- that brought them into scope. While this currently works just fine, there are--- no guarantees it will continue doing so in the future.+-- /Note:/ unlifting functions should not be used outside of continuations that+-- brought them into scope. data UnliftStrategy = SeqUnlift -- ^ The fastest strategy and a default setting for t'Effectful.IOE'. An
src/Effectful/Reader/Dynamic.hs view
@@ -38,6 +38,8 @@ Local f m -> localSeqUnlift env $ \unlift -> R.local f (unlift m) -- | Execute a computation in a modified environment.+--+-- @since 1.1.0.0 withReader :: (r1 -> r2) -- ^ The function to modify the environment.
src/Effectful/Reader/Static.hs view
@@ -31,6 +31,8 @@ runReader r = evalStaticRep (Reader r) -- | Execute a computation in a modified environment.+--+-- @since 1.1.0.0 withReader :: (r1 -> r2) -- ^ The function to modify the environment.
src/Effectful/Writer/Static/Local.hs view
@@ -77,13 +77,13 @@ -- "Hi there!" listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w) listen m = unsafeEff $ \es -> mask $ \unmask -> do- w0 <- stateEnv es $ \(Writer w) -> (w, Writer mempty)+ w0 <- stateEnv es $ \(Writer w) -> pure (w, Writer mempty) a <- unmask (unEff m es) `onException` merge es w0 (a, ) <$> merge es w0 where merge es w0 = -- If an exception is thrown, restore w0 and keep parts of w1.- stateEnv es $ \(Writer w1) -> (w1, Writer (w0 <> w1))+ stateEnv es $ \(Writer w1) -> pure (w1, Writer (w0 <> w1)) -- | Execute an action and append its output to the overall output of the -- 'Writer', then return the final value along with a function of the recorded
@@ -87,7 +87,7 @@ uninterruptibleMask $ \unmask -> do v1 <- newMVar mempty -- Replace thread local MVar with a fresh one for isolated listening.- v0 <- stateEnv es $ \(Writer v) -> (v, Writer v1)+ v0 <- stateEnv es $ \(Writer v) -> pure (v, Writer v1) a <- unmask (unEff m es) `onException` merge es v0 v1 (a, ) <$> merge es v0 v1 where
utils/Effectful/Internal/Utils.hs view
@@ -22,7 +22,7 @@ weakThreadId (ThreadId t#) = fromIntegral $ rts_getThreadId t# foreign import ccall unsafe "rts_getThreadId"-#if __GLASGOW_HASKELL__ >= 903+#if __GLASGOW_HASKELL__ >= 904 -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6163 rts_getThreadId :: ThreadId# -> CULLong #elif __GLASGOW_HASKELL__ >= 900