effectful-core 2.2.1.0 → 2.2.2.0

raw patch · 12 files changed

+277/−91 lines, 12 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• README.md +10/−2
• effectful-core.cabal +2/−2
• src/Effectful.hs +2/−0
• src/Effectful/Dispatch/Dynamic.hs +3/−0
• src/Effectful/Internal/Effect.hs +46/−6
• src/Effectful/Internal/Env.hs +43/−32
• src/Effectful/Internal/Monad.hs +61/−5
• src/Effectful/Internal/Unlift.hs +18/−20
• src/Effectful/State/Static/Shared.hs +18/−14
• src/Effectful/Writer/Static/Shared.hs +10/−10
• utils/Effectful/Internal/Utils.hs +59/−0

@@ -1,3 +1,8 @@+# effectful-core-2.2.2.0 (2023-01-11)+* Add `withSeqEffToIO` and `withConcEffToIO` to `Effectful`.+* Use strict `IORef` and `MVar` variants where appropriate.+* Make `inject` work with effect stacks sharing a polymorphic suffix.+ # effectful-core-2.2.1.0 (2022-11-09) * Add `localSeqLift` and `localLift` to `Effectful.Dispatch.Dynamic`. 

@@ -156,14 +156,22 @@   features of the [`unliftio`](https://hackage.haskell.org/package/unliftio)   package divided into appropriate effects. -## Example+## Examples  For the examples see the *Introduction* sections of [`Effectful.Dispatch.Dynamic`](https://hackage.haskell.org/package/effectful-core/docs/Effectful-Dispatch-Dynamic.html) and [`Effectful.Dispatch.Static`](https://hackage.haskell.org/package/effectful-core/docs/Effectful-Dispatch-Static.html). -## Resources+## Acknowledgements++To all contributors of existing effect libraries - thank you for putting the+time and effort to explore the space. In particular, conversations in issue+trackers of `cleff`, `eff`, `freer-simple`, `fused-effects` and `polysemy`+repositories were invaluable in helping me discover and understand challenges in+the space.++### Resources  Resources that inspired the rise of this library and had a lot of impact on its design.

@@ -1,7 +1,7 @@ cabal-version:      2.4 build-type:         Simple name:               effectful-core-version:            2.2.1.0+version:            2.2.2.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.4 || ==9.4.2+tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.5 || ==9.4.4  bug-reports:   https://github.com/haskell-effectful/effectful/issues source-repository head

@@ -45,6 +45,8 @@   , unliftStrategy   , withUnliftStrategy   , withEffToIO+  , withSeqEffToIO+  , withConcEffToIO      -- ** Lifting   , raise

@@ -348,6 +348,9 @@ -- Handling effects  -- | Interpret an effect.+--+-- /Note:/ 'interpret' can be turned into a 'reinterpret' with the use of+-- 'inject'. interpret   :: DispatchOf e ~ Dynamic   => EffectHandler e es

@@ -10,6 +10,8 @@   , (:>)(..)   , (:>>)   , Subset(..)+  , KnownPrefix(..)+  , IsUnknownSuffixOf    -- * Re-exports   , Type@@ -38,8 +40,9 @@   -- /Note:/ GHC is kind enough to cache these values as they're top level CAFs,   -- so the lookup is amortized @O(1)@ without any language level tricks.   reifyIndex :: Int-  reifyIndex = -- Don't show "minimal complete definition" in haddock.-               error "unimplemented"+  reifyIndex =+    -- Don't show "minimal complete definition" in haddock.+    error "reifyIndex"  instance TypeError   ( Text "There is no handler for '" :<>: ShowType e :<>: Text "' in the context"@@ -66,13 +69,50 @@ ----------------------------------------  -- | Provide evidence that @xs@ is a subset of @es@.-class Subset (xs :: [Effect]) (es :: [Effect]) where+class KnownPrefix es => Subset (xs :: [Effect]) (es :: [Effect]) where+  subsetFullyKnown :: Bool+  subsetFullyKnown =+    -- Don't show "minimal complete definition" in haddock.+    error "subsetFullyKnown"+   reifyIndices :: [Int]-  reifyIndices = -- Don't show "minimal complete definition" in haddock.-                 error "unimplemented"+  reifyIndices =+    -- Don't show "minimal complete definition" in haddock.+    error "reifyIndices" -instance Subset '[] es where+-- If the subset is not fully known, make sure the subset and the base stack+-- have the same unknown suffix.+instance {-# INCOHERENT #-}+  ( KnownPrefix es+  , xs `IsUnknownSuffixOf` es+  ) => Subset xs es where+  subsetFullyKnown = False   reifyIndices = [] +-- If the subset is fully known, we're done.+instance KnownPrefix es => Subset '[] es where+  subsetFullyKnown = True+  reifyIndices = []+ instance (e :> es, Subset xs es) => Subset (e : xs) es where+  subsetFullyKnown = subsetFullyKnown @xs @es   reifyIndices = reifyIndex @e @es : reifyIndices @xs @es++----++-- | Calculate length of a statically known prefix of @es@.+class KnownPrefix (es :: [Effect]) where+  prefixLength :: Int++instance KnownPrefix es => KnownPrefix (e : es) where+  prefixLength = 1 + prefixLength @es++instance {-# INCOHERENT #-} KnownPrefix es where+  prefixLength = 0++----++-- | Require that @xs@ is the unknown suffix of @es@.+class (xs :: [Effect]) `IsUnknownSuffixOf` (es :: [Effect])+instance {-# INCOHERENT #-} xs ~ es => xs `IsUnknownSuffixOf` es+instance xs `IsUnknownSuffixOf` es => xs `IsUnknownSuffixOf` (e : es)

@@ -39,7 +39,6 @@  import Control.Monad import Control.Monad.Primitive-import Data.IORef import Data.Primitive.PrimArray import Data.Primitive.SmallArray import GHC.Stack (HasCallStack)@@ -75,7 +74,7 @@ data Env (es :: [Effect]) = Env   { envOffset  :: !Int   , envRefs    :: !(PrimArray Int)-  , envStorage :: !(IORef Storage)+  , envStorage :: !(IORef' Storage)   }  -- | A storage of effects.@@ -128,12 +127,12 @@ emptyEnv :: IO (Env '[]) emptyEnv = Env 0   <$> (unsafeFreezePrimArray =<< newPrimArray 0)-  <*> (newIORef =<< emptyStorage)+  <*> (newIORef' =<< emptyStorage)  -- | Clone the environment to use it in a different thread. cloneEnv :: Env es -> IO (Env es) cloneEnv (Env offset refs storage0) = do-  Storage storageSize version vs0 es0 fs0 <- readIORef storage0+  Storage storageSize version vs0 es0 fs0 <- readIORef' storage0   let vsSize = sizeofMutablePrimArray  vs0       esSize = sizeofSmallMutableArray es0       fsSize = sizeofSmallMutableArray fs0@@ -144,7 +143,7 @@   vs <- cloneMutablePrimArray  vs0 0 vsSize   es <- cloneSmallMutableArray es0 0 esSize   fs <- cloneSmallMutableArray fs0 0 fsSize-  storage <- newIORef $ Storage storageSize version vs es fs+  storage <- newIORef' $ Storage storageSize version vs es fs   let relinkEffects = \case         0 -> pure ()         k -> do@@ -152,7 +151,7 @@           Relinker f <- fromAny <$> readSmallArray fs i           readSmallArray es i             >>= f (relinkEnv storage) . fromAny-            >>= writeSmallArray es i . toAny+            >>= writeSmallArray' es i . toAny           relinkEffects i   relinkEffects storageSize   pure $ Env offset refs storage@@ -166,14 +165,14 @@   -> Env es -- ^ Source.   -> IO () restoreEnv dest src = do-  destStorage <- readIORef (envStorage dest)-  srcStorage  <- readIORef (envStorage src)+  destStorage <- readIORef' (envStorage dest)+  srcStorage  <- readIORef' (envStorage src)   let destStorageSize = stSize destStorage       srcStorageSize  = stSize srcStorage   when (destStorageSize /= srcStorageSize) $ do     error $ "destStorageSize (" ++ show destStorageSize          ++ ") /= srcStorageSize (" ++ show srcStorageSize ++ ")"-  writeIORef (envStorage dest) $! srcStorage+  writeIORef' (envStorage dest) $ srcStorage     -- Decreasing the counter allows leakage of unsafeCoerce (see unsafeCoerce2     -- in the EnvTests module).     { stVersion = max (stVersion destStorage) (stVersion srcStorage)@@ -275,16 +274,24 @@ -- duplicates) of a subset of effects from the input environment. injectEnv :: forall xs es. Subset xs es => Env es -> IO (Env xs) injectEnv (Env offset refs0 storage) = do-  let xs = reifyIndices @xs @es-  mrefs <- newPrimArray (2 * length xs)-  let writeRefs i = \case+  let xs         = reifyIndices @xs @es+      permSize   = 2 * length xs+      prefixSize = 2 * prefixLength @es+      suffixSize = if subsetFullyKnown @xs @es+                   then 0+                   else sizeofPrimArray refs0 - offset - prefixSize+  when (prefixSize == 0 && permSize /= 0) $ do+    error $ "prefixSize == 0, yet permSize == " ++ show permSize+  mrefs <- newPrimArray (permSize + suffixSize)+  copyPrimArray mrefs permSize refs0 (offset + prefixSize) suffixSize+  let writePermRefs i = \case         []       -> pure ()         (e : es) -> do           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+          writePermRefs (i + 2) es+  writePermRefs 0 xs   refs <- unsafeFreezePrimArray mrefs   pure $ Env 0 refs storage {-# NOINLINE injectEnv #-}@@ -309,7 +316,7 @@   -> IO () putEnv env e = do   (i, es) <- getLocation @e env-  e `seq` writeSmallArray es i (toAny e)+  writeSmallArray' es i (toAny e)  -- | Modify the data type in the environment and return a value (in place). stateEnv@@ -320,7 +327,7 @@ stateEnv env f = do   (i, es) <- getLocation @e env   (a, e) <- f . fromAny =<< readSmallArray es i-  e `seq` writeSmallArray es i (toAny e)+  writeSmallArray' es i (toAny e)   pure a  -- | Modify the data type in the environment (in place).@@ -332,7 +339,7 @@ modifyEnv env f = do   (i, es) <- getLocation @e env   e <- f . fromAny =<< readSmallArray es i-  e `seq` writeSmallArray es i (toAny e)+  writeSmallArray' es i (toAny e)  -- | Determine location of the effect in the environment. getLocation@@ -343,7 +350,7 @@   let i       = offset + 2 * reifyIndex @e @es       ref     = indexPrimArray refs  i       version = indexPrimArray refs (i + 1)-  Storage _ _ vs es _ <- readIORef storage+  Storage _ _ vs es _ <- readIORef' storage   storageVersion <- readPrimArray vs 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@@ -365,21 +372,21 @@  -- | Insert an effect into the storage and return its reference. insertEffect-  :: IORef Storage+  :: IORef' Storage   -> EffectRep (DispatchOf e) e   -- ^ The representation of the effect.   -> Relinker (EffectRep (DispatchOf e)) e   -> IO (Int, Int) insertEffect storage e f = do-  Storage size version vs0 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) (version + 1) vs0 es0 fs0+      writePrimArray   vs0 size version+      writeSmallArray' es0 size (toAny e)+      writeSmallArray' fs0 size (toAny f)+      writeIORef' storage $ Storage (size + 1) (version + 1) vs0 es0 fs0       pure (size, version)     EQ -> do       let len = doubleCapacity len0@@ -389,26 +396,26 @@       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) (version + 1) vs es fs+      writePrimArray   vs size version+      writeSmallArray' es size (toAny e)+      writeSmallArray' fs size (toAny f)+      writeIORef' storage $ Storage (size + 1) (version + 1) vs es fs       pure (size, version)  -- | Given a reference to an effect from the top of the stack, delete it from -- the storage.-deleteEffect :: IORef Storage -> Int -> IO ()+deleteEffect :: IORef' Storage -> Int -> IO () deleteEffect storage ref = do-  Storage size version vs 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) version vs 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 :: IORef' Storage -> Env es -> IO (Env es) relinkEnv storage (Env offset refs _) = pure $ Env offset refs storage  -- | Double the capacity of an array.@@ -420,3 +427,7 @@  undefinedData :: HasCallStack => a undefinedData = error "undefined data"++-- | A strict version of 'writeSmallArray'.+writeSmallArray' :: SmallMutableArray RealWorld a -> Int -> a -> IO ()+writeSmallArray' arr i a = a `seq` writeSmallArray arr i a

@@ -35,6 +35,7 @@   , raiseWith   , subsume   , inject+  , Subset    -- * Unlifting   , UnliftStrategy(..)@@ -43,6 +44,8 @@   , unliftStrategy   , withUnliftStrategy   , withEffToIO+  , withSeqEffToIO+  , withConcEffToIO    -- ** Low-level unlifts   , seqUnliftIO@@ -179,10 +182,29 @@   -- ^ Continuation with the unlifting function in scope.   -> Eff es a withEffToIO f = unliftStrategy >>= \case-  SeqUnlift -> unsafeEff $ \es -> seqUnliftIO es f+  SeqUnlift      -> unsafeEff $ \es -> seqUnliftIO es f   ConcUnlift p b -> unsafeEff $ \es -> concUnliftIO es p b f  -- | Create an unlifting function with the 'SeqUnlift' strategy.+withSeqEffToIO+  :: (HasCallStack, IOE :> es)+  => ((forall r. Eff es r -> IO r) -> IO a)+  -- ^ Continuation with the unlifting function in scope.+  -> Eff es a+withSeqEffToIO f = unsafeEff $ \es -> seqUnliftIO es f++-- | Create an unlifting function with the 'ConcUnlift' strategy.+withConcEffToIO+  :: (HasCallStack, IOE :> es)+  => Persistence+  -> Limit+  -> ((forall r. Eff es r -> IO r) -> IO a)+  -- ^ Continuation with the unlifting function in scope.+  -> Eff es a+withConcEffToIO persistence limit f = unsafeEff $ \es ->+  concUnliftIO es persistence limit f++-- | Create an unlifting function with the 'SeqUnlift' strategy. seqUnliftIO   :: HasCallStack   => Env es@@ -381,10 +403,44 @@ -- -- Generalizes 'raise' and 'subsume'. ----- /Note:/ this function should be needed rarely, usually when you have to cross--- API boundaries and monomorphic effect stacks are involved. Using monomorphic--- stacks is discouraged (see 'Eff'), but sometimes might be necessary due to--- external constraints.+-- >>> data E1 :: Effect+-- >>> data E2 :: Effect+-- >>> data E3 :: Effect+--+-- It makes it possible to rearrange the effect stack however you like:+--+-- >>> :{+--   shuffle :: Eff (E3 : E1 : E2 : es) a -> Eff (E1 : E2 : E3 : es) a+--   shuffle = inject+-- :}+--+-- Moreover, it allows for hiding specific effects from downstream:+--+-- >>> :{+--   onlyE1 :: Eff (E1 : es) a -> Eff (E1 : E2 : E3 : es) a+--   onlyE1 = inject+-- :}+--+-- >>> :{+--   onlyE2 :: Eff (E2 : es) a -> Eff (E1 : E2 : E3 : es) a+--   onlyE2 = inject+-- :}+--+-- >>> :{+--   onlyE3 :: Eff (E3 : es) a -> Eff (E1 : E2 : E3 : es) a+--   onlyE3 = inject+-- :}+--+-- However, it's not possible to inject a computation into an incompatible+-- effect stack:+--+-- >>> :{+--   coerceEs :: Eff es1 a -> Eff es2 a+--   coerceEs = inject+-- :}+-- ...+-- ...Couldn't match type ‘es1’ with ‘es2’+-- ... inject :: Subset xs es => Eff xs a -> Eff es a inject m = unsafeEff $ \es -> unEff m =<< injectEnv es 

@@ -144,20 +144,19 @@   -- use. This can't be done from inside the callback as the environment might   -- have already changed by then.   esTemplate <- cloneEnv es0-  mvUses <- newMVar uses+  mvUses <- newMVar' uses   k $ \m -> do     es <- myThreadId >>= \case       tid | tid0 `eqThreadId` tid -> pure es0-      _ -> modifyMVar mvUses $ \case+      _ -> modifyMVar' mvUses $ \case         0 -> error            $ "Number of permitted calls (" ++ show uses ++ ") to the unlifting "           ++ "function in other threads was exceeded. Please increase the limit "           ++ "or use the unlimited variant."         1 -> pure (0, esTemplate)         n -> do-          let newUses = n - 1           es <- cloneEnv esTemplate-          newUses `seq` pure (newUses, es)+          pure (n - 1, es)     unEff m es  -- | Concurrent unlift that preserves the environment between calls to the@@ -179,11 +178,11 @@   -- use. This can't be done from inside the callback as the environment might   -- have already changed by then.   esTemplate <- cloneEnv es0-  mvEntries <- newMVar $ ThreadEntries threads IM.empty+  mvEntries <- newMVar' $ ThreadEntries threads IM.empty   k $ \m -> do     es <- myThreadId >>= \case       tid | tid0 `eqThreadId` tid -> pure es0-      tid -> modifyMVar mvEntries $ \te -> do+      tid -> modifyMVar' mvEntries $ \te -> do         let wkTid = weakThreadId tid         (mes, i) <- case wkTid `IM.lookup` teEntries te of           Just (ThreadEntry i td) -> (, i) <$> lookupEnv tid td@@ -201,7 +200,7 @@                     { teCapacity = teCapacity te - 1                     , teEntries  = addThreadData wkTid i wkTidEs $ teEntries te                     }-              newEntries `seq` pure (newEntries, esTemplate)+              pure (newEntries, esTemplate)             _ -> do               es      <- cloneEnv esTemplate               wkTidEs <- mkWeakThreadIdEnv tid es wkTid i mvEntries cleanUp@@ -209,7 +208,7 @@                     { teCapacity = teCapacity te - 1                     , teEntries  = addThreadData wkTid i wkTidEs $ teEntries te                     }-              newEntries `seq` pure (newEntries, es)+              pure (newEntries, es)     unEff m es  ----------------------------------------@@ -246,7 +245,7 @@   -> Env es   -> Int   -> EntryId-  -> MVar (ThreadEntries es)+  -> MVar' (ThreadEntries es)   -> Bool   -> IO (Weak (ThreadId, Env es)) mkWeakThreadIdEnv t@(ThreadId t#) es wkTid i v = \case@@ -292,17 +291,16 @@  ---------------------------------------- -deleteThreadData :: Int -> EntryId -> MVar (ThreadEntries es) -> IO ()-deleteThreadData wkTid i v = modifyMVar_ v $ \te -> do-  let newEntries = ThreadEntries-        { teCapacity = case teCapacity te of-            -- If the template copy of the environment hasn't been consumed-            -- yet, the capacity can be restored.-            0 -> 0-            n -> n + 1-        , teEntries = IM.update (cleanThreadEntry i) wkTid $ teEntries te-        }-  newEntries `seq` pure newEntries+deleteThreadData :: Int -> EntryId -> MVar' (ThreadEntries es) -> IO ()+deleteThreadData wkTid i v = modifyMVar_' v $ \te -> do+  pure ThreadEntries+    { teCapacity = case teCapacity te of+        -- If the template copy of the environment hasn't been consumed+        -- yet, the capacity can be restored.+        0 -> 0+        n -> n + 1+    , teEntries = IM.update (cleanThreadEntry i) wkTid $ teEntries te+    }  cleanThreadEntry :: EntryId -> ThreadEntry es -> Maybe (ThreadEntry es) cleanThreadEntry i0 (ThreadEntry i td0) = case cleanThreadData i0 td0 of

@@ -50,61 +50,65 @@ import Effectful import Effectful.Dispatch.Static import Effectful.Dispatch.Static.Primitive+import Effectful.Internal.Utils  -- | Provide access to a strict (WHNF), shared, mutable value of type @s@. data State s :: Effect  type instance DispatchOf (State s) = Static NoSideEffects-newtype instance StaticRep (State s) = State (MVar s)+newtype instance StaticRep (State s) = State (MVar' s)  -- | Run the 'State' effect with the given initial state and return the final -- value along with the final state. runState :: s -> Eff (State s : es) a -> Eff es (a, s) runState s m = do-  v <- unsafeEff_ $ newMVar s+  v <- unsafeEff_ $ newMVar' s   a <- evalStaticRep (State v) m-  (a, ) <$> unsafeEff_ (readMVar v)+  (a, ) <$> unsafeEff_ (readMVar' v)  -- | Run the 'State' effect with the given initial state and return the final -- value, discarding the final state. evalState :: s -> Eff (State s : es) a -> Eff es a evalState s m = do-  v <- unsafeEff_ $ newMVar s+  v <- unsafeEff_ $ newMVar' s   evalStaticRep (State v) m  -- | Run the 'State' effect with the given initial state and return the final -- state, discarding the final value. execState :: s -> Eff (State s : es) a -> Eff es s execState s m = do-  v <- unsafeEff_ $ newMVar s+  v <- unsafeEff_ $ newMVar' s   _ <- evalStaticRep (State v) m-  unsafeEff_ $ readMVar v+  unsafeEff_ $ readMVar' v  -- | Run the 'State' effect with the given initial state 'MVar' and return the -- final value along with the final state. runStateMVar :: MVar s -> Eff (State s : es) a -> Eff es (a, s) runStateMVar v m = do-  a <- evalStaticRep (State v) m+  v' <- unsafeEff_ $ toMVar' v+  a <- evalStaticRep (State v') m   (a, ) <$> unsafeEff_ (readMVar v)  -- | Run the 'State' effect with the given initial state 'MVar' and return the -- final value, discarding the final state. evalStateMVar :: MVar s -> Eff (State s : es) a -> Eff es a evalStateMVar v m = do-  evalStaticRep (State v) m+  v' <- unsafeEff_ $ toMVar' v+  evalStaticRep (State v') m  -- | Run the 'State' effect with the given initial state 'MVar' and return the -- final state, discarding the final value. execStateMVar :: MVar s -> Eff (State s : es) a -> Eff es s execStateMVar v m = do-  _ <- evalStaticRep (State v) m+  v' <- unsafeEff_ $ toMVar' v+  _ <- evalStaticRep (State v') m   unsafeEff_ $ readMVar v  -- | Fetch the current value of the state. get :: State s :> es => Eff es s get = unsafeEff $ \es -> do   State v <- getEnv es-  readMVar v+  readMVar' v  -- | Get a function of the current state. --@@ -116,7 +120,7 @@ put :: State s :> es => s -> Eff es () put s = unsafeEff $ \es -> do   State v <- getEnv es-  modifyMVar_ v $ \_ -> s `seq` pure s+  modifyMVar_' v $ \_ -> pure s  -- | Apply the function to the current state and return a value. --@@ -124,7 +128,7 @@ state :: State s :> es => (s -> (a, s)) -> Eff es a state f = unsafeEff $ \es -> do   State v <- getEnv es-  modifyMVar v $ \s0 -> let (a, s) = f s0 in s `seq` pure (s, a)+  modifyMVar' v $ \s0 -> let (a, s) = f s0 in pure (s, a)  -- | Apply the function to the current state. --@@ -140,9 +144,9 @@ stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a stateM f = unsafeEff $ \es -> do   State v <- getEnv es-  modifyMVar v $ \s0 -> do+  modifyMVar' v $ \s0 -> do     (a, s) <- unEff (f s0) es-    s `seq` pure (s, a)+    pure (s, a)  -- | Apply the monadic function to the current state. --

@@ -27,40 +27,40 @@   , listens   ) where -import Control.Concurrent.MVar import Control.Exception (onException, uninterruptibleMask)  import Effectful import Effectful.Dispatch.Static import Effectful.Dispatch.Static.Primitive+import Effectful.Internal.Utils  -- | Provide access to a strict (WHNF), shared, write only value of type @w@. data Writer w :: Effect  type instance DispatchOf (Writer w) = Static NoSideEffects-newtype instance StaticRep (Writer w) = Writer (MVar w)+newtype instance StaticRep (Writer w) = Writer (MVar' w)  -- | Run a 'Writer' effect and return the final value along with the final -- output. runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w) runWriter m = do-  v <- unsafeEff_ $ newMVar mempty+  v <- unsafeEff_ $ newMVar' mempty   a <- evalStaticRep (Writer v) m-  (a, ) <$> unsafeEff_ (readMVar v)+  (a, ) <$> unsafeEff_ (readMVar' v)  -- | Run a 'Writer' effect and return the final output, discarding the final -- value. execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w execWriter m = do-  v <- unsafeEff_ $ newMVar mempty+  v <- unsafeEff_ $ newMVar' mempty   _ <- evalStaticRep (Writer v) m-  unsafeEff_ $ readMVar v+  unsafeEff_ $ readMVar' v  -- | Append the given output to the overall output of the 'Writer'. tell :: (Writer w :> es, Monoid w) => w -> Eff es () tell w1 = unsafeEff $ \es -> do   Writer v <- getEnv es-  modifyMVar_ v $ \w0 -> let w = w0 <> w1 in w `seq` pure w+  modifyMVar_' v $ \w0 -> let w = w0 <> w1 in pure w  -- | Execute an action and append its output to the overall output of the -- 'Writer'.@@ -85,7 +85,7 @@   -- might block and if an async exception is received while waiting, w1 will be   -- lost.   uninterruptibleMask $ \unmask -> do-    v1 <- newMVar mempty+    v1 <- newMVar' mempty     -- Replace thread local MVar with a fresh one for isolated listening.     v0 <- stateEnv es $ \(Writer v) -> pure (v, Writer v1)     a <- unmask (unEff m es) `onException` merge es v0 v1@@ -95,8 +95,8 @@     -- exception was received while listening, merge results recorded so far.     merge es v0 v1 = do       putEnv es $ Writer v0-      w1 <- readMVar v1-      modifyMVar_ v0 $ \w0 -> let w = w0 <> w1 in w `seq` pure w+      w1 <- readMVar' v1+      modifyMVar_' v0 $ \w0 -> let w = w0 <> w1 in pure w       pure w1  -- | Execute an action and append its output to the overall output of the

@@ -6,12 +6,28 @@   ( weakThreadId   , eqThreadId +  -- * Strict 'IORef'+  , IORef'+  , newIORef'+  , readIORef'+  , writeIORef'++  -- * Strict 'MVar'+  , MVar'+  , toMVar'+  , newMVar'+  , readMVar'+  , modifyMVar'+  , modifyMVar_'+   -- * Utils for 'Any'   , Any   , toAny   , fromAny   ) where +import Control.Concurrent.MVar+import Data.IORef import Foreign.C.Types import GHC.Conc.Sync (ThreadId(..)) import GHC.Exts (Any, ThreadId#)@@ -39,6 +55,49 @@  foreign import ccall unsafe "effectful_eq_thread"   eq_thread :: ThreadId# -> ThreadId# -> CLong++----------------------------------------++-- | A strict variant of 'IORef'.+newtype IORef' a = IORef' (IORef a)++newIORef' :: a -> IO (IORef' a)+newIORef' a = a `seq` (IORef' <$> newIORef a)++readIORef' :: IORef' a -> IO a+readIORef' (IORef' var) = readIORef var++writeIORef' :: IORef' a -> a -> IO ()+writeIORef' (IORef' var) a = a `seq` writeIORef var a++----------------------------------------++-- | A strict variant of 'MVar'.+newtype MVar' a = MVar' (MVar a)++toMVar' :: MVar a -> IO (MVar' a)+toMVar' var = do+  let var' = MVar' var+  modifyMVar_' var' pure+  pure var'++newMVar' :: a -> IO (MVar' a)+newMVar' a = a `seq` (MVar' <$> newMVar a)++readMVar' :: MVar' a -> IO a+readMVar' (MVar' var) = readMVar var++modifyMVar' :: MVar' a -> (a -> IO (a, r)) -> IO r+modifyMVar' (MVar' var) action = modifyMVar var $ \a0 -> do+  (a, r) <- action a0+  a `seq` pure (a, r)+{-# INLINE modifyMVar' #-}++modifyMVar_' :: MVar' a -> (a -> IO a) -> IO ()+modifyMVar_' (MVar' var) action = modifyMVar_ var $ \a0 -> do+  a <- action a0+  a `seq` pure a+{-# INLINE modifyMVar_' #-}  ----------------------------------------