effectful-core 2.3.0.0 → 2.3.0.1

raw patch · 7 files changed

+61/−19 lines, 7 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +3/−0
• effectful-core.cabal +2/−2
• src/Effectful/Dispatch/Dynamic.hs +16/−7
• src/Effectful/Dispatch/Static.hs +1/−1
• src/Effectful/Internal/Env.hs +10/−4
• src/Effectful/Internal/Monad.hs +8/−4
• src/Effectful/Internal/Utils.hs +21/−1

@@ -1,3 +1,6 @@+# effectful-core-2.3.0.1 (2023-11-13)+* Prevent internal functions from appending calls stack frames to handlers.+ # effectful-core-2.3.0.0 (2023-09-13) * Deprecate `withConcEffToIO`. * Make `withEffToIO` take an explicit unlifting strategy for the sake of

@@ -1,7 +1,7 @@ cabal-version:      2.4 build-type:         Simple name:               effectful-core-version:            2.3.0.0+version:            2.3.0.1 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.8 || ==9.4.7 || ==9.6.2+tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.7 || ==9.6.3               || ==9.8.1  bug-reports:   https://github.com/haskell-effectful/effectful/issues

@@ -1,3 +1,4 @@+{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE UndecidableInstances #-} -- | Dynamically dispatched effects. module Effectful.Dispatch.Dynamic@@ -357,7 +358,7 @@ -- >>> :set -XFunctionalDependencies -- -- >>> :{---   class Monad m => MonadInput i m | i -> m where+--   class Monad m => MonadInput i m | m -> i where --     input :: m i -- :} --@@ -371,7 +372,7 @@ -- ... -- ...Illegal instance declaration for ‘MonadInput i (Eff es)’... -- ...  The liberal coverage condition fails in class ‘MonadInput’...--- ...    for functional dependency: ‘i -> m’...+-- ...    for functional dependency: ‘m -> i’... -- ... -- -- However, there exists a [dirty@@ -407,7 +408,9 @@   -> Eff (e : es) a   -> Eff      es  a interpret handler m = unsafeEff $ \es -> do-  (`unEff` es) $ runHandler (Handler es handler) m+  (`unEff` es) $ runHandler (mkHandler es) m+  where+    mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler)  -- | Interpret an effect using other, private effects. --@@ -422,7 +425,9 @@   -> Eff      es  b reinterpret runHandlerEs handler m = unsafeEff $ \es -> do   (`unEff` es) . runHandlerEs . unsafeEff $ \handlerEs -> do-    (`unEff` es) $ runHandler (Handler handlerEs handler) m+    (`unEff` es) $ runHandler (mkHandler handlerEs) m+  where+    mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler)  -- | Replace the handler of an existing effect with a new one. --@@ -472,9 +477,11 @@     (\newEs -> do         -- Replace the original handler with a new one. Note that 'newEs'         -- will still see the original handler.-        putEnv es (Handler newEs handler)+        putEnv es $ mkHandler newEs         unEff m es     )+  where+    mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler)  -- | Replace the handler of an existing effect with a new one that uses other, -- private effects.@@ -504,9 +511,11 @@           -- 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)+          putEnv es $ mkHandler handlerEs           unEff m es     )+  where+    mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler)  ---------------------------------------- -- Unlifts@@ -760,7 +769,7 @@ --      localSeqUnlift env $ \unlift -> unlift m -- :} -- ...--- ...Could not deduce (SharedSuffix '[] es)...+-- ...Could not deduce ...SharedSuffix '[] es... -- ... -- -- Running local actions in a monomorphic effect stack is also not fine as

@@ -130,7 +130,7 @@ --  runLog logger = evalStaticRep (Log logger) -- :} -- ...--- ...No instance for (IOE :> es) arising from a use of ‘evalStaticRep’+-- ...No instance for ...IOE :> es... arising from a use of ‘evalStaticRep’ -- ... -- -- Including @'IOE' :> es@ in the context fixes the problem:

