effectful-core 2.2.2.1 → 2.2.2.2

raw patch · 6 files changed

+142/−83 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• effectful-core.cabal +4/−3
• src/Effectful/Dispatch/Dynamic.hs +35/−33
• src/Effectful/Internal/Env.hs +0/−2
• src/Effectful/Internal/Monad.hs +36/−18
• src/Effectful/Internal/Utils.hs +61/−27

@@ -1,3 +1,9 @@+# effectful-core-2.2.2.2 (2023-03-13)+* Allow `inject` to turn a monomorphic effect stack into a polymorphic one.+* Use C sources only with GHC < 9.+* Force inlining of `bracket` early to work around excessive inlining problem+  with GHC 9.6 (https://gitlab.haskell.org/ghc/ghc/-/issues/22824).+ # effectful-core-2.2.2.1 (2023-01-12) * Stop using the internal library because of bugs in `stack`. 

@@ -1,7 +1,7 @@ cabal-version:      2.4 build-type:         Simple name:               effectful-core-version:            2.2.2.1+version:            2.2.2.2 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.5 || ==9.4.4+tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.4 || ==9.6.1  bug-reports:   https://github.com/haskell-effectful/effectful/issues source-repository head@@ -69,7 +69,8 @@      hs-source-dirs:  src -    c-sources:       cbits/utils.c+    if impl(ghc < 9)+      c-sources:     cbits/utils.c      exposed-modules: Effectful                      Effectful.Dispatch.Dynamic