@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK not-home #-} module Effectful.Internal.Env   ( -- * The environment@@ -133,9 +134,9 @@ cloneEnv :: Env es -> IO (Env es) cloneEnv (Env offset refs storage0) = do   Storage storageSize version vs0 es0 fs0 <- readIORef' storage0-  let vsSize = sizeofMutablePrimArray  vs0-      esSize = sizeofSmallMutableArray es0-      fsSize = sizeofSmallMutableArray fs0+  vsSize <- getSizeofMutablePrimArray  vs0+  esSize <- getSizeofSmallMutableArray es0+  fsSize <- getSizeofSmallMutableArray fs0   when (vsSize /= esSize) $ do     error $ "vsSize (" ++ show vsSize ++ ") /= esSize (" ++ show esSize ++ ")"   when (esSize /= fsSize) $ do@@ -377,7 +378,7 @@   -> IO (Int, Int) insertEffect storage e f = do   Storage size version vs0 es0 fs0 <- readIORef' storage-  let len0 = sizeofSmallMutableArray es0+  len0 <- getSizeofSmallMutableArray es0   case size `compare` len0 of     GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"     LT -> do@@ -429,3 +430,8 @@ -- | A strict version of 'writeSmallArray'. writeSmallArray' :: SmallMutableArray RealWorld a -> Int -> a -> IO () writeSmallArray' arr i a = a `seq` writeSmallArray arr i a++#if !MIN_VERSION_primitive(0,9,0)+getSizeofSmallMutableArray :: SmallMutableArray RealWorld a -> IO Int+getSizeofSmallMutableArray arr = pure $! sizeofSmallMutableArray arr+#endif

@@ -508,9 +508,9 @@ type instance EffectRep Dynamic = Handler  relinkHandler :: Relinker Handler e-relinkHandler = Relinker $ \relink (Handler handlerEs handle) -> do+relinkHandler = Relinker $ \relink (Handler handlerEs handler) -> do   newHandlerEs <- relink handlerEs-  pure $ Handler newHandlerEs handle+  pure $ Handler newHandlerEs handler  -- | Run a dynamically dispatched effect with the given handler. runHandler :: DispatchOf e ~ Dynamic => Handler e -> Eff (e : es) a -> Eff es a@@ -527,8 +527,12 @@   -- ^ The operation.   -> Eff es a send op = unsafeEff $ \es -> do-  Handler handlerEs handle <- getEnv es-  unEff (handle (LocalEnv es) op) handlerEs+  Handler handlerEs handler <- getEnv es+  -- Prevent internal functions that rebind the effect handler from polluting+  -- its call stack by freezing it. Note that functions 'interpret',+  -- 'reinterpret', 'interpose' and 'impose' need to thaw it so that useful+  -- stack frames from inside the effect handler continue to be added.+  unEff (withFrozenCallStack handler (LocalEnv es) op) handlerEs {-# NOINLINE send #-}  ----------------------------------------

@@ -31,6 +31,9 @@     -- * Unique   , Unique   , newUnique++  -- * CallStack+  , thawCallStack   ) where  import Control.Concurrent.MVar@@ -38,14 +41,20 @@ import Data.IORef import Data.Primitive.ByteArray import GHC.Conc.Sync (ThreadId(..))-import GHC.Exts (Addr#, Any, RealWorld, ThreadId#, unsafeCoerce#)+import GHC.Exts (Any, RealWorld)+import GHC.Stack.Types (CallStack(..)) import Unsafe.Coerce (unsafeCoerce) +#if MIN_VERSION_base(4,19,0)+import GHC.Conc.Sync (fromThreadId)+#else+import GHC.Exts (Addr#, ThreadId#, unsafeCoerce#) #if __GLASGOW_HASKELL__ >= 904 import Data.Word #else import Foreign.C.Types #endif+#endif  -- | Version of bracket with an INLINE pragma to work around -- https://gitlab.haskell.org/ghc/ghc/-/issues/22824.@@ -61,6 +70,9 @@  -- | Get an id of a thread that doesn't prevent its garbage collection. weakThreadId :: ThreadId -> Int+#if MIN_VERSION_base(4,19,0)+weakThreadId = fromIntegral . fromThreadId+#else weakThreadId (ThreadId t#) = fromIntegral $ rts_getThreadId (threadIdToAddr# t#)  foreign import ccall unsafe "rts_getThreadId"@@ -84,6 +96,7 @@ -- The coercion is fine because GHC represents ThreadId# as a pointer. threadIdToAddr# :: ThreadId# -> Addr# threadIdToAddr# = unsafeCoerce#+#endif  ---------------------------------------- @@ -168,3 +181,10 @@  newUnique :: IO Unique newUnique = Unique <$> newByteArray 0++----------------------------------------++thawCallStack :: CallStack -> CallStack+thawCallStack = \case+  FreezeCallStack cs -> thawCallStack cs+  cs -> cs