@@ -49,7 +49,6 @@   , HasCallStack   ) where -import Control.Exception (bracket) import Control.Monad.IO.Unlift import GHC.Stack (HasCallStack) import GHC.TypeLits@@ -57,6 +56,7 @@ import Effectful.Internal.Effect import Effectful.Internal.Env import Effectful.Internal.Monad+import Effectful.Internal.Utils  -- $intro --@@ -410,21 +410,22 @@   -> Eff es a   -> Eff es a 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-          )+  inlineBracket+    (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.@@ -439,23 +440,24 @@   -> Eff es a   -> Eff es b 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-          )+  inlineBracket+    (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

@@ -280,8 +280,6 @@       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

@@ -1,5 +1,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-noncanonical-monad-instances #-}+{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_HADDOCK not-home #-} -- | The 'Eff' monad. --@@ -101,6 +102,7 @@ import Effectful.Internal.Effect import Effectful.Internal.Env import Effectful.Internal.Unlift+import Effectful.Internal.Utils  type role Eff nominal representational @@ -186,6 +188,8 @@   ConcUnlift p b -> unsafeEff $ \es -> concUnliftIO es p b f  -- | Create an unlifting function with the 'SeqUnlift' strategy.+--+-- @since 2.2.2.0 withSeqEffToIO   :: (HasCallStack, IOE :> es)   => ((forall r. Eff es r -> IO r) -> IO a)@@ -194,6 +198,8 @@ withSeqEffToIO f = unsafeEff $ \es -> seqUnliftIO es f  -- | Create an unlifting function with the 'ConcUnlift' strategy.+--+-- @since 2.2.2.0 withConcEffToIO   :: (HasCallStack, IOE :> es)   => Persistence@@ -262,12 +268,12 @@  type instance DispatchOf NonDet = Dynamic --- | @since: 2.2.0.0+-- | @since 2.2.0.0 instance NonDet :> es => Alternative (Eff es) where   empty   = withFrozenCallStack (send Empty)   a <|> b = send (a :<|>: b) --- | @since: 2.2.0.0+-- | @since 2.2.0.0 instance NonDet :> es => MonadPlus (Eff es)  ----------------------------------------@@ -414,6 +420,13 @@ --   shuffle = inject -- :} --+-- It can also turn a monomorphic effect stack into a polymorphic one:+--+-- >>> :{+--   toPoly :: (E1 :> es, E2 :> es, E3 :> es) => Eff [E1, E2, E3] a -> Eff es a+--   toPoly = inject+-- :}+-- -- Moreover, it allows for hiding specific effects from downstream: -- -- >>> :{@@ -471,7 +484,7 @@ -- | An internal representation of dynamically dispatched effects, i.e. the -- effect handler bundled with its environment. data Handler :: Effect -> Type where-  Handler :: !(Env es) -> !(EffectHandler e es) -> Handler e+  Handler :: !(Env handlerEs) -> !(EffectHandler e handlerEs) -> Handler e type instance EffectRep Dynamic = Handler  relinkHandler :: Relinker Handler e@@ -482,9 +495,10 @@ -- | Run a dynamically dispatched effect with the given handler. runHandler :: DispatchOf e ~ Dynamic => Handler e -> Eff (e : es) a -> Eff es a runHandler e m = unsafeEff $ \es0 -> do-  E.bracket (consEnv e relinkHandler es0)-            unconsEnv-            (\es -> unEff m es)+  inlineBracket+    (consEnv e relinkHandler es0)+    unconsEnv+    (\es -> unEff m es)  -- | Send an operation of the given effect to its handler for execution. send@@ -518,9 +532,10 @@   -> Eff (e : es) a   -> Eff es (a, StaticRep e) runStaticRep e0 m = unsafeEff $ \es0 -> do-  E.bracket (consEnv e0 dummyRelinker es0)-            unconsEnv-            (\es -> (,) <$> unEff m es <*> getEnv es)+  inlineBracket+    (consEnv e0 dummyRelinker es0)+    unconsEnv+    (\es -> (,) <$> unEff m es <*> getEnv es)  -- | Run a statically dispatched effect with the given initial representation -- and return the final value, discarding the final representation.@@ -530,9 +545,10 @@   -> Eff (e : es) a   -> Eff es a evalStaticRep e m = unsafeEff $ \es0 -> do-  E.bracket (consEnv e dummyRelinker es0)-            unconsEnv-            (\es -> unEff m es)+  inlineBracket+    (consEnv e dummyRelinker es0)+    unconsEnv+    (\es -> unEff m es)  -- | Run a statically dispatched effect with the given initial representation -- and return the final representation, discarding the final value.@@ -542,9 +558,10 @@   -> Eff (e : es) a   -> Eff es (StaticRep e) execStaticRep e0 m = unsafeEff $ \es0 -> do-  E.bracket (consEnv e0 dummyRelinker es0)-            unconsEnv-            (\es -> unEff m es *> getEnv es)+  inlineBracket+    (consEnv e0 dummyRelinker es0)+    unconsEnv+    (\es -> unEff m es *> getEnv es)  -- | Fetch the current representation of the effect. getStaticRep :: (DispatchOf e ~ Static sideEffects, e :> es) => Eff es (StaticRep e)@@ -582,6 +599,7 @@   -> Eff es a   -> Eff es a localStaticRep f m = unsafeEff $ \es -> do-  E.bracket (stateEnv es $ \s -> pure (s, f s))-            (\s -> putEnv es s)-            (\_ -> unEff m es)+  inlineBracket+    (stateEnv es $ \s -> pure (s, f s))+    (\s -> putEnv es s)+    (\_ -> unEff m es)

@@ -3,36 +3,57 @@ {-# LANGUAGE UnliftedFFITypes #-} {-# OPTIONS_HADDOCK not-home #-} module Effectful.Internal.Utils-  ( weakThreadId+  ( inlineBracket++    -- * Utils for 'ThreadId'+  , weakThreadId   , eqThreadId -  -- * Strict 'IORef'+    -- * Utils for 'Any'+  , Any+  , toAny+  , fromAny++    -- * Strict 'IORef'   , IORef'   , newIORef'   , readIORef'   , writeIORef' -  -- * Strict 'MVar'+    -- * Strict 'MVar'   , MVar'   , toMVar'   , newMVar'   , readMVar'   , modifyMVar'   , modifyMVar_'--  -- * Utils for 'Any'-  , Any-  , toAny-  , fromAny   ) where  import Control.Concurrent.MVar+import Control.Exception import Data.IORef-import Foreign.C.Types import GHC.Conc.Sync (ThreadId(..)) import GHC.Exts (Addr#, Any, ThreadId#, unsafeCoerce#) import Unsafe.Coerce (unsafeCoerce) +#if __GLASGOW_HASKELL__ >= 904+import Data.Word+#else+import Foreign.C.Types+#endif++-- | Version of bracket with an INLINE pragma to work around+-- https://gitlab.haskell.org/ghc/ghc/-/issues/22824.+inlineBracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c+inlineBracket before after action = mask $ \unmask -> do+  a <- before+  r <- unmask (action a) `onException` after a+  _ <- after a+  pure r+{-# INLINE inlineBracket #-}++----------------------------------------+ -- | Get an id of a thread that doesn't prevent its garbage collection. weakThreadId :: ThreadId -> Int weakThreadId (ThreadId t#) = fromIntegral $ rts_getThreadId (threadIdToAddr# t#)@@ -40,7 +61,7 @@ foreign import ccall unsafe "rts_getThreadId" #if __GLASGOW_HASKELL__ >= 904   -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6163-  rts_getThreadId :: Addr# -> CULLong+  rts_getThreadId :: Addr# -> Word64 #elif __GLASGOW_HASKELL__ >= 900   -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1254   rts_getThreadId :: Addr# -> CLong@@ -48,15 +69,6 @@   rts_getThreadId :: Addr# -> CInt #endif --- | 'Eq' instance for 'ThreadId' is broken in GHC < 9, see--- https://gitlab.haskell.org/ghc/ghc/-/issues/16761 for more info.-eqThreadId :: ThreadId -> ThreadId -> Bool-eqThreadId (ThreadId t1#) (ThreadId t2#) =-  eq_thread (threadIdToAddr# t1#) (threadIdToAddr# t2#) == 1--foreign import ccall unsafe "effectful_eq_thread"-  eq_thread :: Addr# -> Addr# -> CLong- -- Note: FFI imports take Addr# instead of ThreadId# because of -- https://gitlab.haskell.org/ghc/ghc/-/issues/8281, which would prevent loading -- effectful-core into GHCi.@@ -70,8 +82,37 @@  ---------------------------------------- +#if __GLASGOW_HASKELL__ < 900++-- | 'Eq' instance for 'ThreadId' is broken in GHC < 9, see+-- https://gitlab.haskell.org/ghc/ghc/-/issues/16761 for more info.+eqThreadId :: ThreadId -> ThreadId -> Bool+eqThreadId (ThreadId t1#) (ThreadId t2#) =+  eq_thread (threadIdToAddr# t1#) (threadIdToAddr# t2#) == 1++foreign import ccall unsafe "effectful_eq_thread"+  eq_thread :: Addr# -> Addr# -> CLong++#else++eqThreadId :: ThreadId -> ThreadId -> Bool+eqThreadId = (==)++#endif++----------------------------------------++toAny :: a -> Any+toAny = unsafeCoerce++fromAny :: Any -> a+fromAny = unsafeCoerce++----------------------------------------+ -- | A strict variant of 'IORef'. newtype IORef' a = IORef' (IORef a)+  deriving Eq  newIORef' :: a -> IO (IORef' a) newIORef' a = a `seq` (IORef' <$> newIORef a)@@ -86,6 +127,7 @@  -- | A strict variant of 'MVar'. newtype MVar' a = MVar' (MVar a)+  deriving Eq  toMVar' :: MVar a -> IO (MVar' a) toMVar' var = do@@ -110,11 +152,3 @@   a <- action a0   a `seq` pure a {-# INLINE modifyMVar_' #-}--------------------------------------------toAny :: a -> Any-toAny = unsafeCoerce--fromAny :: Any -> a-fromAny = unsafeCoerce