diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,39 @@ +# effectful-core-2.4.0.0 (2024-10-08) +* Add utility functions for handling effects that take the effect handler as the + last parameter to `Effectful.Dispatch.Dynamic`. +* Add utility functions for handling first order effects to + `Effectful.Dispatch.Dynamic`. +* Improve `Effectful.Labeled`, add `Effectful.Labeled.Error`, + `Effectful.Labeled.Reader`, `Effectful.Labeled.State` and + `Effectful.Labeled.Writer`. +* Add `throwErrorWith` and `throwError_` to `Effectful.Error.Static` and + `Effectful.Error.Dynamic`. +* Add `HasCallStack` constraints where appropriate for better debugging + experience. +* Add a `SeqForkUnlift` strategy to support running unlifting functions outside + of the scope of effects they capture. +* Add `Effectful.Exception` with appropriate re-exports from the + `safe-exceptions` library. +* **Bugfixes**: + - Ensure that a `LocalEnv` is only used in a thread it belongs to. + - Properly roll back changes made to the environment when `OnEmptyRollback` + policy for the `NonDet` effect is selected. + - Fix a bug in `stateM` and `modifyM` of thread local `State` effect that + might've caused dropped state updates + ([#237](https://github.com/haskell-effectful/effectful/issues/237)). +* **Breaking changes**: + - `localSeqLend`, `localLend`, `localSeqBorrow` and `localBorrow` now take a + list of effects instead of a single one. + - `Effectful.Error.Static.throwError` now requires the error type to have a + `Show` constraint. If this is not the case for some of your error types, use + `throwError_` for them. + - `ThrowError` operation from the dynamic version of the `Error` effect was + replaced with `ThrowErrorWith`. + - `stateEnv` and `modifyEnv` now take pure modification functions. If you rely + on their old forms, switch to a combination of `getEnv` and `putEnv`. + - `runStateMVar`, `evalStateMVar` and `execStateMVar` now take a strict + `MVar'` from the `strict-mutable-base` package. + # effectful-core-2.3.1.0 (2024-06-07) * Drop support for GHC 8.8. * Remove inaccurate information from the `Show` instance of `ErrorWrapper`. diff --git a/effectful-core.cabal b/effectful-core.cabal --- a/effectful-core.cabal +++ b/effectful-core.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: effectful-core -version: 2.3.1.0 +version: 2.4.0.0 license: BSD-3-Clause license-file: LICENSE category: Control @@ -29,7 +29,10 @@ location: https://github.com/haskell-effectful/effectful.git common language - ghc-options: -Wall -Wcompat -Wno-unticked-promoted-constructors + ghc-options: -Wall + -Wcompat + -Wno-unticked-promoted-constructors + -Wmissing-deriving-strategies -Werror=prepositive-qualified-module default-language: Haskell2010 @@ -39,6 +42,7 @@ DataKinds DeriveFunctor DeriveGeneric + DerivingStrategies FlexibleContexts FlexibleInstances GADTs @@ -47,6 +51,7 @@ LambdaCase MultiParamTypeClasses NoStarIsType + PolyKinds RankNTypes RoleAnnotations ScopedTypeVariables @@ -63,9 +68,12 @@ build-depends: base >= 4.14 && < 5 , containers >= 0.6 + , deepseq >= 1.2 , exceptions >= 0.10.4 , monad-control >= 1.0.3 , primitive >= 0.7.3.0 + , safe-exceptions >= 0.1.7.2 + , strict-mutable-base >= 1.1.0.0 , transformers-base >= 0.4.6 , unliftio-core >= 0.2.0.1 @@ -81,6 +89,7 @@ Effectful.Dispatch.Static.Unsafe Effectful.Error.Dynamic Effectful.Error.Static + Effectful.Exception Effectful.Fail Effectful.Internal.Effect Effectful.Internal.Env @@ -88,6 +97,10 @@ Effectful.Internal.Unlift Effectful.Internal.Utils Effectful.Labeled + Effectful.Labeled.Error + Effectful.Labeled.Reader + Effectful.Labeled.State + Effectful.Labeled.Writer Effectful.NonDet Effectful.Prim Effectful.Provider diff --git a/src/Effectful.hs b/src/Effectful.hs --- a/src/Effectful.hs +++ b/src/Effectful.hs @@ -148,7 +148,7 @@ -- -- These libraries can trivially be used with the 'Eff' monad since it provides -- typical instances that these libraries require the underlying monad to have, --- such as t'Control.Monad.Catch.MonadMask' or 'MonadUnliftIO'. +-- such as t'Effectful.Exception.MonadMask' or 'MonadUnliftIO'. -- -- In case the 'Eff' monad doesn't provide a specific instance out of the box, -- it can be supplied via an effect. As an example see how the instance of @@ -199,8 +199,8 @@ -- -- As an example, consider the following monad: -- --- >>> import qualified Control.Monad.State as T --- >>> import qualified Control.Monad.Except as T +-- >>> import Control.Monad.State qualified as T +-- >>> import Control.Monad.Except qualified as T -- -- >>> data HandlerState -- >>> data HandlerError diff --git a/src/Effectful/Dispatch/Dynamic.hs b/src/Effectful/Dispatch/Dynamic.hs --- a/src/Effectful/Dispatch/Dynamic.hs +++ b/src/Effectful/Dispatch/Dynamic.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE UndecidableInstances #-} -- | Dynamically dispatched effects. @@ -23,9 +24,13 @@ -- * Handling effects , EffectHandler , interpret + , interpretWith , reinterpret + , reinterpretWith , interpose + , interposeWith , impose + , imposeWith -- ** Handling local 'Eff' computations , LocalEnv @@ -52,13 +57,23 @@ , localSeqBorrow , localBorrow , SharedSuffix + , KnownSubset + -- ** Utils for first order effects + , EffectHandler_ + , interpret_ + , interpretWith_ + , reinterpret_ + , reinterpretWith_ + , interpose_ + , interposeWith_ + , impose_ + , imposeWith_ + -- * Re-exports , HasCallStack ) where -import Control.Monad -import Control.Monad.IO.Unlift import Data.Primitive.PrimArray import GHC.Stack (HasCallStack) import GHC.TypeLits @@ -138,11 +153,9 @@ -- The following defines an 'EffectHandler' that reads and writes files from the -- drive: -- --- >>> import Control.Exception (IOException) --- >>> import Control.Monad.Catch (catch) --- >>> import qualified System.IO as IO --- -- >>> import Effectful.Error.Static +-- >>> import Effectful.Exception +-- >>> import System.IO qualified as IO -- -- >>> newtype FsError = FsError String deriving Show -- @@ -155,7 +168,7 @@ -- ReadFile path -> adapt $ IO.readFile path -- WriteFile path contents -> adapt $ IO.writeFile path contents -- where --- adapt m = liftIO m `catch` \(e::IOException) -> throwError . FsError $ show e +-- adapt m = liftIO m `catchIO` \e -> throwError . FsError $ show e -- :} -- -- Here, we use 'interpret' and simply execute corresponding 'IO' actions for @@ -164,8 +177,7 @@ -- On the other hand, maybe there is a situation in which instead of interacting -- with the outside world, a pure, in-memory storage is preferred: -- --- >>> import qualified Data.Map.Strict as M --- +-- >>> import Data.Map.Strict qualified as M -- >>> import Effectful.State.Static.Local -- -- >>> :{ @@ -212,6 +224,9 @@ -- -- If an effect makes use of the @m@ parameter, it is a /higher order effect/. -- +-- /Note:/ for handling first order effects you can use 'interpret_' or +-- 'reinterpret_' whose 'EffectHandler_' doesn't take the 'LocalEnv' parameter. +-- -- Interpretation of higher order effects is slightly more involving. To see -- why, let's consider the @Profiling@ effect for logging how much time a -- specific action took to run: @@ -343,7 +358,7 @@ -- -- >>> :{ -- runDummyRNG :: Eff (RNG : es) a -> Eff es a --- runDummyRNG = interpret $ \_ -> \case +-- runDummyRNG = interpret_ $ \case -- RandomInt -> pure 55 -- :} -- @@ -381,9 +396,8 @@ -- ... for functional dependency: ‘m -> i’... -- ... -- --- However, there exists a [dirty --- trick](https://www.youtube.com/watch?v=ZXtdd8e7CQQ) for bypassing the --- coverage condition, i.e. including the instance head in the context: +-- However, there exists a trick for bypassing the coverage condition, +-- i.e. including the instance head in its context: -- -- >>> :{ -- instance (MonadInput i (Eff es), Reader i :> es) => MonadInput i (Eff es) where @@ -408,7 +422,7 @@ -- /Note:/ 'interpret' can be turned into a 'reinterpret' with the use of -- 'inject'. interpret - :: DispatchOf e ~ Dynamic + :: (HasCallStack, DispatchOf e ~ Dynamic) => EffectHandler e es -- ^ The effect handler. -> Eff (e : es) a @@ -418,11 +432,22 @@ where mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler) +-- | 'interpret' with the effect handler as the last argument. +-- +-- @since 2.4.0.0 +interpretWith + :: (HasCallStack, DispatchOf e ~ Dynamic) + => Eff (e : es) a + -> EffectHandler e es + -- ^ The effect handler. + -> Eff es a +interpretWith m handler = interpret handler m + -- | Interpret an effect using other, private effects. -- -- @'interpret' ≡ 'reinterpret' 'id'@ reinterpret - :: DispatchOf e ~ Dynamic + :: (HasCallStack, DispatchOf e ~ Dynamic) => (Eff handlerEs a -> Eff es b) -- ^ Introduction of effects encapsulated within the handler. -> EffectHandler e handlerEs @@ -435,6 +460,19 @@ where mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler) +-- | 'reinterpret' with the effect handler as the last argument. +-- +-- @since 2.4.0.0 +reinterpretWith + :: (HasCallStack, DispatchOf e ~ Dynamic) + => (Eff handlerEs a -> Eff es b) + -- ^ Introduction of effects encapsulated within the handler. + -> Eff (e : es) a + -> EffectHandler e handlerEs + -- ^ The effect handler. + -> Eff es b +reinterpretWith runHandlerEs m handler = reinterpret runHandlerEs handler m + -- | Replace the handler of an existing effect with a new one. -- -- /Note:/ this function allows for augmenting handlers with a new functionality @@ -442,29 +480,70 @@ -- -- >>> :{ -- data E :: Effect where --- Op :: E m () +-- Op1 :: E m () +-- Op2 :: E m () -- type instance DispatchOf E = Dynamic -- :} -- -- >>> :{ -- runE :: IOE :> es => Eff (E : es) a -> Eff es a --- runE = interpret $ \_ Op -> liftIO (putStrLn "op") +-- runE = interpret_ $ \case +-- Op1 -> liftIO (putStrLn "op1") +-- Op2 -> liftIO (putStrLn "op2") -- :} -- --- >>> runEff . runE $ send Op --- op +-- >>> runEff . runE $ send Op1 >> send Op2 +-- op1 +-- op2 -- -- >>> :{ --- augmentE :: (E :> es, IOE :> es) => Eff es a -> Eff es a --- augmentE = interpose $ \_ Op -> liftIO (putStrLn "augmented op") >> send Op +-- augmentOp2 :: (E :> es, IOE :> es) => Eff es a -> Eff es a +-- augmentOp2 = interpose_ $ \case +-- Op1 -> send Op1 +-- Op2 -> liftIO (putStrLn "augmented op2") >> send Op2 -- :} -- --- >>> runEff . runE . augmentE $ send Op --- augmented op --- op +-- >>> runEff . runE . augmentOp2 $ send Op1 >> send Op2 +-- op1 +-- augmented op2 +-- op2 -- +-- /Note:/ when using 'interpose' to modify only specific operations of the +-- effect, your first instinct might be to match on them, then handle the rest +-- with a generic match. Unfortunately, this doesn't work out of the box: +-- +-- >>> :{ +-- genericAugmentOp2 :: (E :> es, IOE :> es) => Eff es a -> Eff es a +-- genericAugmentOp2 = interpose_ $ \case +-- Op2 -> liftIO (putStrLn "augmented op2") >> send Op2 +-- op -> send op +-- :} +-- ... +-- ...Couldn't match type ‘localEs’ with ‘es’ +-- ... +-- +-- This is because within the generic match, 'send' expects @Op (Eff es) a@, but +-- @op@ has a type @Op (Eff localEs) a@. If the effect in question is first +-- order (i.e. its @m@ type parameter is phantom), you can use 'coerce': +-- +-- >>> import Data.Coerce +-- >>> :{ +-- genericAugmentOp2 :: (E :> es, IOE :> es) => Eff es a -> Eff es a +-- genericAugmentOp2 = interpose_ $ \case +-- Op2 -> liftIO (putStrLn "augmented op2") >> send Op2 +-- op -> send @E (coerce op) +-- :} +-- +-- >>> runEff . runE . genericAugmentOp2 $ send Op1 >> send Op2 +-- op1 +-- augmented op2 +-- op2 +-- +-- On the other hand, when dealing with higher order effects you need to pattern +-- match on each operation and unlift where necessary. +-- interpose - :: forall e es a. (DispatchOf e ~ Dynamic, e :> es) + :: forall e es a. (HasCallStack, DispatchOf e ~ Dynamic, e :> es) => EffectHandler e es -- ^ The effect handler. -> Eff es a @@ -489,12 +568,23 @@ where mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler) +-- | 'interpose' with the effect handler as the last argument. +-- +-- @since 2.4.0.0 +interposeWith + :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es) + => Eff es a + -> EffectHandler e es + -- ^ The effect handler. + -> Eff es a +interposeWith m handler = interpose handler m + -- | Replace the handler of an existing effect with a new one that uses other, -- private effects. -- -- @'interpose' ≡ 'impose' 'id'@ impose - :: forall e es handlerEs a b. (DispatchOf e ~ Dynamic, e :> es) + :: forall e es handlerEs a b. (HasCallStack, DispatchOf e ~ Dynamic, e :> es) => (Eff handlerEs a -> Eff es b) -- ^ Introduction of effects encapsulated within the handler. -> EffectHandler e handlerEs @@ -523,7 +613,128 @@ where mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler) +-- | 'impose' with the effect handler as the last argument. +-- +-- @since 2.4.0.0 +imposeWith + :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es) + => (Eff handlerEs a -> Eff es b) + -- ^ Introduction of effects encapsulated within the handler. + -> Eff es a + -> EffectHandler e handlerEs + -- ^ The effect handler. + -> Eff es b +imposeWith runHandlerEs m handler = impose runHandlerEs handler m + ---------------------------------------- +-- First order effects + +-- | Type signature of a first order effect handler. +-- +-- @since 2.4.0.0 +type EffectHandler_ (e :: Effect) (es :: [Effect]) + = forall a localEs. HasCallStack + => e (Eff localEs) a + -- ^ The operation. + -> Eff es a + +-- | 'interpret' for first order effects. +-- +-- @since 2.4.0.0 +interpret_ + :: (HasCallStack, DispatchOf e ~ Dynamic) + => EffectHandler_ e es + -- ^ The effect handler. + -> Eff (e : es) a + -> Eff es a +interpret_ handler = interpret (const handler) + +-- | 'interpretWith' for first order effects. +-- +-- @since 2.4.0.0 +interpretWith_ + :: (HasCallStack, DispatchOf e ~ Dynamic) + => Eff (e : es) a + -> EffectHandler_ e es + -- ^ The effect handler. + -> Eff es a +interpretWith_ m handler = interpret (const handler) m + +-- | 'reinterpret' for first order effects. +-- +-- @since 2.4.0.0 +reinterpret_ + :: (HasCallStack, DispatchOf e ~ Dynamic) + => (Eff handlerEs a -> Eff es b) + -- ^ Introduction of effects encapsulated within the handler. + -> EffectHandler_ e handlerEs + -- ^ The effect handler. + -> Eff (e : es) a + -> Eff es b +reinterpret_ runHandlerEs handler = reinterpret runHandlerEs (const handler) + +-- | 'reinterpretWith' for first order effects. +-- +-- @since 2.4.0.0 +reinterpretWith_ + :: (HasCallStack, DispatchOf e ~ Dynamic) + => (Eff handlerEs a -> Eff es b) + -- ^ Introduction of effects encapsulated within the handler. + -> Eff (e : es) a + -> EffectHandler_ e handlerEs + -- ^ The effect handler. + -> Eff es b +reinterpretWith_ runHandlerEs m handler = reinterpret runHandlerEs (const handler) m + +-- | 'interpose' for first order effects. +-- +-- @since 2.4.0.0 +interpose_ + :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es) + => EffectHandler_ e es + -- ^ The effect handler. + -> Eff es a + -> Eff es a +interpose_ handler = interpose (const handler) + +-- | 'interposeWith' for first order effects. +-- +-- @since 2.4.0.0 +interposeWith_ + :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es) + => Eff es a + -> EffectHandler_ e es + -- ^ The effect handler. + -> Eff es a +interposeWith_ m handler = interpose (const handler) m + +-- | 'impose' for first order effects. +-- +-- @since 2.4.0.0 +impose_ + :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es) + => (Eff handlerEs a -> Eff es b) + -- ^ Introduction of effects encapsulated within the handler. + -> EffectHandler_ e handlerEs + -- ^ The effect handler. + -> Eff es a + -> Eff es b +impose_ runHandlerEs handler = impose runHandlerEs (const handler) + +-- | 'imposeWith' for first order effects. +-- +-- @since 2.4.0.0 +imposeWith_ + :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es) + => (Eff handlerEs a -> Eff es b) + -- ^ Introduction of effects encapsulated within the handler. + -> Eff es a + -> EffectHandler_ e handlerEs + -- ^ The effect handler. + -> Eff es b +imposeWith_ runHandlerEs m handler = impose runHandlerEs (const handler) m + +---------------------------------------- -- Unlifts -- | Create a local unlifting function with the 'SeqUnlift' strategy. For the @@ -536,8 +747,10 @@ -- ^ Continuation with the unlifting function in scope. -> Eff es a localSeqUnlift (LocalEnv les) k = unsafeEff $ \es -> do + requireMatchingStorages es les seqUnliftIO les $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift +{-# INLINE localSeqUnlift #-} -- | Create a local unlifting function with the 'SeqUnlift' strategy. For the -- general version see 'localUnliftIO'. @@ -548,7 +761,10 @@ -> ((forall r. Eff localEs r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> Eff es a -localSeqUnliftIO (LocalEnv les) k = liftIO $ seqUnliftIO les k +localSeqUnliftIO (LocalEnv les) k = unsafeEff $ \es -> do + requireMatchingStorages es les + seqUnliftIO les k +{-# INLINE localSeqUnliftIO #-} -- | Create a local unlifting function with the given strategy. localUnlift @@ -559,13 +775,15 @@ -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a) -- ^ Continuation with the unlifting function in scope. -> Eff es a -localUnlift (LocalEnv les) strategy k = case strategy of - SeqUnlift -> unsafeEff $ \es -> do - seqUnliftIO les $ \unlift -> do +localUnlift (LocalEnv les) strategy k = unsafeEff $ \es -> do + requireMatchingStorages es les + case strategy of + SeqUnlift -> seqUnliftIO les $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift - ConcUnlift p l -> unsafeEff $ \es -> do - concUnliftIO les p l $ \unlift -> do + SeqForkUnlift -> seqForkUnliftIO les $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift + ConcUnlift p l -> concUnliftIO les p l $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift {-# INLINE localUnlift #-} -- | Create a local unlifting function with the given strategy. @@ -577,9 +795,12 @@ -> ((forall r. Eff localEs r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> Eff es a -localUnliftIO (LocalEnv les) strategy k = case strategy of - SeqUnlift -> liftIO $ seqUnliftIO les k - ConcUnlift p l -> liftIO $ concUnliftIO les p l k +localUnliftIO (LocalEnv les) strategy k = unsafeEff $ \es -> do + requireMatchingStorages es les + case strategy of + SeqUnlift -> seqUnliftIO les k + SeqForkUnlift -> seqForkUnliftIO les k + ConcUnlift p l -> concUnliftIO les p l k {-# INLINE localUnliftIO #-} ---------------------------------------- @@ -596,11 +817,11 @@ -> ((forall r. Eff es r -> Eff localEs r) -> Eff es a) -- ^ Continuation with the lifting function in scope. -> Eff es a -localSeqLift !_ k = unsafeEff $ \es -> do - -- The LocalEnv parameter is not used, but we need it to constraint the - -- localEs type variable. It's also strict so that callers don't cheat. +localSeqLift (LocalEnv les) k = unsafeEff $ \es -> do + requireMatchingStorages es les seqUnliftIO es $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift +{-# INLINE localSeqLift #-} -- | Create a local lifting function with the given strategy. -- @@ -613,15 +834,15 @@ -> ((forall r. Eff es r -> Eff localEs r) -> Eff es a) -- ^ Continuation with the lifting function in scope. -> Eff es a -localLift !_ strategy k = case strategy of - -- The LocalEnv parameter is not used, but we need it to constraint the - -- localEs type variable. It's also strict so that callers don't cheat. - SeqUnlift -> unsafeEff $ \es -> do - seqUnliftIO es $ \unlift -> do +localLift (LocalEnv les) strategy k = unsafeEff $ \es -> do + requireMatchingStorages es les + case strategy of + SeqUnlift -> seqUnliftIO es $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift - ConcUnlift p l -> unsafeEff $ \es -> do - concUnliftIO es p l $ \unlift -> do + SeqForkUnlift -> seqForkUnliftIO es $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift + ConcUnlift p l -> concUnliftIO es p l $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift {-# INLINE localLift #-} -- | Utility for lifting 'Eff' computations of type @@ -641,12 +862,12 @@ -> ((forall a b. (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b) -> Eff es r) -- ^ Continuation with the lifting function in scope. -> Eff es r -withLiftMap !_ k = unsafeEff $ \es -> do - -- The LocalEnv parameter is not used, but we need it to constraint the - -- localEs type variable. It's also strict so that callers don't cheat. +withLiftMap (LocalEnv les) k = unsafeEff $ \es -> do + requireMatchingStorages es les (`unEff` es) $ k $ \mapEff m -> unsafeEff $ \localEs -> do seqUnliftIO localEs $ \unlift -> do (`unEff` es) . mapEff . unsafeEff_ $ unlift m +{-# INLINE withLiftMap #-} -- | Utility for lifting 'IO' computations of type -- @@ -681,10 +902,11 @@ -> ((forall a b. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r) -- ^ Continuation with the lifting function in scope. -> Eff es r -withLiftMapIO !_ k = k $ \mapIO m -> unsafeEff $ \es -> do - -- The LocalEnv parameter is not used, but we need it to constraint the - -- localEs type variable. It's also strict so that callers don't cheat. - seqUnliftIO es $ \unlift -> mapIO $ unlift m +withLiftMapIO (LocalEnv les) k = unsafeEff $ \es -> do + requireMatchingStorages es les + (`unEff` es) $ k $ \mapIO m -> unsafeEff $ \localEs -> do + seqUnliftIO localEs $ \unlift -> mapIO $ unlift m +{-# INLINE withLiftMapIO #-} ---------------------------------------- -- Bidirectional lifts @@ -704,13 +926,16 @@ -> ((forall r. Eff es r -> Eff localEs r) -> (forall r. Eff localEs r -> Eff es r) -> Eff es a) -- ^ Continuation with the lifting and unlifting function in scope. -> Eff es a -localLiftUnlift (LocalEnv les) strategy k = case strategy of - SeqUnlift -> unsafeEff $ \es -> do - seqUnliftIO es $ \unliftEs -> do +localLiftUnlift (LocalEnv les) strategy k = unsafeEff $ \es -> do + requireMatchingStorages es les + case strategy of + SeqUnlift -> seqUnliftIO es $ \unliftEs -> do seqUnliftIO les $ \unliftLocalEs -> do (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs) - ConcUnlift p l -> unsafeEff $ \es -> do - concUnliftIO es p l $ \unliftEs -> do + SeqForkUnlift -> seqForkUnliftIO es $ \unliftEs -> do + seqForkUnliftIO les $ \unliftLocalEs -> do + (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs) + ConcUnlift p l -> concUnliftIO es p l $ \unliftEs -> do concUnliftIO les p l $ \unliftLocalEs -> do (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs) {-# INLINE localLiftUnlift #-} @@ -731,15 +956,18 @@ -> ((forall r. IO r -> Eff localEs r) -> (forall r. Eff localEs r -> IO r) -> IO a) -- ^ Continuation with the lifting and unlifting function in scope. -> Eff es a -localLiftUnliftIO (LocalEnv les) strategy k = case strategy of - SeqUnlift -> liftIO $ seqUnliftIO les $ k unsafeEff_ - ConcUnlift p l -> liftIO $ concUnliftIO les p l $ k unsafeEff_ +localLiftUnliftIO (LocalEnv les) strategy k = unsafeEff $ \es -> do + requireMatchingStorages es les + case strategy of + SeqUnlift -> seqUnliftIO les $ k unsafeEff_ + SeqForkUnlift -> seqForkUnliftIO les $ k unsafeEff_ + ConcUnlift p l -> concUnliftIO les p l $ k unsafeEff_ {-# INLINE localLiftUnliftIO #-} ---------------------------------------- -- Misc --- | Lend an effect to the local environment. +-- | Lend effects to the local environment. -- -- Consider the following effect: -- @@ -777,93 +1005,119 @@ -- runD :: IOE :> es => Eff (D : es) a -> Eff es a -- runD = interpret $ \env -> \case -- D -> localSeqUnlift env $ \unlift -> do --- localSeqLend @IOE env $ \useIOE -> do +-- localSeqLend @'[IOE] env $ \useIOE -> do -- unlift . useIOE . runE $ pure () -- :} -- --- @since 2.3.1.0 +-- @since 2.4.0.0 localSeqLend - :: (e :> es, SharedSuffix es handlerEs) + :: forall lentEs es handlerEs localEs a + . (HasCallStack, KnownSubset lentEs es, SharedSuffix es handlerEs) => LocalEnv localEs handlerEs - -> ((forall r. Eff (e : localEs) r -> Eff localEs r) -> Eff es a) + -> ((forall r. Eff (lentEs ++ localEs) r -> Eff localEs r) -> Eff es a) -- ^ Continuation with the lent handler in scope. -> Eff es a localSeqLend (LocalEnv les) k = unsafeEff $ \es -> do - eles <- copyRef es les + eles <- copyRefs @lentEs es les seqUnliftIO eles $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift +{-# INLINE localSeqLend #-} --- | Lend an effect to the local environment with a given unlifting strategy. +-- | Lend effects to the local environment with a given unlifting strategy. -- -- Generalizes 'localSeqLend'. -- --- @since 2.3.1.0 +-- @since 2.4.0.0 localLend - :: (e :> es, SharedSuffix es handlerEs) + :: forall lentEs es handlerEs localEs a + . (HasCallStack, KnownSubset lentEs es, SharedSuffix es handlerEs) => LocalEnv localEs handlerEs -> UnliftStrategy - -> ((forall r. Eff (e : localEs) r -> Eff localEs r) -> Eff es a) + -> ((forall r. Eff (lentEs ++ localEs) r -> Eff localEs r) -> Eff es a) -- ^ Continuation with the lent handler in scope. -> Eff es a -localLend (LocalEnv les) strategy k = case strategy of - SeqUnlift -> unsafeEff $ \es -> do - eles <- copyRef es les - seqUnliftIO eles $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift - ConcUnlift p l -> unsafeEff $ \es -> do - eles <- copyRef es les - concUnliftIO eles p l $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift +localLend (LocalEnv les) strategy k = unsafeEff $ \es -> do + eles <- copyRefs @lentEs es les + case strategy of + SeqUnlift -> seqUnliftIO eles $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift + SeqForkUnlift -> seqForkUnliftIO eles $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift + ConcUnlift p l -> concUnliftIO eles p l $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift {-# INLINE localLend #-} --- | Borrow an effect from the local environment. +-- | Borrow effects from the local environment. -- --- @since 2.3.1.0 +-- @since 2.4.0.0 localSeqBorrow - :: (e :> localEs, SharedSuffix es handlerEs) + :: forall borrowedEs es handlerEs localEs a + . (HasCallStack, KnownSubset borrowedEs localEs, SharedSuffix es handlerEs) => LocalEnv localEs handlerEs - -> ((forall r. Eff (e : es) r -> Eff es r) -> Eff es a) + -> ((forall r. Eff (borrowedEs ++ es) r -> Eff es r) -> Eff es a) -- ^ Continuation with the borrowed handler in scope. -> Eff es a localSeqBorrow (LocalEnv les) k = unsafeEff $ \es -> do - ees <- copyRef les es + ees <- copyRefs @borrowedEs les es seqUnliftIO ees $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift +{-# INLINE localSeqBorrow #-} --- | Borrow an effect from the local environment with a given unlifting +-- | Borrow effects from the local environment with a given unlifting -- strategy. -- -- Generalizes 'localSeqBorrow'. -- --- @since 2.3.1.0 +-- @since 2.4.0.0 localBorrow - :: (e :> localEs, SharedSuffix es handlerEs) + :: forall borrowedEs es handlerEs localEs a + . (HasCallStack, KnownSubset borrowedEs localEs, SharedSuffix es handlerEs) => LocalEnv localEs handlerEs -> UnliftStrategy - -> ((forall r. Eff (e : es) r -> Eff es r) -> Eff es a) + -> ((forall r. Eff (borrowedEs ++ es) r -> Eff es r) -> Eff es a) -- ^ Continuation with the borrowed handler in scope. -> Eff es a -localBorrow (LocalEnv les) strategy k = case strategy of - SeqUnlift -> unsafeEff $ \es -> do - ees <- copyRef les es - seqUnliftIO ees $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift - ConcUnlift p l -> unsafeEff $ \es -> do - ees <- copyRef les es - concUnliftIO ees p l $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift +localBorrow (LocalEnv les) strategy k = unsafeEff $ \es -> do + ees <- copyRefs @borrowedEs les es + case strategy of + SeqUnlift -> seqUnliftIO ees $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift + SeqForkUnlift -> seqForkUnliftIO ees $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift + ConcUnlift p l -> concUnliftIO ees p l $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift {-# INLINE localBorrow #-} -copyRef - :: forall e srcEs destEs. e :> srcEs +copyRefs + :: forall es srcEs destEs + . (HasCallStack, KnownSubset es srcEs) => Env srcEs -> Env destEs - -> IO (Env (e : destEs)) -copyRef (Env hoffset hrefs hstorage) (Env offset refs0 storage) = do - when (hstorage /= storage) $ do - error "storages do not match" - let size = sizeofPrimArray refs0 - offset - i = 2 * reifyIndex @e @srcEs - mrefs <- newPrimArray (size + 2) - copyPrimArray mrefs 0 hrefs (hoffset + i) 2 - copyPrimArray mrefs 2 refs0 offset size + -> IO (Env (es ++ destEs)) +copyRefs src@(Env soffset srefs _) dest@(Env doffset drefs storage) = do + requireMatchingStorages src dest + let es = reifyIndices @es @srcEs + esSize = length es + destSize = sizeofPrimArray drefs - doffset + mrefs <- newPrimArray (esSize + destSize) + copyPrimArray mrefs esSize drefs doffset destSize + let writeRefs i = \case + [] -> pure () + (x : xs) -> do + writePrimArray mrefs i $ indexPrimArray srefs (soffset + x) + writeRefs (i + 1) xs + writeRefs 0 es refs <- unsafeFreezePrimArray mrefs pure $ Env 0 refs storage +{-# NOINLINE copyRefs #-} +requireMatchingStorages :: HasCallStack => Env es1 -> Env es2 -> IO () +requireMatchingStorages es1 es2 + | envStorage es1 /= envStorage es2 = error + $ "Env and LocalEnv point to different Storages.\n" + ++ "If you passed LocalEnv to a different thread and tried to create an " + ++ "unlifting function there, it's not allowed. You need to create it in " + ++ "the thread of the effect handler." + | otherwise = pure () + -- | Require that both effect stacks share an opaque suffix. -- -- Functions from the 'localUnlift' family utilize this constraint to guarantee @@ -937,4 +1191,5 @@ -- $setup -- >>> import Control.Concurrent (ThreadId, forkIOWithUnmask) +-- >>> import Control.Monad.IO.Class -- >>> import Effectful.Reader.Static diff --git a/src/Effectful/Error/Dynamic.hs b/src/Effectful/Error/Dynamic.hs --- a/src/Effectful/Error/Dynamic.hs +++ b/src/Effectful/Error/Dynamic.hs @@ -14,7 +14,9 @@ , runErrorNoCallStackWith -- ** Operations + , throwErrorWith , throwError + , throwError_ , catchError , handleError , tryError @@ -34,17 +36,19 @@ -- | Provide the ability to handle errors of type @e@. data Error e :: Effect where - ThrowError :: e -> Error e m a + -- | @since 2.4.0.0 + ThrowErrorWith :: (e -> String) -> e -> Error e m a CatchError :: m a -> (E.CallStack -> e -> m a) -> Error e m a type instance DispatchOf (Error e) = Dynamic -- | Handle errors of type @e@ (via "Effectful.Error.Static"). runError - :: Eff (Error e : es) a + :: HasCallStack + => Eff (Error e : es) a -> Eff es (Either (E.CallStack, e) a) runError = reinterpret E.runError $ \env -> \case - ThrowError e -> E.throwError e + ThrowErrorWith display e -> E.throwErrorWith display e CatchError m h -> localSeqUnlift env $ \unlift -> do E.catchError (unlift m) (\cs -> unlift . h cs) @@ -53,7 +57,8 @@ -- -- @since 2.3.0.0 runErrorWith - :: (E.CallStack -> e -> Eff es a) + :: HasCallStack + => (E.CallStack -> e -> Eff es a) -- ^ The error handler. -> Eff (Error e : es) a -> Eff es a @@ -66,14 +71,16 @@ -- -- @since 2.3.0.0 runErrorNoCallStack - :: Eff (Error e : es) a + :: HasCallStack + => Eff (Error e : es) a -> Eff es (Either e a) runErrorNoCallStack = fmap (either (Left . snd) Right) . runError -- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific -- error handler. In case of an error discard the 'CallStack'. runErrorNoCallStackWith - :: (e -> Eff es a) + :: HasCallStack + => (e -> Eff es a) -- ^ The error handler. -> Eff (Error e : es) a -> Eff es a @@ -81,13 +88,36 @@ Left e -> handler e Right a -> pure a --- | Throw an error of type @e@. +-- | Throw an error of type @e@ and specify a display function in case a +-- third-party code catches the internal exception and 'show's it. +-- +-- @since 2.4.0.0 +throwErrorWith + :: (HasCallStack, Error e :> es) + => (e -> String) + -- ^ The display function. + -> e + -- ^ The error. + -> Eff es a +throwErrorWith display = withFrozenCallStack send . ThrowErrorWith display + +-- | Throw an error of type @e@ with 'show' as a display function. throwError + :: (HasCallStack, Error e :> es, Show e) + => e + -- ^ The error. + -> Eff es a +throwError = withFrozenCallStack throwErrorWith show + +-- | Throw an error of type @e@ with no display function. +-- +-- @since 2.4.0.0 +throwError_ :: (HasCallStack, Error e :> es) => e -- ^ The error. -> Eff es a -throwError e = withFrozenCallStack $ send (ThrowError e) +throwError_ = withFrozenCallStack throwErrorWith (const "") -- | Handle an error of type @e@. catchError @@ -102,7 +132,7 @@ -- | The same as @'flip' 'catchError'@, which is useful in situations where the -- code for the handler is shorter. handleError - :: Error e :> es + :: (HasCallStack, Error e :> es) => (E.CallStack -> e -> Eff es a) -- ^ A handler for errors in the inner computation. -> Eff es a diff --git a/src/Effectful/Error/Static.hs b/src/Effectful/Error/Static.hs --- a/src/Effectful/Error/Static.hs +++ b/src/Effectful/Error/Static.hs @@ -1,13 +1,13 @@ -- | Support for handling errors of a particular type, i.e. checked exceptions. -- -- The 'Error' effect is __not__ a general mechanism for handling regular --- exceptions, that's what functions from the @exceptions@ library are for (see --- "Control.Monad.Catch" for more information). +-- exceptions, that's what functions from the "Effectful.Exception" module are +-- for. -- -- In particular, regular exceptions of type @e@ are distinct from errors of -- type @e@ and will __not__ be caught by functions from this module: -- --- >>> import qualified Control.Monad.Catch as E +-- >>> import Effectful.Exception qualified as E -- -- >>> boom = error "BOOM!" -- @@ -16,14 +16,14 @@ -- ... -- -- If you want to catch regular exceptions, you should use --- 'Control.Monad.Catch.catch' (or a similar function): +-- 'Effectful.Exception.catch' (or a similar function): -- -- >>> runEff $ boom `E.catch` \(_::ErrorCall) -> pure "caught" -- "caught" -- -- On the other hand, functions for safe finalization and management of --- resources such as 'Control.Monad.Catch.finally' and --- 'Control.Monad.Catch.bracket' work as expected: +-- resources such as 'Effectful.Exception.finally' and +-- 'Effectful.Exception.bracket' work as expected: -- -- >>> msg = liftIO . putStrLn -- @@ -43,8 +43,8 @@ -- effect with regard to other stateful effects does not matter. Consider the -- following: -- --- >>> import qualified Control.Monad.State.Strict as T --- >>> import qualified Control.Monad.Except as T +-- >>> import Control.Monad.State.Strict qualified as T +-- >>> import Control.Monad.Except qualified as T -- -- >>> m1 = (T.modify (++ " there!") >> T.throwError "oops") `T.catchError` \_ -> pure () -- @@ -74,7 +74,7 @@ -- -- /Hint:/ if you'd like to reproduce the transactional behavior with the -- t'Effectful.State.Static.Local.State' effect, appropriate usage of --- 'Control.Monad.Catch.bracketOnError' will do the trick. +-- 'Effectful.Exception.bracketOnError' will do the trick. module Effectful.Error.Static ( -- * Effect Error @@ -86,7 +86,9 @@ , runErrorNoCallStackWith -- ** Operations + , throwErrorWith , throwError + , throwError_ , catchError , handleError , tryError @@ -99,6 +101,7 @@ ) where import Control.Exception +import Data.Kind import GHC.Stack import Effectful @@ -107,7 +110,7 @@ import Effectful.Internal.Utils -- | Provide the ability to handle errors of type @e@. -data Error e :: Effect +data Error (e :: Type) :: Effect type instance DispatchOf (Error e) = Static NoSideEffects newtype instance StaticRep (Error e) = Error ErrorId @@ -115,7 +118,8 @@ -- | Handle errors of type @e@. runError :: forall e es a - . Eff (Error e : es) a + . HasCallStack + => Eff (Error e : es) a -> Eff es (Either (CallStack, e) a) runError m = unsafeEff $ \es0 -> mask $ \unmask -> do eid <- newErrorId @@ -133,7 +137,8 @@ -- -- @since 2.3.0.0 runErrorWith - :: (CallStack -> e -> Eff es a) + :: HasCallStack + => (CallStack -> e -> Eff es a) -- ^ The error handler. -> Eff (Error e : es) a -> Eff es a @@ -146,14 +151,16 @@ -- @since 2.3.0.0 runErrorNoCallStack :: forall e es a - . Eff (Error e : es) a + . HasCallStack + => Eff (Error e : es) a -> Eff es (Either e a) runErrorNoCallStack = fmap (either (Left . snd) Right) . runError -- | Handle errors of type @e@ with a specific error handler. In case of an -- error discard the 'CallStack'. runErrorNoCallStackWith - :: (e -> Eff es a) + :: HasCallStack + => (e -> Eff es a) -- ^ The error handler. -> Eff (Error e : es) a -> Eff es a @@ -161,19 +168,42 @@ Left e -> handler e Right a -> pure a --- | Throw an error of type @e@. +-- | Throw an error of type @e@ and specify a display function in case a +-- third-party code catches the internal exception and 'show's it. +-- +-- @since 2.4.0.0 +throwErrorWith + :: forall e es a. (HasCallStack, Error e :> es) + => (e -> String) + -- ^ The display function. + -> e + -- ^ The error. + -> Eff es a +throwErrorWith display e = unsafeEff $ \es -> do + Error eid <- getEnv @(Error e) es + throwIO $ ErrorWrapper eid callStack (display e) (toAny e) + +-- | Throw an error of type @e@ with 'show' as a display function. throwError + :: forall e es a. (HasCallStack, Error e :> es, Show e) + => e + -- ^ The error. + -> Eff es a +throwError = withFrozenCallStack throwErrorWith show + +-- | Throw an error of type @e@ with no display function. +-- +-- @since 2.4.0.0 +throwError_ :: forall e es a. (HasCallStack, Error e :> es) => e -- ^ The error. -> Eff es a -throwError e = unsafeEff $ \es -> do - Error eid <- getEnv @(Error e) es - throwIO $ ErrorWrapper eid callStack (toAny e) +throwError_ = withFrozenCallStack throwErrorWith (const "") -- | Handle an error of type @e@. catchError - :: forall e es a. Error e :> es + :: forall e es a. (HasCallStack, Error e :> es) => Eff es a -- ^ The inner computation. -> (CallStack -> e -> Eff es a) @@ -187,7 +217,7 @@ -- | The same as @'flip' 'catchError'@, which is useful in situations where the -- code for the handler is shorter. handleError - :: forall e es a. Error e :> es + :: forall e es a. (HasCallStack, Error e :> es) => (CallStack -> e -> Eff es a) -- ^ A handler for errors in the inner computation. -> Eff es a @@ -198,7 +228,7 @@ -- | Similar to 'catchError', but returns an 'Either' result which is a 'Right' -- if no error was thrown and a 'Left' otherwise. tryError - :: forall e es a. Error e :> es + :: forall e es a. (HasCallStack, Error e :> es) => Eff es a -- ^ The inner computation. -> Eff es (Either (CallStack, e) a) @@ -208,7 +238,7 @@ -- Helpers newtype ErrorId = ErrorId Unique - deriving Eq + deriving newtype Eq -- | A unique is picked so that distinct 'Error' handlers for the same type -- don't catch each other's exceptions. @@ -222,21 +252,25 @@ -> IO r -> IO r tryHandler ex eid0 handler next = case fromException ex of - Just (ErrorWrapper eid cs e) + Just (ErrorWrapper eid cs _ e) | eid0 == eid -> pure $ handler cs (fromAny e) | otherwise -> next Nothing -> next -data ErrorWrapper = ErrorWrapper !ErrorId CallStack Any +data ErrorWrapper = ErrorWrapper !ErrorId CallStack String Any + instance Show ErrorWrapper where - showsPrec p (ErrorWrapper _ cs _) - = ("Effectful.Error.Static.ErrorWrapper\n\n" ++) - . showsPrec p (prettyCallStack cs) + showsPrec _ (ErrorWrapper _ cs errRep _) + = ("Effectful.Error.Static.ErrorWrapper: " ++) + . (errRep ++) + . ("\n" ++) + . (prettyCallStack cs ++) + instance Exception ErrorWrapper catchErrorIO :: ErrorId -> IO a -> (CallStack -> e -> IO a) -> IO a catchErrorIO eid m handler = do - m `catch` \err@(ErrorWrapper etag cs e) -> do + m `catch` \err@(ErrorWrapper etag cs _ e) -> do if eid == etag then handler cs (fromAny e) else throwIO err diff --git a/src/Effectful/Exception.hs b/src/Effectful/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Exception.hs @@ -0,0 +1,130 @@ +-- | The 'Eff' monad comes with instances of 'MonadThrow', 'MonadCatch' and +-- 'MonadMask' from the +-- [@exceptions@](https://hackage.haskell.org/package/exceptions) library, so +-- this module simply re-exports the interface of the +-- [@safe-exceptions@](https://hackage.haskell.org/package/safe-exceptions) +-- library. +-- +-- Why @safe-exceptions@ and not @exceptions@? Because the former makes it much +-- easier to correctly deal with asynchronous exceptions (for more information +-- see its [README](https://github.com/fpco/safe-exceptions#readme)) and +-- provides more convenience functions. +module Effectful.Exception + ( -- * Throwing + C.MonadThrow(..) + , Safe.throwString + , Safe.StringException(..) + + -- * Catching (with recovery) + , C.MonadCatch(..) + , Safe.catchIO + , Safe.catchIOError + , Safe.catchAny + , Safe.catchDeep + , Safe.catchAnyDeep + , Safe.catchAsync + , Safe.catchJust + + , Safe.handle + , Safe.handleIO + , Safe.handleIOError + , Safe.handleAny + , Safe.handleDeep + , Safe.handleAnyDeep + , Safe.handleAsync + , Safe.handleJust + + , Safe.try + , Safe.tryIO + , Safe.tryAny + , Safe.tryDeep + , Safe.tryAnyDeep + , Safe.tryAsync + , Safe.tryJust + + , Safe.Handler(..) + , Safe.catches + , Safe.catchesDeep + , Safe.catchesAsync + + -- * Cleanup (no recovery) + , C.MonadMask(..) + , C.ExitCase(..) + , Safe.onException + , Safe.bracket + , Safe.bracket_ + , Safe.finally + , Safe.withException + , Safe.bracketOnError + , Safe.bracketOnError_ + , Safe.bracketWithError + + -- * Utilities + + -- ** Coercion to sync and async + , Safe.SyncExceptionWrapper(..) + , Safe.toSyncException + , Safe.AsyncExceptionWrapper(..) + , Safe.toAsyncException + + -- ** Check exception type + , Safe.isSyncException + , Safe.isAsyncException + + -- ** Evaluation + , evaluate + , evaluateDeep + + -- * Re-exports from "Control.Exception" + + -- ** The 'SomeException' type + , E.SomeException(..) + + -- ** The 'Exception' class + , E.Exception(..) + + -- ** Concrete exception types + , E.IOException + , E.ArithException(..) + , E.ArrayException(..) + , E.AssertionFailed(..) + , E.NoMethodError(..) + , E.PatternMatchFail(..) + , E.RecConError(..) + , E.RecSelError(..) + , E.RecUpdError(..) + , E.ErrorCall(..) + , E.TypeError(..) + + -- ** Asynchronous exceptions + , E.SomeAsyncException(..) + , E.AsyncException(..) + , E.asyncExceptionToException + , E.asyncExceptionFromException + , E.NonTermination(..) + , E.NestedAtomically(..) + , E.BlockedIndefinitelyOnMVar(..) + , E.BlockedIndefinitelyOnSTM(..) + , E.AllocationLimitExceeded(..) + , E.CompactionFailed(..) + , E.Deadlock(..) + + -- ** Assertions + , E.assert + ) where + +import Control.DeepSeq +import Control.Exception qualified as E +import Control.Exception.Safe qualified as Safe +import Control.Monad.Catch qualified as C + +import Effectful +import Effectful.Dispatch.Static + +-- | Lifted version of 'E.evaluate'. +evaluate :: a -> Eff es a +evaluate = unsafeEff_ . E.evaluate + +-- | Deeply evaluate a value using 'evaluate' and 'NFData'. +evaluateDeep :: NFData a => a -> Eff es a +evaluateDeep = unsafeEff_ . E.evaluate . force diff --git a/src/Effectful/Fail.hs b/src/Effectful/Fail.hs --- a/src/Effectful/Fail.hs +++ b/src/Effectful/Fail.hs @@ -14,11 +14,11 @@ import Effectful.Internal.Monad (Fail(..)) -- | Run the 'Fail' effect via 'Error'. -runFail :: Eff (Fail : es) a -> Eff es (Either String a) -runFail = reinterpret runErrorNoCallStack $ \_ -> \case +runFail :: HasCallStack => Eff (Fail : es) a -> Eff es (Either String a) +runFail = reinterpret_ runErrorNoCallStack $ \case Fail msg -> throwError msg -- | Run the 'Fail' effect via the 'MonadFail' instance for 'IO'. -runFailIO :: IOE :> es => Eff (Fail : es) a -> Eff es a -runFailIO = interpret $ \_ -> \case +runFailIO :: (HasCallStack, IOE :> es) => Eff (Fail : es) a -> Eff es a +runFailIO = interpret_ $ \case Fail msg -> liftIO $ fail msg diff --git a/src/Effectful/Internal/Effect.hs b/src/Effectful/Internal/Effect.hs --- a/src/Effectful/Internal/Effect.hs +++ b/src/Effectful/Internal/Effect.hs @@ -10,6 +10,7 @@ , (:>)(..) , (:>>) , Subset(..) + , KnownSubset , KnownPrefix(..) , IsUnknownSuffixOf , type (++) @@ -70,8 +71,8 @@ ---------------------------------------- --- | Provide evidence that @xs@ is a subset of @es@. -class KnownPrefix es => Subset (xs :: [Effect]) (es :: [Effect]) where +-- | Provide evidence that @subEs@ is a subset of @es@. +class KnownPrefix es => Subset (subEs :: [Effect]) (es :: [Effect]) where subsetFullyKnown :: Bool subsetFullyKnown = -- Don't show "minimal complete definition" in haddock. @@ -86,8 +87,8 @@ -- have the same unknown suffix. instance {-# INCOHERENT #-} ( KnownPrefix es - , xs `IsUnknownSuffixOf` es - ) => Subset xs es where + , subEs `IsUnknownSuffixOf` es + ) => Subset subEs es where subsetFullyKnown = False reifyIndices = [] @@ -96,12 +97,19 @@ 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 +instance (e :> es, Subset subEs es) => Subset (e : subEs) es where + subsetFullyKnown = subsetFullyKnown @subEs @es + reifyIndices = reifyIndex @e @es : reifyIndices @subEs @es ---- +-- | Provide evidence that @subEs@ is a known subset of @es@. +class Subset subEs es => KnownSubset (subEs :: [Effect]) (es :: [Effect]) +instance KnownSubset '[] es +instance (e :> es, KnownSubset subEs es) => KnownSubset (e : subEs) es + +---- + -- | Calculate length of a statically known prefix of @es@. class KnownPrefix (es :: [Effect]) where prefixLength :: Int @@ -114,10 +122,10 @@ ---- --- | 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) +-- | Require that @subEs@ is the unknown suffix of @es@. +class (subEs :: [Effect]) `IsUnknownSuffixOf` (es :: [Effect]) +instance {-# INCOHERENT #-} subEs ~ es => subEs `IsUnknownSuffixOf` es +instance subEs `IsUnknownSuffixOf` es => subEs `IsUnknownSuffixOf` (e : es) ---- diff --git a/src/Effectful/Internal/Env.hs b/src/Effectful/Internal/Env.hs --- a/src/Effectful/Internal/Env.hs +++ b/src/Effectful/Internal/Env.hs @@ -1,10 +1,20 @@ {-# 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(..) @@ -40,9 +50,12 @@ import Control.Monad import Control.Monad.Primitive +import Data.IORef.Strict import Data.Primitive.PrimArray import Data.Primitive.SmallArray -import GHC.Stack (HasCallStack) +import Data.Primitive.Types +import GHC.Exts ((*#), (+#)) +import GHC.Stack import Effectful.Internal.Effect import Effectful.Internal.Utils @@ -74,19 +87,78 @@ -- data Env (es :: [Effect]) = Env { envOffset :: !Int - , envRefs :: !(PrimArray Int) + , envRefs :: !(PrimArray Ref) , envStorage :: !(IORef' Storage) } +-- | Reference to the effect in 'Storage'. +data Ref = Ref !Int !Version + +instance Prim Ref where + sizeOf# _ = 2# *# sizeOf# (undefined :: Int) + alignment# _ = alignment# (undefined :: Int) + indexByteArray# arr i = + let n = 2# *# i + ref = indexByteArray# arr n + version = indexByteArray# arr (n +# 1#) + in Ref ref version + readByteArray# arr i s0 = + let n = 2# *# i + !(# s1, ref #) = readByteArray# arr n s0 + !(# s2, version #) = readByteArray# arr (n +# 1#) s1 + in (# s2, Ref ref version #) + writeByteArray# arr i (Ref ref version) s0 = + let n = 2# *# i + s1 = writeByteArray# arr n ref s0 + s2 = writeByteArray# arr (n +# 1#) version s1 + in s2 + indexOffAddr# addr i = + let n = 2# *# i + ref = indexOffAddr# addr n + version = indexOffAddr# addr (n +# 1#) + in Ref ref version + readOffAddr# addr i s0 = + let n = 2# *# i + !(# s1, ref #) = readOffAddr# addr n s0 + !(# s2, version #) = readOffAddr# addr (n +# 1#) s1 + in (# s2, Ref ref version #) + writeOffAddr# addr i (Ref ref version) s0 = + let n = 2# *# i + s1 = writeOffAddr# addr n ref s0 + s2 = writeOffAddr# addr (n +# 1#) version s1 + in s2 + +-- | Version of the effect. +newtype Version = Version Int + deriving newtype (Eq, Ord, Prim, Show) + -- | A storage of effects. data Storage = Storage { stSize :: !Int - , stVersion :: !Int - , stVersions :: !(MutablePrimArray RealWorld Int) - , stEffects :: !(SmallMutableArray RealWorld Any) - , stRelinkers :: !(SmallMutableArray RealWorld Any) + , stVersion :: !Version + , stVersions :: !(MutablePrimArray RealWorld Version) + , stEffects :: !(SmallMutableArray RealWorld AnyEffect) + , stRelinkers :: !(SmallMutableArray RealWorld AnyRelinker) } +-- | Effect in 'Storage'. +newtype AnyEffect = AnyEffect Any + +toAnyEffect :: EffectRep (DispatchOf e) e -> AnyEffect +toAnyEffect = AnyEffect . toAny + +fromAnyEffect :: AnyEffect -> EffectRep (DispatchOf e) e +fromAnyEffect (AnyEffect e) = fromAny e + +-- | Relinker in 'Storage'. +newtype AnyRelinker = AnyRelinker Any + +toAnyRelinker :: Relinker (EffectRep (DispatchOf e)) e -> AnyRelinker +toAnyRelinker = AnyRelinker . toAny + +fromAnyRelinker :: AnyRelinker -> Relinker (EffectRep (DispatchOf e)) e +fromAnyRelinker (AnyRelinker f) = fromAny f + ---------------------------------------- -- Relinker @@ -94,7 +166,7 @@ -- a deep copy of the representation of the effect when cloning the environment. newtype Relinker :: (Effect -> Type) -> Effect -> Type where Relinker - :: ((forall es. Env es -> IO (Env es)) -> rep e -> IO (rep e)) + :: (HasCallStack => (forall es. Env es -> IO (Env es)) -> rep e -> IO (rep e)) -> Relinker rep e -- | A dummy 'Relinker'. @@ -125,13 +197,13 @@ -- Operations -- | Create an empty environment. -emptyEnv :: IO (Env '[]) +emptyEnv :: HasCallStack => IO (Env '[]) 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 :: HasCallStack => Env es -> IO (Env es) cloneEnv (Env offset refs storage0) = do Storage storageSize version vs0 es0 fs0 <- readIORef' storage0 vsSize <- getSizeofMutablePrimArray vs0 @@ -149,10 +221,10 @@ 0 -> pure () k -> do let i = k - 1 - Relinker f <- fromAny <$> readSmallArray fs i + Relinker relinker <- fromAnyRelinker <$> readSmallArray fs i readSmallArray es i - >>= f (relinkEnv storage) . fromAny - >>= writeSmallArray' es i . toAny + >>= relinker (relinkEnv storage) . fromAnyEffect + >>= writeSmallArray' es i . toAnyEffect relinkEffects i relinkEffects storageSize pure $ Env offset refs storage @@ -162,7 +234,8 @@ -- -- @since 2.2.0.0 restoreEnv - :: Env es -- ^ Destination. + :: HasCallStack + => Env es -- ^ Destination. -> Env es -- ^ Source. -> IO () restoreEnv dest src = do @@ -183,30 +256,30 @@ -- | Get the current size of the environment. sizeEnv :: Env es -> IO Int sizeEnv (Env offset refs _) = do - pure $ (sizeofPrimArray refs - offset) `div` 2 + pure $ sizeofPrimArray refs - offset -- | Access the tail of the environment. tailEnv :: Env (e : es) -> IO (Env es) tailEnv (Env offset refs storage) = do - pure $ Env (offset + 2) refs storage + pure $ Env (offset + 1) refs storage ---------------------------------------- -- Extending and shrinking -- | Extend the environment with a new data type. consEnv - :: EffectRep (DispatchOf e) e + :: HasCallStack + => EffectRep (DispatchOf e) e -- ^ The representation of the effect. -> Relinker (EffectRep (DispatchOf e)) e -> Env es -> IO (Env (e : es)) 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 + mrefs <- newPrimArray (size + 1) + copyPrimArray mrefs 1 refs0 offset size + ref <- insertEffect storage e f writePrimArray mrefs 0 ref - writePrimArray mrefs 1 version refs <- unsafeFreezePrimArray mrefs pure $ Env 0 refs storage {-# NOINLINE consEnv #-} @@ -215,7 +288,7 @@ -- -- /Note:/ after calling this function @e@ from the input environment is no -- longer usable. -unconsEnv :: Env (e : es) -> IO () +unconsEnv :: HasCallStack => Env (e : es) -> IO () unconsEnv (Env _ refs storage) = do deleteEffect storage (indexPrimArray refs 0) {-# NOINLINE unconsEnv #-} @@ -227,7 +300,7 @@ -- /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 + :: forall e es. (HasCallStack, e :> es) => EffectRep (DispatchOf e) e -- ^ The representation of the effect. -> Relinker (EffectRep (DispatchOf e)) e @@ -237,10 +310,8 @@ 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 + ref <- insertEffect storage e f + writePrimArray mrefs (reifyIndex @e @es) ref refs <- unsafeFreezePrimArray mrefs pure $ Env 0 refs storage {-# NOINLINE replaceEnv #-} @@ -249,9 +320,9 @@ -- -- /Note:/ after calling this function the input environment is no longer -- usable. -unreplaceEnv :: forall e es. e :> es => Env es -> IO () +unreplaceEnv :: forall e es. (HasCallStack, e :> es) => Env es -> IO () unreplaceEnv (Env offset refs storage) = do - deleteEffect storage $ indexPrimArray refs (offset + 2 * reifyIndex @e @es) + deleteEffect storage $ indexPrimArray refs (offset + reifyIndex @e @es) {-# NOINLINE unreplaceEnv #-} ---------------------------------------- @@ -260,11 +331,9 @@ subsumeEnv :: forall e es. e :> es => Env es -> IO (Env (e : es)) 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) + mrefs <- newPrimArray (size + 1) + copyPrimArray mrefs 1 refs0 offset size + writePrimArray mrefs 0 $ indexPrimArray refs0 (offset + reifyIndex @e @es) refs <- unsafeFreezePrimArray mrefs pure $ Env 0 refs storage {-# NOINLINE subsumeEnv #-} @@ -273,24 +342,22 @@ -- | 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 :: forall subEs es. Subset subEs es => Env es -> IO (Env subEs) injectEnv (Env offset refs0 storage) = do - let xs = reifyIndices @xs @es - permSize = 2 * length xs - prefixSize = 2 * prefixLength @es - suffixSize = if subsetFullyKnown @xs @es + let subEs = reifyIndices @subEs @es + subEsSize = length subEs + prefixSize = prefixLength @es + suffixSize = if subsetFullyKnown @subEs @es then 0 else sizeofPrimArray refs0 - offset - prefixSize - mrefs <- newPrimArray (permSize + suffixSize) - copyPrimArray mrefs permSize refs0 (offset + prefixSize) suffixSize - let writePermRefs i = \case + mrefs <- newPrimArray (subEsSize + suffixSize) + copyPrimArray mrefs subEsSize refs0 (offset + prefixSize) suffixSize + let writeRefs 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) - writePermRefs (i + 2) es - writePermRefs 0 xs + (x : xs) -> do + writePrimArray mrefs i $ indexPrimArray refs0 (offset + x) + writeRefs (i + 1) xs + writeRefs 0 subEs refs <- unsafeFreezePrimArray mrefs pure $ Env 0 refs storage {-# NOINLINE injectEnv #-} @@ -300,55 +367,52 @@ -- | Extract a specific data type from the environment. getEnv - :: forall e es. e :> es + :: forall e es. (HasCallStack, e :> es) => Env es -- ^ The environment. -> IO (EffectRep (DispatchOf e) e) getEnv env = do (i, es) <- getLocation @e env - fromAny <$> readSmallArray es i + fromAnyEffect <$> readSmallArray es i -- | Replace the data type in the environment with a new value (in place). putEnv - :: forall e es. e :> es + :: forall e es. (HasCallStack, e :> es) => Env es -- ^ The environment. -> EffectRep (DispatchOf e) e -> IO () putEnv env e = do (i, es) <- getLocation @e env - writeSmallArray' es i (toAny e) + writeSmallArray' es i (toAnyEffect e) -- | Modify the data type in the environment and return a value (in place). stateEnv - :: forall e es a. e :> es + :: forall e es a. (HasCallStack, e :> es) => Env es -- ^ The environment. - -> (EffectRep (DispatchOf e) e -> IO (a, EffectRep (DispatchOf e) e)) + -> (EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e)) -> IO a stateEnv env f = do (i, es) <- getLocation @e env - (a, e) <- f . fromAny =<< readSmallArray es i - writeSmallArray' es i (toAny e) + (a, e) <- f . fromAnyEffect <$> readSmallArray es i + writeSmallArray' es i (toAnyEffect e) pure a -- | Modify the data type in the environment (in place). modifyEnv - :: forall e es. e :> es + :: forall e es. (HasCallStack, e :> es) => Env es -- ^ The environment. - -> (EffectRep (DispatchOf e) e -> IO (EffectRep (DispatchOf e) e)) + -> (EffectRep (DispatchOf e) e -> (EffectRep (DispatchOf e) e)) -> IO () modifyEnv env f = do (i, es) <- getLocation @e env - e <- f . fromAny =<< readSmallArray es i - writeSmallArray' es i (toAny e) + e <- f . fromAnyEffect <$> readSmallArray es i + writeSmallArray' es i (toAnyEffect e) -- | Determine location of the effect in the environment. getLocation - :: forall e es. e :> es + :: forall e es. (HasCallStack, e :> es) => Env es - -> IO (Int, SmallMutableArray RealWorld Any) + -> IO (Int, SmallMutableArray RealWorld AnyEffect) getLocation (Env offset refs storage) = do - let i = offset + 2 * reifyIndex @e @es - ref = indexPrimArray refs i - version = indexPrimArray refs (i + 1) Storage _ _ vs es _ <- readIORef' storage storageVersion <- readPrimArray vs ref -- If version of the reference is different than version in the storage, it @@ -356,26 +420,32 @@ -- referenced. when (version /= storageVersion) $ do error $ "version (" ++ show version ++ ") /= storageVersion (" - ++ show storageVersion ++ ")" + ++ show storageVersion ++ ")\n" + ++ "If you're attempting to run an unlifting function outside " + ++ "of the scope of effects it captures, have a look at " + ++ "UnliftingStrategy (SeqForkUnlift)." pure (ref, es) + where + Ref ref version = indexPrimArray refs (offset + reifyIndex @e @es) ---------------------------------------- -- Internal helpers -- | Create an empty storage. -emptyStorage :: IO Storage -emptyStorage = Storage 0 (noVersion + 1) +emptyStorage :: HasCallStack => IO Storage +emptyStorage = Storage 0 initialVersion <$> newPrimArray 0 - <*> newSmallArray 0 undefinedData - <*> newSmallArray 0 undefinedData + <*> newSmallArray 0 undefinedEffect + <*> newSmallArray 0 undefinedRelinker -- | Insert an effect into the storage and return its reference. insertEffect - :: IORef' Storage + :: HasCallStack + => IORef' Storage -> EffectRep (DispatchOf e) e -- ^ The representation of the effect. -> Relinker (EffectRep (DispatchOf e)) e - -> IO (Int, Int) + -> IO Ref insertEffect storage e f = do Storage size version vs0 es0 fs0 <- readIORef' storage len0 <- getSizeofSmallMutableArray es0 @@ -383,35 +453,39 @@ GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")" LT -> do 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) + writeSmallArray' es0 size (toAnyEffect e) + writeSmallArray' fs0 size (toAnyRelinker f) + writeIORef' storage $ Storage (size + 1) (bumpVersion version) vs0 es0 fs0 + pure $ Ref size version EQ -> do let len = doubleCapacity len0 vs <- newPrimArray len - es <- newSmallArray len undefinedData - fs <- newSmallArray len undefinedData + es <- newSmallArray len undefinedEffect + fs <- newSmallArray len undefinedRelinker copyMutablePrimArray vs 0 vs0 0 size copySmallMutableArray es 0 es0 0 size copySmallMutableArray fs 0 fs0 0 size 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) + writeSmallArray' es size (toAnyEffect e) + writeSmallArray' fs size (toAnyRelinker f) + writeIORef' storage $ Storage (size + 1) (bumpVersion version) vs es fs + pure $ Ref 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 storage ref = do - Storage size version vs es fs <- readIORef' storage +deleteEffect :: HasCallStack => IORef' Storage -> Ref -> IO () +deleteEffect storage (Ref ref version) = do + Storage size currentVersion 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 + storageVersion <- readPrimArray vs ref + when (version /= storageVersion) $ do + error $ "version (" ++ show version ++ ") /= storageVersion (" + ++ show storageVersion ++ ")\n" + writePrimArray vs ref undefinedVersion + writeSmallArray es ref undefinedEffect + writeSmallArray fs ref undefinedRelinker + writeIORef' storage $ Storage (size - 1) currentVersion vs es fs -- | Relink the environment to use the new storage. relinkEnv :: IORef' Storage -> Env es -> IO (Env es) @@ -421,11 +495,30 @@ doubleCapacity :: Int -> Int doubleCapacity n = max 1 n * 2 -noVersion :: Int -noVersion = 0 +undefinedVersion :: Version +undefinedVersion = Version 0 -undefinedData :: HasCallStack => a -undefinedData = error "undefined data" +initialVersion :: Version +initialVersion = Version 1 + +bumpVersion :: Version -> Version +bumpVersion (Version n) = Version (n + 1) + +undefinedEffect :: HasCallStack => AnyEffect +undefinedEffect = toAnyEffect . errorWithoutStackTrace $ unlines + [ "Undefined effect" + , "Created at: " ++ prettyCallStack callStack + ] + +undefinedRelinker :: HasCallStack => AnyRelinker +undefinedRelinker = toAnyRelinker $ Relinker $ \_ _ -> do + errorWithoutStackTrace $ unlines + [ "Undefined relinker" + , "Created at: " ++ prettyCallStack creationCallStack + , "Called at: " ++ prettyCallStack callStack + ] + where + creationCallStack = callStack -- | A strict version of 'writeSmallArray'. writeSmallArray' :: SmallMutableArray RealWorld a -> Int -> a -> IO () diff --git a/src/Effectful/Internal/Monad.hs b/src/Effectful/Internal/Monad.hs --- a/src/Effectful/Internal/Monad.hs +++ b/src/Effectful/Internal/Monad.hs @@ -50,6 +50,7 @@ -- ** Low-level unlifts , seqUnliftIO + , seqForkUnliftIO , concUnliftIO -- * Dispatch @@ -73,16 +74,10 @@ , stateStaticRep , stateStaticRepM , localStaticRep - - -- *** Primitive operations - , consEnv - , getEnv - , putEnv - , stateEnv - , modifyEnv ) where import Control.Applicative +import Control.Concurrent (myThreadId) import Control.Exception qualified as E import Control.Monad import Control.Monad.Base @@ -124,12 +119,12 @@ -- -- - Allows the effects to be handled in any order. newtype Eff (es :: [Effect]) a = Eff (Env es -> IO a) - deriving (Monoid, Semigroup) + deriving newtype (Monoid, Semigroup) -- | Run a pure 'Eff' computation. -- -- For running computations with side effects see 'runEff'. -runPureEff :: Eff '[] a -> a +runPureEff :: HasCallStack => Eff '[] a -> a runPureEff (Eff m) = -- unsafeDupablePerformIO is safe here since IOE was not on the stack, so no -- IO with side effects was performed (unless someone sneakily introduced side @@ -144,7 +139,7 @@ -- | Peel off the constructor of 'Eff'. unEff :: Eff es a -> Env es -> IO a -unEff = \(Eff m) -> m +unEff (Eff m) = m -- | Access the underlying 'IO' monad along with the environment. -- @@ -188,7 +183,8 @@ => ((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 +withSeqEffToIO k = unsafeEff $ \es -> seqUnliftIO es k +{-# INLINE withSeqEffToIO #-} -- | Create an unlifting function with the given strategy. -- @@ -202,6 +198,7 @@ -> Eff es a withEffToIO strategy k = case strategy of SeqUnlift -> unsafeEff $ \es -> seqUnliftIO es k + SeqForkUnlift -> unsafeEff $ \es -> seqForkUnliftIO es k ConcUnlift p b -> unsafeEff $ \es -> concUnliftIO es p b k {-# INLINE withEffToIO #-} @@ -215,8 +212,8 @@ -> ((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 +withConcEffToIO persistence limit k = unsafeEff $ \es -> + concUnliftIO es persistence limit k {-# DEPRECATED withConcEffToIO "Use withEffToIO with the appropriate strategy." #-} -- | Create an unlifting function with the 'SeqUnlift' strategy. @@ -227,8 +224,27 @@ -> ((forall r. Eff es r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> IO a -seqUnliftIO es k = seqUnlift k es unEff +seqUnliftIO es k = do + tid0 <- myThreadId + k $ \m -> do + tid <- myThreadId + if tid `eqThreadId` tid0 + then unEff m es + else error + $ "If you want to use the unlifting function to run Eff computations " + ++ "in multiple threads, have a look at UnliftStrategy (ConcUnlift)." +-- | Create an unlifting function with the 'SeqForkUnlift' strategy. +seqForkUnliftIO + :: HasCallStack + => Env es + -- ^ The environment. + -> ((forall r. Eff es r -> IO r) -> IO a) + -- ^ Continuation with the unlifting function in scope. + -> IO a +seqForkUnliftIO es0 k = cloneEnv es0 >>= \es -> seqUnliftIO es k +{-# INLINE seqForkUnliftIO #-} + -- | Create an unlifting function with the 'ConcUnlift' strategy. concUnliftIO :: HasCallStack @@ -239,7 +255,10 @@ -> ((forall r. Eff es r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> IO a -concUnliftIO es persistence limit k = concUnlift persistence limit k es unEff +concUnliftIO es Ephemeral (Limited uses) = ephemeralConcUnlift es uses +concUnliftIO es Ephemeral Unlimited = ephemeralConcUnlift es maxBound +concUnliftIO es Persistent (Limited threads) = persistentConcUnlift es False threads +concUnliftIO es Persistent Unlimited = persistentConcUnlift es True maxBound ---------------------------------------- -- Base @@ -279,7 +298,7 @@ -- | @since 2.2.0.0 instance NonDet :> es => Alternative (Eff es) where - empty = withFrozenCallStack (send Empty) + empty = send Empty a <|> b = send (a :<|>: b) -- | @since 2.2.0.0 @@ -321,7 +340,7 @@ type instance DispatchOf Fail = Dynamic instance Fail :> es => MonadFail (Eff es) where - fail msg = withFrozenCallStack $ send (Fail msg) + fail msg = send (Fail msg) ---------------------------------------- -- IO @@ -339,7 +358,7 @@ -- | Run an 'Eff' computation with side effects. -- -- For running pure computations see 'runPureEff'. -runEff :: Eff '[IOE] a -> IO a +runEff :: HasCallStack => Eff '[IOE] a -> IO a runEff m = unEff m =<< consEnv (IOE SeqUnlift) dummyRelinker =<< emptyEnv instance IOE :> es => MonadIO (Eff es) where @@ -387,7 +406,7 @@ data PrimStateEff -- | Run an 'Eff' computation with primitive state-transformer actions. -runPrim :: IOE :> es => Eff (Prim : es) a -> Eff es a +runPrim :: (HasCallStack, IOE :> es) => Eff (Prim : es) a -> Eff es a runPrim = evalStaticRep Prim instance Prim :> es => PrimMonad (Eff es) where @@ -411,23 +430,23 @@ -> ((forall r. Eff (e : es) r -> Eff es r) -> Eff es a) -- ^ Continuation with the unlifting function in scope. -> Eff (e : es) a -raiseWith strategy k = case strategy of - SeqUnlift -> unsafeEff $ \ees -> do - es <- tailEnv ees - seqUnliftIO ees $ \unlift -> do +raiseWith strategy k = unsafeEff $ \ees -> do + es <- tailEnv ees + case strategy of + SeqUnlift -> seqUnliftIO ees $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift - ConcUnlift p l -> unsafeEff $ \ees -> do - es <- tailEnv ees - concUnliftIO ees p l $ \unlift -> do + SeqForkUnlift -> seqForkUnliftIO ees $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift + ConcUnlift p l -> concUnliftIO ees p l $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift {-# INLINE raiseWith #-} -- | Eliminate a duplicate effect from the top of the effect stack. subsume :: e :> es => Eff (e : es) a -> Eff es a 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@. +-- | Allow for running an effect stack @subEs@ within @es@ as long as @subEs@ is +-- a permutation (with possible duplicates) of a subset of @es@. -- -- Generalizes 'raise' and 'subsume'. -- @@ -476,7 +495,7 @@ -- ... -- ...Couldn't match type ‘es1’ with ‘es2’ -- ... -inject :: Subset xs es => Eff xs a -> Eff es a +inject :: Subset subEs es => Eff subEs a -> Eff es a inject m = unsafeEff $ \es -> unEff m =<< injectEnv es ---------------------------------------- @@ -494,13 +513,13 @@ newtype LocalEnv (localEs :: [Effect]) (handlerEs :: [Effect]) = LocalEnv (Env localEs) -- | Type signature of the effect handler. -type EffectHandler e es +type EffectHandler (e :: Effect) (es :: [Effect]) = forall a localEs. (HasCallStack, e :> localEs) => LocalEnv localEs es -- ^ Capture of the local environment for handling local 'Eff' computations -- when @e@ is a higher order effect. -> e (Eff localEs) a - -- ^ The effect performed in the local environment. + -- ^ The operation. -> Eff es a -- | An internal representation of dynamically dispatched effects, i.e. the @@ -515,7 +534,11 @@ 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 +runHandler + :: (HasCallStack, DispatchOf e ~ Dynamic) + => Handler e + -> Eff (e : es) a + -> Eff es a runHandler e m = unsafeEff $ \es0 -> do inlineBracket (consEnv e relinkHandler es0) @@ -553,7 +576,7 @@ -- | Run a statically dispatched effect with the given initial representation -- and return the final value along with the final representation. runStaticRep - :: (DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es) + :: (HasCallStack, DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es) => StaticRep e -- ^ The initial representation. -> Eff (e : es) a -> Eff es (a, StaticRep e) @@ -566,7 +589,7 @@ -- | Run a statically dispatched effect with the given initial representation -- and return the final value, discarding the final representation. evalStaticRep - :: (DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es) + :: (HasCallStack, DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es) => StaticRep e -- ^ The initial representation. -> Eff (e : es) a -> Eff es a @@ -579,7 +602,7 @@ -- | Run a statically dispatched effect with the given initial representation -- and return the final representation, discarding the final value. execStaticRep - :: (DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es) + :: (HasCallStack, DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es) => StaticRep e -- ^ The initial representation. -> Eff (e : es) a -> Eff es (StaticRep e) @@ -590,42 +613,48 @@ (\es -> unEff m es *> getEnv es) -- | Fetch the current representation of the effect. -getStaticRep :: (DispatchOf e ~ Static sideEffects, e :> es) => Eff es (StaticRep e) +getStaticRep + :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es) + => Eff es (StaticRep e) getStaticRep = unsafeEff $ \es -> getEnv es -- | Set the current representation of the effect to the given value. -putStaticRep :: (DispatchOf e ~ Static sideEffects, e :> es) => StaticRep e -> Eff es () +putStaticRep + :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es) + => StaticRep e -> Eff es () putStaticRep s = unsafeEff $ \es -> putEnv es s -- | Apply the function to the current representation of the effect and return a -- value. stateStaticRep - :: (DispatchOf e ~ Static sideEffects, e :> es) + :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es) => (StaticRep e -> (a, StaticRep e)) -- ^ The function to modify the representation. -> Eff es a -stateStaticRep f = unsafeEff $ \es -> stateEnv es (pure . f) +stateStaticRep f = unsafeEff $ \es -> stateEnv es f -- | Apply the monadic function to the current representation of the effect and -- return a value. stateStaticRepM - :: (DispatchOf e ~ Static sideEffects, e :> es) + :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es) => (StaticRep e -> Eff es (a, StaticRep e)) -- ^ The function to modify the representation. -> Eff es a stateStaticRepM f = unsafeEff $ \es -> E.mask $ \unmask -> do - stateEnv es $ unmask . (`unEff` es) . f + (a, e) <- unmask . (`unEff` es) . f =<< getEnv es + putEnv es e + pure a -- | Execute a computation with a temporarily modified representation of the -- effect. localStaticRep - :: (DispatchOf e ~ Static sideEffects, e :> es) + :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es) => (StaticRep e -> StaticRep e) -- ^ The function to temporarily modify the representation. -> Eff es a -> Eff es a localStaticRep f m = unsafeEff $ \es -> do inlineBracket - (stateEnv es $ \s -> pure (s, f s)) + (stateEnv es $ \s -> (s, f s)) (\s -> putEnv es s) (\_ -> unEff m es) diff --git a/src/Effectful/Internal/Unlift.hs b/src/Effectful/Internal/Unlift.hs --- a/src/Effectful/Internal/Unlift.hs +++ b/src/Effectful/Internal/Unlift.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MagicHash #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-} -- | Implementation of sequential and concurrent unlifts. @@ -12,12 +13,14 @@ , Limit(..) -- * Unlifting functions - , seqUnlift - , concUnlift + , ephemeralConcUnlift + , persistentConcUnlift ) where import Control.Concurrent +import Control.Concurrent.MVar.Strict import Control.Monad +import Data.Coerce import Data.IntMap.Strict qualified as IM import GHC.Conc.Sync (ThreadId(..)) import GHC.Exts (mkWeak#, mkWeakNoFinalizer#) @@ -41,11 +44,59 @@ -- ^ The sequential strategy is the fastest and a default setting for -- t'Effectful.IOE'. Any attempt of calling the unlifting function in threads -- distinct from its creator will result in a runtime error. + | SeqForkUnlift + -- ^ Like 'SeqUnlift', but all unlifted actions will be executed in a cloned + -- environment. + -- + -- The main consequence is that thread local state is forked at the point of + -- creation of the unlifting function and its modifications in unlifted + -- actions will not affect the main thread of execution (and vice versa): + -- + -- >>> import Effectful + -- >>> import Effectful.State.Dynamic + -- >>> :{ + -- action :: (IOE :> es, State Int :> es) => Eff es () + -- action = do + -- modify @Int (+1) + -- withEffToIO SeqForkUnlift $ \unlift -> unlift $ modify @Int (+2) + -- modify @Int (+4) + -- :} + -- + -- >>> runEff . execStateLocal @Int 0 $ action + -- 5 + -- + -- >>> runEff . execStateShared @Int 0 $ action + -- 7 + -- + -- Because of this it's possible to safely use the unlifting function outside + -- of the scope of effects it captures, e.g. by creating an @IO@ action that + -- executes effectful operations and running it later: + -- + -- >>> :{ + -- delayed :: UnliftStrategy -> IO (IO String) + -- delayed strategy = runEff . evalStateLocal "Hey" $ do + -- r <- withEffToIO strategy $ \unlift -> pure $ unlift get + -- modify (++ "!!!") + -- pure r + -- :} + -- + -- This doesn't work with the 'SeqUnlift' strategy because when the returned + -- action runs, @State@ is no longer in scope: + -- + -- >>> join $ delayed SeqUnlift + -- *** Exception: version (...) /= storageVersion (0) + -- ... + -- + -- However, it does with the 'SeqForkUnlift' strategy: + -- + -- >>> join $ delayed SeqForkUnlift + -- "Hey" + -- | ConcUnlift !Persistence !Limit -- ^ The concurrent strategy makes it possible for the unlifting function to -- be called in threads distinct from its creator. See 'Persistence' and -- 'Limit' settings for more information. - deriving (Eq, Generic, Ord, Show) + deriving stock (Eq, Generic, Ord, Show) -- | Persistence setting for the 'ConcUnlift' strategy. -- @@ -65,7 +116,7 @@ | Persistent -- ^ Persist the environment between calls to the unlifting function within a -- particular thread. - deriving (Eq, Generic, Ord, Show) + deriving stock (Eq, Generic, Ord, Show) -- | Limit setting for the 'ConcUnlift' strategy. data Limit @@ -84,60 +135,21 @@ -- when called in @N@ threads and @K+1@ copies when called in @K < N@ threads. | Unlimited -- ^ Unlimited use of the unlifting function. - deriving (Eq, Generic, Ord, Show) + deriving stock (Eq, Generic, Ord, Show) ---------------------------------------- -- Unlift functions --- | Sequential unlift. -seqUnlift - :: HasCallStack - => ((forall r. m r -> IO r) -> IO a) - -> Env es - -> (forall r. m r -> Env es -> IO r) - -> IO a -seqUnlift k es unEff = do - tid0 <- myThreadId - k $ \m -> do - tid <- myThreadId - if tid `eqThreadId` tid0 - then unEff m es - else error - $ "If you want to use the unlifting function to run Eff computations " - ++ "in multiple threads, have a look at UnliftStrategy (ConcUnlift)." - --- | Concurrent unlift. -concUnlift - :: HasCallStack - => Persistence - -> Limit - -> ((forall r. m r -> IO r) -> IO a) - -> Env es - -> (forall r. m r -> Env es -> IO r) - -> IO a -concUnlift Ephemeral (Limited uses) k = - ephemeralConcUnlift uses k -concUnlift Ephemeral Unlimited k = - ephemeralConcUnlift maxBound k -concUnlift Persistent (Limited threads) k = - persistentConcUnlift False threads k -concUnlift Persistent Unlimited k = - persistentConcUnlift True maxBound k - ----------------------------------------- --- Internal - -- | Concurrent unlift that doesn't preserve the environment between calls to -- the unlifting function in threads other than its creator. ephemeralConcUnlift - :: HasCallStack - => Int + :: (HasCallStack, forall r. Coercible (m r) (Env es -> IO r)) + => Env es + -> Int -- ^ Number of permitted uses of the unlift function. -> ((forall r. m r -> IO r) -> IO a) - -> Env es - -> (forall r. m r -> Env es -> IO r) -> IO a -ephemeralConcUnlift uses k es0 unEff = do +ephemeralConcUnlift es0 uses k = do unless (uses > 0) $ do error $ "Invalid number of uses: " ++ show uses tid0 <- myThreadId @@ -158,21 +170,20 @@ n -> do es <- cloneEnv esTemplate pure (n - 1, es) - unEff m es + coerce m es {-# NOINLINE ephemeralConcUnlift #-} -- | Concurrent unlift that preserves the environment between calls to the -- unlifting function within a particular thread. persistentConcUnlift - :: HasCallStack - => Bool + :: (HasCallStack, forall r. Coercible (m r) (Env es -> IO r)) + => Env es + -> Bool -> Int -- ^ Number of threads that are allowed to use the unlift function. -> ((forall r. m r -> IO r) -> IO a) - -> Env es - -> (forall r. m r -> Env es -> IO r) -> IO a -persistentConcUnlift cleanUp threads k es0 unEff = do +persistentConcUnlift es0 cleanUp threads k = do unless (threads > 0) $ do error $ "Invalid number of threads: " ++ show threads tid0 <- myThreadId @@ -211,14 +222,14 @@ , teEntries = addThreadData wkTid i wkTidEs $ teEntries te } pure (newEntries, es) - unEff m es + coerce m es {-# NOINLINE persistentConcUnlift #-} ---------------------------------------- -- Data types newtype EntryId = EntryId Int - deriving Eq + deriving newtype Eq newEntryId :: EntryId newEntryId = EntryId 0 @@ -295,7 +306,7 @@ ---------------------------------------- deleteThreadData :: Int -> EntryId -> MVar' (ThreadEntries es) -> IO () -deleteThreadData wkTid i v = modifyMVar_' v $ \te -> do +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 diff --git a/src/Effectful/Internal/Utils.hs b/src/Effectful/Internal/Utils.hs --- a/src/Effectful/Internal/Utils.hs +++ b/src/Effectful/Internal/Utils.hs @@ -14,20 +14,6 @@ , toAny , fromAny - -- * Strict 'IORef' - , IORef' - , newIORef' - , readIORef' - , writeIORef' - - -- * Strict 'MVar' - , MVar' - , toMVar' - , newMVar' - , readMVar' - , modifyMVar' - , modifyMVar_' - -- * Unique , Unique , newUnique @@ -36,9 +22,7 @@ , thawCallStack ) where -import Control.Concurrent.MVar import Control.Exception -import Data.IORef import Data.Primitive.ByteArray import GHC.Conc.Sync (ThreadId(..)) import GHC.Exts (Any, RealWorld) @@ -125,49 +109,6 @@ 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) - -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) - deriving Eq - -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) - -modifyMVar_' :: MVar' a -> (a -> IO a) -> IO () -modifyMVar_' (MVar' var) action = modifyMVar_ var $ \a0 -> do - a <- action a0 - a `seq` pure a ---------------------------------------- diff --git a/src/Effectful/Labeled.hs b/src/Effectful/Labeled.hs --- a/src/Effectful/Labeled.hs +++ b/src/Effectful/Labeled.hs @@ -1,14 +1,13 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE PolyKinds #-} -- | Labeled effects. -- +-- Any effect can be assigned multiple labels so you have more than one +-- available simultaneously. +-- -- @since 2.3.0.0 module Effectful.Labeled - ( -- * Example - -- $example - - -- * Effect - Labeled + ( -- * Effect + Labeled(..) -- ** Handlers , runLabeled @@ -22,58 +21,49 @@ import Effectful import Effectful.Dispatch.Static --- $example +-- | Assign a label to an effect. -- --- An effect can be assigned multiple labels and you can have all of them --- available at the same time. +-- The constructor is for sending labeled operations of a dynamically dispatched +-- effect to the handler: -- --- >>> import Effectful.Reader.Static +-- >>> import Effectful.Dispatch.Dynamic -- -- >>> :{ --- action --- :: ( Labeled "a" (Reader String) :> es --- , Labeled "b" (Reader String) :> es --- , Reader String :> es --- ) --- => Eff es String --- action = do --- a <- labeled @"b" @(Reader String) $ do --- labeled @"a" @(Reader String) $ do --- ask --- b <- labeled @"b" @(Reader String) $ do --- ask --- pure $ a ++ b +-- data X :: Effect where +-- X :: X m Int +-- type instance DispatchOf X = Dynamic -- :} -- -- >>> :{ --- runPureEff @String --- . runLabeled @"a" (runReader "a") --- . runLabeled @"b" (runReader "b") --- . runReader "c" --- $ action +-- runPureEff . runLabeled @"x" (interpret_ $ \X -> pure 333) $ do +-- send $ Labeled @"x" X -- :} --- "ab" - --- | Assign a label to an effect. -data Labeled (label :: k) (e :: Effect) :: Effect +-- 333 +-- +newtype Labeled (label :: k) (e :: Effect) :: Effect where + -- | @since 2.4.0.0 + Labeled :: forall label e m a. e m a -> Labeled label e m a -type instance DispatchOf (Labeled label e) = Static NoSideEffects +type instance DispatchOf (Labeled label e) = DispatchOf e data instance StaticRep (Labeled label e) -- | Run a 'Labeled' effect with a given effect handler. runLabeled :: forall label e es a b - . (Eff (e : es) a -> Eff es b) + . HasCallStack + => (Eff (e : es) a -> Eff es b) -- ^ The effect handler. -> Eff (Labeled label e : es) a -> Eff es b runLabeled runE m = runE (fromLabeled m) --- | Bring an effect into scope to be able to run its operations. +-- | Bring an effect into scope without a label. +-- +-- Useful for running code written with the non-labeled effect in mind. labeled :: forall label e es a - . Labeled label e :> es + . (HasCallStack, Labeled label e :> es) => Eff (e : es) a -- ^ The action using the effect. -> Eff es a diff --git a/src/Effectful/Labeled/Error.hs b/src/Effectful/Labeled/Error.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Labeled/Error.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | Convenience functions for the 'Labeled' 'Error' effect. +-- +-- @since 2.4.0.0 +module Effectful.Labeled.Error + ( -- * Effect + Error(..) + + -- ** Handlers + , runError + , runErrorWith + , runErrorNoCallStack + , runErrorNoCallStackWith + + -- ** Operations + , throwErrorWith + , throwError + , throwError_ + , catchError + , handleError + , tryError + + -- * Re-exports + , E.HasCallStack + , E.CallStack + , E.getCallStack + , E.prettyCallStack + ) where + +import GHC.Stack (withFrozenCallStack) + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Labeled +import Effectful.Error.Dynamic (Error(..)) +import Effectful.Error.Dynamic qualified as E + +-- | Handle errors of type @e@ (via "Effectful.Error.Static"). +runError + :: forall label e es a + . HasCallStack + => Eff (Labeled label (Error e) : es) a + -> Eff es (Either (E.CallStack, e) a) +runError = runLabeled @label E.runError + +-- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific +-- error handler. +runErrorWith + :: forall label e es a + . HasCallStack + => (E.CallStack -> e -> Eff es a) + -- ^ The error handler. + -> Eff (Labeled label (Error e) : es) a + -> Eff es a +runErrorWith = runLabeled @label . E.runErrorWith + +-- | Handle errors of type @e@ (via "Effectful.Error.Static"). In case of an +-- error discard the 'E.CallStack'. +runErrorNoCallStack + :: forall label e es a + . HasCallStack + => Eff (Labeled label (Error e) : es) a + -> Eff es (Either e a) +runErrorNoCallStack = runLabeled @label E.runErrorNoCallStack + +-- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific +-- error handler. In case of an error discard the 'CallStack'. +runErrorNoCallStackWith + :: forall label e es a + . HasCallStack + => (e -> Eff es a) + -- ^ The error handler. + -> Eff (Labeled label (Error e) : es) a + -> Eff es a +runErrorNoCallStackWith = runLabeled @label . E.runErrorNoCallStackWith + +-- | Throw an error of type @e@ and specify a display function in case a +-- third-party code catches the internal exception and 'show's it. +throwErrorWith + :: forall label e es a + . (HasCallStack, Labeled label (Error e) :> es) + => (e -> String) + -- ^ The display function. + -> e + -- ^ The error. + -> Eff es a +throwErrorWith display = + withFrozenCallStack send . Labeled @label . ThrowErrorWith display + +-- | Throw an error of type @e@ with 'show' as a display function. +throwError + :: forall label e es a + . (HasCallStack, Labeled label (Error e) :> es, Show e) + => e + -- ^ The error. + -> Eff es a +throwError = withFrozenCallStack (throwErrorWith @label) show + +-- | Throw an error of type @e@ with no display function. +throwError_ + :: forall label e es a + . (HasCallStack, Labeled label (Error e) :> es) + => e + -- ^ The error. + -> Eff es a +throwError_ = withFrozenCallStack (throwErrorWith @label) (const "") + +-- | Handle an error of type @e@. +catchError + :: forall label e es a + . (HasCallStack, Labeled label (Error e) :> es) + => Eff es a + -- ^ The inner computation. + -> (E.CallStack -> e -> Eff es a) + -- ^ A handler for errors in the inner computation. + -> Eff es a +catchError m = send . Labeled @label . CatchError m + +-- | The same as @'flip' 'catchError'@, which is useful in situations where the +-- code for the handler is shorter. +handleError + :: forall label e es a + . (HasCallStack, Labeled label (Error e) :> es) + => (E.CallStack -> e -> Eff es a) + -- ^ A handler for errors in the inner computation. + -> Eff es a + -- ^ The inner computation. + -> Eff es a +handleError = flip (catchError @label) + +-- | Similar to 'catchError', but returns an 'Either' result which is a 'Right' +-- if no error was thrown and a 'Left' otherwise. +tryError + :: forall label e es a + . (HasCallStack, Labeled label (Error e) :> es) + => Eff es a + -- ^ The inner computation. + -> Eff es (Either (E.CallStack, e) a) +tryError m = catchError @label (Right <$> m) (\es e -> pure $ Left (es, e)) diff --git a/src/Effectful/Labeled/Reader.hs b/src/Effectful/Labeled/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Labeled/Reader.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | Convenience functions for the 'Labeled' 'Reader' effect. +-- +-- @since 2.4.0.0 +module Effectful.Labeled.Reader + ( -- * Effect + Reader(..) + + -- ** Handlers + , runReader + + -- ** Operations + , ask + , asks + , local + ) where + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Labeled +import Effectful.Reader.Dynamic (Reader(..)) +import Effectful.Reader.Dynamic qualified as R + +-- | Run the 'Reader' effect with the given initial environment (via +-- "Effectful.Reader.Static"). +runReader + :: forall label r es a + . HasCallStack + => r + -- ^ The initial environment. + -> Eff (Labeled label (Reader r) : es) a + -> Eff es a +runReader = runLabeled @label . R.runReader + +---------------------------------------- +-- Operations + +-- | Fetch the value of the environment. +ask + :: forall label r es + . (HasCallStack, Labeled label (Reader r) :> es) + => Eff es r +ask = send $ Labeled @label Ask + +-- | Retrieve a function of the current environment. +-- +-- @'asks' f ≡ f '<$>' 'ask'@ +asks + :: forall label r es a + . (HasCallStack, Labeled label (Reader r) :> es) + => (r -> a) + -- ^ The function to apply to the environment. + -> Eff es a +asks f = f <$> ask @label + +-- | Execute a computation in a modified environment. +-- +-- @'runReader' r ('local' f m) ≡ 'runReader' (f r) m@ +-- +local + :: forall label r es a + . (HasCallStack, Labeled label (Reader r) :> es) + => (r -> r) + -- ^ The function to modify the environment. + -> Eff es a + -> Eff es a +local f = send . Labeled @label . Local f diff --git a/src/Effectful/Labeled/State.hs b/src/Effectful/Labeled/State.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Labeled/State.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | Convenience functions for the 'Labeled' 'State' effect. +-- +-- @since 2.4.0.0 +module Effectful.Labeled.State + ( -- * Effect + State(..) + + -- ** Handlers + + -- *** Local + , runStateLocal + , evalStateLocal + , execStateLocal + + -- *** Shared + , runStateShared + , evalStateShared + , execStateShared + + -- ** Operations + , get + , gets + , put + , state + , modify + , stateM + , modifyM + ) where + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Labeled +import Effectful.State.Dynamic (State(..)) +import Effectful.State.Dynamic qualified as S + +---------------------------------------- +-- Local + +-- | Run the 'State' effect with the given initial state and return the final +-- value along with the final state (via "Effectful.State.Static.Local"). +runStateLocal + :: forall label s es a + . HasCallStack + => s + -- ^ The initial state. + -> Eff (Labeled label (State s) : es) a + -> Eff es (a, s) +runStateLocal = runLabeled @label . S.runStateLocal + +-- | Run the 'State' effect with the given initial state and return the final +-- value, discarding the final state (via "Effectful.State.Static.Local"). +evalStateLocal + :: forall label s es a + . HasCallStack + => s + -- ^ The initial state. + -> Eff (Labeled label (State s) : es) a + -> Eff es a +evalStateLocal = runLabeled @label . S.evalStateLocal + +-- | Run the 'State' effect with the given initial state and return the final +-- state, discarding the final value (via "Effectful.State.Static.Local"). +execStateLocal + :: forall label s es a + . HasCallStack + => s + -- ^ The initial state. + -> Eff (Labeled label (State s) : es) a + -> Eff es s +execStateLocal = runLabeled @label . S.execStateLocal + +---------------------------------------- +-- Shared + +-- | Run the 'State' effect with the given initial state and return the final +-- value along with the final state (via "Effectful.State.Static.Shared"). +runStateShared + :: forall label s es a + . HasCallStack + => s + -- ^ The initial state. + -> Eff (Labeled label (State s) : es) a + -> Eff es (a, s) +runStateShared = runLabeled @label . S.runStateShared + +-- | Run the 'State' effect with the given initial state and return the final +-- value, discarding the final state (via "Effectful.State.Static.Shared"). +evalStateShared + :: forall label s es a + . HasCallStack + => s + -- ^ The initial state. + -> Eff (Labeled label (State s) : es) a + -> Eff es a +evalStateShared = runLabeled @label . S.evalStateShared + +-- | Run the 'State' effect with the given initial state and return the final +-- state, discarding the final value (via "Effectful.State.Static.Shared"). +execStateShared + :: forall label s es a + . HasCallStack + => s + -- ^ The initial state. + -> Eff (Labeled label (State s) : es) a + -> Eff es s +execStateShared = runLabeled @label . S.execStateShared + +---------------------------------------- +-- Operations + +-- | Fetch the current value of the state. +get + :: forall label s es + . (HasCallStack, Labeled label (State s) :> es) + => Eff es s +get = send $ Labeled @label Get + +-- | Get a function of the current state. +-- +-- @'gets' f ≡ f '<$>' 'get'@ +gets + :: forall label s es a + . (HasCallStack, Labeled label (State s) :> es) + => (s -> a) + -- ^ . + -> Eff es a +gets f = f <$> get @label + +-- | Set the current state to the given value. +put + :: forall label s es + . (HasCallStack, Labeled label (State s) :> es) + => s + -- ^ . + -> Eff es () +put = send . Labeled @label . Put + +-- | Apply the function to the current state and return a value. +state + :: forall label s es a + . (HasCallStack, Labeled label (State s) :> es) + => (s -> (a, s)) + -- ^ . + -> Eff es a +state = send . Labeled @label . State + +-- | Apply the function to the current state. +-- +-- @'modify' f ≡ 'state' (\\s -> ((), f s))@ +modify + :: forall label s es + . (HasCallStack, Labeled label (State s) :> es) + => (s -> s) + -- ^ . + -> Eff es () +modify f = state @label (\s -> ((), f s)) + +-- | Apply the monadic function to the current state and return a value. +stateM + :: forall label s es a + . (HasCallStack, Labeled label (State s) :> es) + => (s -> Eff es (a, s)) + -- ^ . + -> Eff es a +stateM = send . Labeled @label . StateM + +-- | Apply the monadic function to the current state. +-- +-- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@ +modifyM + :: forall label s es + . (HasCallStack, Labeled label (State s) :> es) + => (s -> Eff es s) + -- ^ . + -> Eff es () +modifyM f = stateM @label (\s -> ((), ) <$> f s) diff --git a/src/Effectful/Labeled/Writer.hs b/src/Effectful/Labeled/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Labeled/Writer.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | Convenience functions for the 'Labeled' 'Writer' effect. +-- +-- @since 2.4.0.0 +module Effectful.Labeled.Writer + ( -- * Effect + Writer(..) + + -- ** Handlers + + -- *** Local + , runWriterLocal + , execWriterLocal + + -- *** Shared + , runWriterShared + , execWriterShared + + -- * Operations + , tell + , listen + , listens + ) where + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Labeled +import Effectful.Writer.Dynamic (Writer(..)) +import Effectful.Writer.Dynamic qualified as W + +---------------------------------------- +-- Local + +-- | Run the 'Writer' effect and return the final value along with the final +-- output (via "Effectful.Writer.Static.Local"). +runWriterLocal + :: forall label w es a + . (HasCallStack, Monoid w) + => Eff (Labeled label (Writer w) : es) + a -> Eff es (a, w) +runWriterLocal = runLabeled @label W.runWriterLocal + +-- | Run a 'Writer' effect and return the final output, discarding the final +-- value (via "Effectful.Writer.Static.Local"). +execWriterLocal + :: forall label w es a + . (HasCallStack, Monoid w) + => Eff (Labeled label (Writer w) : es) a + -> Eff es w +execWriterLocal = runLabeled @label W.execWriterLocal + +---------------------------------------- +-- Shared + +-- | Run the 'Writer' effect and return the final value along with the final +-- output (via "Effectful.Writer.Static.Shared"). +runWriterShared + :: forall label w es a + . (HasCallStack, Monoid w) + => Eff (Labeled label (Writer w) : es) a + -> Eff es (a, w) +runWriterShared = runLabeled @label W.runWriterShared + +-- | Run the 'Writer' effect and return the final output, discarding the final +-- value (via "Effectful.Writer.Static.Shared"). +execWriterShared + :: forall label w es a + . (HasCallStack, Monoid w) + => Eff (Labeled label (Writer w) : es) a + -> Eff es w +execWriterShared = runLabeled @label W.execWriterShared + +---------------------------------------- +-- Operations + +-- | Append the given output to the overall output of the 'Writer'. +tell + :: forall label w es + . (HasCallStack, Labeled label (Writer w) :> es) + => w + -> Eff es () +tell = send . Labeled @label . Tell + +-- | Execute an action and append its output to the overall output of the +-- 'Writer'. +listen + :: forall label w es a + . (HasCallStack, Labeled label (Writer w) :> es) + => Eff es a + -> Eff es (a, w) +listen = send . Labeled @label . Listen + +-- | 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 +-- output. +-- +-- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@ +listens + :: forall label w es a b + . (HasCallStack, Labeled label (Writer w) :> es) + => (w -> b) + -> Eff es a + -> Eff es (a, b) +listens f m = do + (a, w) <- listen @label m + pure (a, f w) diff --git a/src/Effectful/NonDet.hs b/src/Effectful/NonDet.hs --- a/src/Effectful/NonDet.hs +++ b/src/Effectful/NonDet.hs @@ -40,9 +40,14 @@ -- -- @since 2.2.0.0 data OnEmptyPolicy - = OnEmptyKeep -- ^ Keep modifications on 'Empty'. - | OnEmptyRollback -- ^ Rollback modifications on 'Empty'. - deriving (Eq, Generic, Ord, Show) + = OnEmptyKeep + -- ^ Keep modifications on 'Empty'. + | OnEmptyRollback + -- ^ Rollback modifications on 'Empty'. + -- + -- /Note:/ state modifications are rolled back on 'Empty' only. In particular, + -- they are __not__ rolled back on exceptions. + deriving stock (Eq, Generic, Ord, Show) -- | Run the 'NonDet' effect with a given 'OnEmptyPolicy'. -- @@ -50,33 +55,52 @@ -- computation calls 'Empty'. -- -- @since 2.2.0.0 -runNonDet :: OnEmptyPolicy -> Eff (NonDet : es) a -> Eff es (Either CallStack a) +runNonDet + :: HasCallStack + => OnEmptyPolicy + -> Eff (NonDet : es) a + -> Eff es (Either CallStack a) runNonDet = \case OnEmptyKeep -> runNonDetKeep OnEmptyRollback -> runNonDetRollback -runNonDetKeep :: Eff (NonDet : es) a -> Eff es (Either CallStack a) -runNonDetKeep = reinterpret (fmap noError . runError @()) $ \env -> \case - Empty -> throwError () +runNonDetKeep + :: HasCallStack + => Eff (NonDet : es) a + -> Eff es (Either CallStack a) +runNonDetKeep = reinterpret (fmap noError . runError @ErrorEmpty) $ \env -> \case + Empty -> throwError ErrorEmpty m1 :<|>: m2 -> localSeqUnlift env $ \unlift -> do - mr <- (Just <$> unlift m1) `catchError` \_ () -> pure Nothing + mr <- (Just <$> unlift m1) `catchError` \_ ErrorEmpty -> pure Nothing case mr of Just r -> pure r Nothing -> unlift m2 -runNonDetRollback :: Eff (NonDet : es) a -> Eff es (Either CallStack a) -runNonDetRollback = reinterpret (fmap noError . runError @()) $ \env -> \case - Empty -> throwError () +runNonDetRollback + :: HasCallStack + => Eff (NonDet : es) a + -> Eff es (Either CallStack a) +runNonDetRollback = reinterpret setup $ \env -> \case + Empty -> throwError ErrorEmpty m1 :<|>: m2 -> do backupEnv <- cloneLocalEnv env localSeqUnlift env $ \unlift -> do - mr <- (Just <$> unlift m1) `catchError` \_ () -> do + mr <- (Just <$> unlift m1) `catchError` \_ ErrorEmpty -> do -- If m1 failed, roll back the environment. restoreLocalEnv env backupEnv pure Nothing case mr of Just r -> pure r Nothing -> unlift m2 + where + setup action = do + backupEs <- unsafeEff cloneEnv + runError @ErrorEmpty action >>= \case + Right r -> pure $ Right r + Left (cs, _) -> do + -- If the whole action failed, roll back the environment. + unsafeEff $ \es -> restoreEnv es backupEs + pure $ Left cs ---------------------------------------- @@ -85,7 +109,7 @@ -- -- @since 2.2.0.0 emptyEff :: (HasCallStack, NonDet :> es) => Eff es a -emptyEff = withFrozenCallStack $ send Empty +emptyEff = withFrozenCallStack send Empty -- | Specialized version of 'asum' with the 'HasCallStack' constraint for -- tracking purposes. @@ -97,16 +121,24 @@ ---------------------------------------- -- Internal helpers +-- | Internal error type for the Empty action. Better than '()' in case it +-- escapes the scope of 'runNonDet' and shows up in error messages. +data ErrorEmpty = ErrorEmpty +instance Show ErrorEmpty where + show ErrorEmpty = "Effectful.NonDet.ErrorEmpty" + noError :: Either (cs, e) a -> Either cs a noError = either (Left . fst) Right cloneLocalEnv - :: LocalEnv localEs handlerEs + :: HasCallStack + => LocalEnv localEs handlerEs -> Eff es (LocalEnv localEs handlerEs) cloneLocalEnv = coerce . unsafeEff_ . cloneEnv . coerce restoreLocalEnv - :: LocalEnv localEs handlerEs + :: HasCallStack + => LocalEnv localEs handlerEs -> LocalEnv localEs handlerEs -> Eff es () restoreLocalEnv dest src = unsafeEff_ $ restoreEnv (coerce dest) (coerce src) diff --git a/src/Effectful/Provider.hs b/src/Effectful/Provider.hs --- a/src/Effectful/Provider.hs +++ b/src/Effectful/Provider.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ImplicitParams #-} -- | Turn an effect handler into an effectful operation. -- -- @since 2.3.0.0 @@ -25,6 +26,7 @@ import Data.Functor.Identity import Data.Kind (Type) import Data.Primitive.PrimArray +import GHC.Stack import Effectful import Effectful.Dispatch.Static @@ -35,9 +37,9 @@ -- $example -- -- >>> import Control.Monad.IO.Class +-- >>> import Data.Map.Strict qualified as M -- >>> import Effectful.Dispatch.Dynamic -- >>> import Effectful.State.Static.Local --- >>> import qualified Data.Map.Strict as M -- -- Given an effect: -- @@ -74,7 +76,7 @@ -- => FilePath -- -> Eff (Write : es) a -- -> Eff es a --- runWriteIO fp = interpret $ \_ -> \case +-- runWriteIO fp = interpret_ $ \case -- Write msg -> liftIO . putStrLn $ fp ++ ": " ++ msg -- :} -- @@ -84,7 +86,7 @@ -- => FilePath -- -> Eff (Write : es) a -- -> Eff es a --- runWritePure fp = interpret $ \_ -> \case +-- runWritePure fp = interpret_ $ \case -- Write msg -> modify $ M.insertWith (++) fp [msg] -- :} -- @@ -122,55 +124,64 @@ type instance DispatchOf (Provider e input f) = Static NoSideEffects data instance StaticRep (Provider e input f) where - Provider :: !(Env handlerEs) - -> !(forall r. input -> Eff (e : handlerEs) r -> Eff handlerEs (f r)) - -> StaticRep (Provider e input f) + Provider + :: !(Env handlerEs) + -> !(forall r. HasCallStack => input -> Eff (e : handlerEs) r -> Eff handlerEs (f r)) + -> StaticRep (Provider e input f) -- | Run the 'Provider' effect with a given effect handler. runProvider - :: (forall r. input -> Eff (e : es) r -> Eff es (f r)) + :: HasCallStack + => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r)) -- ^ The effect handler. -> Eff (Provider e input f : es) a -> Eff es a -runProvider run m = unsafeEff $ \es0 -> do +runProvider provider m = unsafeEff $ \es0 -> do inlineBracket - (consEnv (Provider es0 run) relinkProvider es0) + (consEnv (mkProvider es0) relinkProvider es0) unconsEnv (\es -> unEff m es) + where + -- Corresponds to withFrozenCallStack in provideWith. + mkProvider es = Provider es (let ?callStack = thawCallStack ?callStack in provider) -- | Run the 'Provider' effect with a given effect handler that doesn't change -- its return type. runProvider_ - :: (forall r. input -> Eff (e : es) r -> Eff es r) + :: HasCallStack + => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es r) -- ^ The effect handler. -> Eff (Provider_ e input : es) a -> Eff es a -runProvider_ run = runProvider $ \input -> coerce . run input +runProvider_ provider = runProvider $ \input -> coerce . provider input -- | Run the effect handler. -provide :: Provider e () f :> es => Eff (e : es) a -> Eff es (f a) +provide :: (HasCallStack, Provider e () f :> es) => Eff (e : es) a -> Eff es (f a) provide = provideWith () -- | Run the effect handler with unchanged return type. -provide_ :: Provider_ e () :> es => Eff (e : es) a -> Eff es a +provide_ :: (HasCallStack, Provider_ e () :> es) => Eff (e : es) a -> Eff es a provide_ = provideWith_ () -- | Run the effect handler with a given input. provideWith - :: Provider e input f :> es + :: (HasCallStack, Provider e input f :> es) => input -- ^ The input to the effect handler. -> Eff (e : es) a -> Eff es (f a) provideWith input action = unsafeEff $ \es -> do - Provider handlerEs run <- getEnv es - (`unEff` handlerEs) . run input . unsafeEff $ \eHandlerEs -> do - unEff action =<< copyRef eHandlerEs es + Provider handlerEs handler <- getEnv es + (`unEff` handlerEs) + -- Corresponds to thawCallStack in runProvider. + . withFrozenCallStack handler input + . unsafeEff $ \eProviderEs -> do + unEff action =<< copyRef eProviderEs es -- | Run the effect handler that doesn't change its return type with a given -- input. provideWith_ - :: Provider_ e input :> es + :: (HasCallStack, Provider_ e input :> es) => input -- ^ The input to the effect handler. -> Eff (e : es) a @@ -188,13 +199,17 @@ newHandlerEs <- relink handlerEs pure $ Provider newHandlerEs run -copyRef :: Env (e : handlerEs) -> Env es -> IO (Env (e : es)) +copyRef + :: HasCallStack + => Env (e : handlerEs) + -> Env es + -> IO (Env (e : es)) copyRef (Env hoffset hrefs hstorage) (Env offset refs0 storage) = do when (hstorage /= storage) $ do error "storages do not match" let size = sizeofPrimArray refs0 - offset - mrefs <- newPrimArray (size + 2) - copyPrimArray mrefs 0 hrefs hoffset 2 - copyPrimArray mrefs 2 refs0 offset size + mrefs <- newPrimArray (size + 1) + writePrimArray mrefs 0 $ indexPrimArray hrefs hoffset + copyPrimArray mrefs 1 refs0 offset size refs <- unsafeFreezePrimArray mrefs pure $ Env 0 refs storage diff --git a/src/Effectful/Provider/List.hs b/src/Effectful/Provider/List.hs --- a/src/Effectful/Provider/List.hs +++ b/src/Effectful/Provider/List.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ImplicitParams #-} -- | Turn a handler of multiple effects into an effectful operation. -- -- Generalizes "Effectful.Provider". @@ -28,6 +29,7 @@ import Data.Coerce import Data.Functor.Identity import Data.Primitive.PrimArray +import GHC.Stack import Effectful import Effectful.Dispatch.Static @@ -36,86 +38,95 @@ import Effectful.Internal.Env (Env(..)) import Effectful.Internal.Utils --- | Provide a way to run a handler of multiple @effects@ with a given @input@. +-- | Provide a way to run a handler of multiple @providedEs@ with a given +-- @input@. -- -- /Note:/ @f@ can be used to alter the return type of the handler. If that's -- unnecessary, use 'ProviderList_'. -data ProviderList (effects :: [Effect]) (input :: Type) (f :: Type -> Type) :: Effect +data ProviderList (providedEs :: [Effect]) (input :: Type) (f :: Type -> Type) :: Effect -- | A restricted variant of 'ProviderList' with unchanged return type of the -- handler. -type ProviderList_ effs input = ProviderList effs input Identity +type ProviderList_ providedEs input = ProviderList providedEs input Identity -type instance DispatchOf (ProviderList effs input f) = Static NoSideEffects +type instance DispatchOf (ProviderList providedEs input f) = Static NoSideEffects -data instance StaticRep (ProviderList effs input f) where +data instance StaticRep (ProviderList providedEs input f) where ProviderList - :: KnownEffects effs + :: KnownEffects providedEs => !(Env handlerEs) - -> !(forall r. input -> Eff (effs ++ handlerEs) r -> Eff handlerEs (f r)) - -> StaticRep (ProviderList effs input f) + -> !(forall r. HasCallStack => input -> Eff (providedEs ++ handlerEs) r -> Eff handlerEs (f r)) + -> StaticRep (ProviderList providedEs input f) -- | Run the 'ProviderList' effect with a given handler. runProviderList - :: KnownEffects effs - => (forall r. input -> Eff (effs ++ es) r -> Eff es (f r)) + :: (HasCallStack, KnownEffects providedEs) + => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es (f r)) -- ^ The handler. - -> Eff (ProviderList effs input f : es) a + -> Eff (ProviderList providedEs input f : es) a -> Eff es a -runProviderList run m = unsafeEff $ \es0 -> do +runProviderList providerList m = unsafeEff $ \es0 -> do inlineBracket - (consEnv (ProviderList es0 run) relinkProviderList es0) + (consEnv (mkProviderList es0) relinkProviderList es0) unconsEnv (\es -> unEff m es) + where + -- Corresponds to withFrozenCallStack in provideListWith. + mkProviderList es = + ProviderList es (let ?callStack = thawCallStack ?callStack in providerList) -- | Run the 'Provider' effect with a given handler that doesn't change its -- return type. runProviderList_ - :: KnownEffects effs - => (forall r. input -> Eff (effs ++ es) r -> Eff es r) + :: (HasCallStack, KnownEffects providedEs) + => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es r) -- ^ The handler. - -> Eff (ProviderList_ effs input : es) a + -> Eff (ProviderList_ providedEs input : es) a -> Eff es a -runProviderList_ run = runProviderList $ \input -> coerce . run input +runProviderList_ providerList = runProviderList $ \input -> coerce . providerList input -- | Run the handler. provideList - :: forall effs f es a - . ProviderList effs () f :> es - => Eff (effs ++ es) a + :: forall providedEs f es a + . (HasCallStack, ProviderList providedEs () f :> es) + => Eff (providedEs ++ es) a -> Eff es (f a) -provideList = provideListWith @effs () +provideList = provideListWith @providedEs () -- | Run the handler with unchanged return type. provideList_ - :: forall effs es a - . ProviderList_ effs () :> es - => Eff (effs ++ es) a + :: forall providedEs es a + . (HasCallStack, ProviderList_ providedEs () :> es) + => Eff (providedEs ++ es) a -> Eff es a -provideList_ = provideListWith_ @effs () +provideList_ = provideListWith_ @providedEs () -- | Run the handler with a given input. provideListWith - :: forall effs input f es a - . ProviderList effs input f :> es + :: forall providedEs input f es a + . (HasCallStack, ProviderList providedEs input f :> es) => input -- ^ The input to the handler. - -> Eff (effs ++ es) a + -> Eff (providedEs ++ es) a -> Eff es (f a) provideListWith input action = unsafeEff $ \es -> do - ProviderList (handlerEs :: Env handlerEs) run <- getEnv @(ProviderList effs input f) es - (`unEff` handlerEs) . run input . unsafeEff $ \eHandlerEs -> do - unEff action =<< copyRefs @effs @handlerEs eHandlerEs es + ProviderList (handlerEs :: Env handlerEs) providerList <- do + getEnv @(ProviderList providedEs input f) es + (`unEff` handlerEs) + -- Corresponds to a thawCallStack in runProviderList. + . withFrozenCallStack providerList input + . unsafeEff $ \eHandlerEs -> do + unEff action =<< copyRefs @providedEs @handlerEs eHandlerEs es -- | Run the handler that doesn't change its return type with a given input. provideListWith_ - :: forall effs input es a - . ProviderList_ effs input :> es + :: forall providedEs input es a + . (HasCallStack, ProviderList_ providedEs input :> es) => input -- ^ The input to the handler. - -> Eff (effs ++ es) a + -> Eff (providedEs ++ es) a -> Eff es a -provideListWith_ input = adapt . provideListWith @effs input +provideListWith_ input = adapt . provideListWith @providedEs input where adapt :: Eff es (Identity a) -> Eff es a adapt = coerce @@ -129,18 +140,18 @@ pure $ ProviderList newHandlerEs run copyRefs - :: forall effs handlerEs es - . KnownEffects effs - => Env (effs ++ handlerEs) + :: forall providedEs handlerEs es + . (HasCallStack, KnownEffects providedEs) + => Env (providedEs ++ handlerEs) -> Env es - -> IO (Env (effs ++ es)) + -> IO (Env (providedEs ++ es)) copyRefs (Env hoffset hrefs hstorage) (Env offset refs0 storage) = do when (hstorage /= storage) $ do error "storages do not match" - let size = sizeofPrimArray refs0 - offset - effsSize = 2 * knownEffectsLength @effs - mrefs <- newPrimArray (size + effsSize) - copyPrimArray mrefs 0 hrefs hoffset effsSize - copyPrimArray mrefs effsSize refs0 offset size + let providedEsSize = knownEffectsLength @providedEs + esSize = sizeofPrimArray refs0 - offset + mrefs <- newPrimArray (providedEsSize + esSize) + copyPrimArray mrefs 0 hrefs hoffset providedEsSize + copyPrimArray mrefs providedEsSize refs0 offset esSize refs <- unsafeFreezePrimArray mrefs pure $ Env 0 refs storage diff --git a/src/Effectful/Reader/Dynamic.hs b/src/Effectful/Reader/Dynamic.hs --- a/src/Effectful/Reader/Dynamic.hs +++ b/src/Effectful/Reader/Dynamic.hs @@ -30,7 +30,8 @@ -- | Run the 'Reader' effect with the given initial environment (via -- "Effectful.Reader.Static"). runReader - :: r -- ^ The initial environment. + :: HasCallStack + => r -- ^ The initial environment. -> Eff (Reader r : es) a -> Eff es a runReader r = reinterpret (R.runReader r) $ \env -> \case @@ -41,7 +42,8 @@ -- -- @since 1.1.0.0 withReader - :: (r1 -> r2) + :: HasCallStack + => (r1 -> r2) -- ^ The function to modify the environment. -> Eff (Reader r2 : es) a -- ^ Computation to run in the modified environment. diff --git a/src/Effectful/Reader/Static.hs b/src/Effectful/Reader/Static.hs --- a/src/Effectful/Reader/Static.hs +++ b/src/Effectful/Reader/Static.hs @@ -13,19 +13,22 @@ , local ) where +import Data.Kind + import Effectful import Effectful.Dispatch.Static -- | Provide access to a strict (WHNF), thread local, read only value of type -- @r@. -data Reader r :: Effect +data Reader (r :: Type) :: Effect type instance DispatchOf (Reader r) = Static NoSideEffects newtype instance StaticRep (Reader r) = Reader r -- | Run a 'Reader' effect with the given initial environment. runReader - :: r -- ^ The initial environment. + :: HasCallStack + => r -- ^ The initial environment. -> Eff (Reader r : es) a -> Eff es a runReader r = evalStaticRep (Reader r) @@ -34,7 +37,8 @@ -- -- @since 1.1.0.0 withReader - :: (r1 -> r2) + :: HasCallStack + => (r1 -> r2) -- ^ The function to modify the environment. -> Eff (Reader r2 : es) a -- ^ Computation to run in the modified environment. @@ -44,7 +48,7 @@ raise $ runReader (f r) m -- | Fetch the value of the environment. -ask :: Reader r :> es => Eff es r +ask :: (HasCallStack, Reader r :> es) => Eff es r ask = do Reader r <- getStaticRep pure r @@ -53,7 +57,7 @@ -- -- @'asks' f ≡ f '<$>' 'ask'@ asks - :: Reader r :> es + :: (HasCallStack, Reader r :> es) => (r -> a) -- ^ The function to apply to the environment. -> Eff es a asks f = f <$> ask @@ -63,7 +67,7 @@ -- @'runReader' r ('local' f m) ≡ 'runReader' (f r) m@ -- local - :: Reader r :> es + :: (HasCallStack, Reader r :> es) => (r -> r) -- ^ The function to modify the environment. -> Eff es a -> Eff es a diff --git a/src/Effectful/State/Dynamic.hs b/src/Effectful/State/Dynamic.hs --- a/src/Effectful/State/Dynamic.hs +++ b/src/Effectful/State/Dynamic.hs @@ -48,24 +48,20 @@ -- | Run the 'State' effect with the given initial state and return the final -- value along with the final state (via "Effectful.State.Static.Local"). -runStateLocal :: s -> Eff (State s : es) a -> Eff es (a, s) +runStateLocal :: HasCallStack => s -> Eff (State s : es) a -> Eff es (a, s) runStateLocal s0 = reinterpret (L.runState s0) localState -- | Run the 'State' effect with the given initial state and return the final -- value, discarding the final state (via "Effectful.State.Static.Local"). -evalStateLocal :: s -> Eff (State s : es) a -> Eff es a +evalStateLocal :: HasCallStack => s -> Eff (State s : es) a -> Eff es a evalStateLocal s0 = reinterpret (L.evalState s0) localState -- | Run the 'State' effect with the given initial state and return the final -- state, discarding the final value (via "Effectful.State.Static.Local"). -execStateLocal :: s -> Eff (State s : es) a -> Eff es s +execStateLocal :: HasCallStack => s -> Eff (State s : es) a -> Eff es s execStateLocal s0 = reinterpret (L.execState s0) localState -localState - :: L.State s :> es - => LocalEnv localEs es - -> State s (Eff localEs) a - -> Eff es a +localState :: L.State s :> es => EffectHandler (State s) es localState env = \case Get -> L.get Put s -> L.put s @@ -77,24 +73,20 @@ -- | Run the 'State' effect with the given initial state and return the final -- value along with the final state (via "Effectful.State.Static.Shared"). -runStateShared :: s -> Eff (State s : es) a -> Eff es (a, s) +runStateShared :: HasCallStack => s -> Eff (State s : es) a -> Eff es (a, s) runStateShared s0 = reinterpret (S.runState s0) sharedState -- | Run the 'State' effect with the given initial state and return the final -- value, discarding the final state (via "Effectful.State.Static.Shared"). -evalStateShared :: s -> Eff (State s : es) a -> Eff es a +evalStateShared :: HasCallStack => s -> Eff (State s : es) a -> Eff es a evalStateShared s0 = reinterpret (S.evalState s0) sharedState -- | Run the 'State' effect with the given initial state and return the final -- state, discarding the final value (via "Effectful.State.Static.Shared"). -execStateShared :: s -> Eff (State s : es) a -> Eff es s +execStateShared :: HasCallStack => s -> Eff (State s : es) a -> Eff es s execStateShared s0 = reinterpret (S.execState s0) sharedState -sharedState - :: S.State s :> es - => LocalEnv localEs es - -> State s (Eff localEs) a - -> Eff es a +sharedState :: S.State s :> es => EffectHandler (State s) es sharedState env = \case Get -> S.get Put s -> S.put s diff --git a/src/Effectful/State/Static/Local.hs b/src/Effectful/State/Static/Local.hs --- a/src/Effectful/State/Static/Local.hs +++ b/src/Effectful/State/Static/Local.hs @@ -7,7 +7,7 @@ -- the @transformers@ library, the 'State' effect doesn't discard state updates -- when an exception is received: -- --- >>> import qualified Control.Monad.Trans.State.Strict as S +-- >>> import Control.Monad.Trans.State.Strict qualified as S -- -- >>> :{ -- (`S.execStateT` "Hi") . handle (\(_::ErrorCall) -> pure ()) $ do @@ -41,11 +41,13 @@ , modifyM ) where +import Data.Kind + import Effectful import Effectful.Dispatch.Static -- | Provide access to a strict (WHNF), thread local, mutable value of type @s@. -data State s :: Effect +data State (s :: Type) :: Effect type instance DispatchOf (State s) = Static NoSideEffects newtype instance StaticRep (State s) = State s @@ -53,7 +55,8 @@ -- | Run the 'State' effect with the given initial state and return the final -- value along with the final state. runState - :: s -- ^ The initial state. + :: HasCallStack + => s -- ^ The initial state. -> Eff (State s : es) a -> Eff es (a, s) runState s0 m = do @@ -63,7 +66,8 @@ -- | Run the 'State' effect with the given initial state and return the final -- value, discarding the final state. evalState - :: s -- ^ The initial state. + :: HasCallStack + => s -- ^ The initial state. -> Eff (State s : es) a -> Eff es a evalState s = evalStaticRep (State s) @@ -71,7 +75,8 @@ -- | Run the 'State' effect with the given initial state and return the final -- state, discarding the final value. execState - :: s -- ^ The initial state. + :: HasCallStack + => s -- ^ The initial state. -> Eff (State s : es) a -> Eff es s execState s0 m = do @@ -79,7 +84,7 @@ pure s -- | Fetch the current value of the state. -get :: State s :> es => Eff es s +get :: (HasCallStack, State s :> es) => Eff es s get = do State s <- getStaticRep pure s @@ -88,18 +93,18 @@ -- -- @'gets' f ≡ f '<$>' 'get'@ gets - :: State s :> es + :: (HasCallStack, State s :> es) => (s -> a) -- ^ The function to apply to the state. -> Eff es a gets f = f <$> get -- | Set the current state to the given value. -put :: State s :> es => s -> Eff es () +put :: (HasCallStack, State s :> es) => s -> Eff es () put s = putStaticRep (State s) -- | Apply the function to the current state and return a value. state - :: State s :> es + :: (HasCallStack, State s :> es) => (s -> (a, s)) -- ^ The function to modify the state. -> Eff es a state f = stateStaticRep $ \(State s0) -> let (a, s) = f s0 in (a, State s) @@ -108,14 +113,14 @@ -- -- @'modify' f ≡ 'state' (\\s -> ((), f s))@ modify - :: State s :> es + :: (HasCallStack, State s :> es) => (s -> s) -- ^ The function to modify the state. -> Eff es () modify f = state $ \s -> ((), f s) -- | Apply the monadic function to the current state and return a value. stateM - :: State s :> es + :: (HasCallStack, State s :> es) => (s -> Eff es (a, s)) -- ^ The function to modify the state. -> Eff es a stateM f = stateStaticRepM $ \(State s0) -> do @@ -126,11 +131,10 @@ -- -- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@ modifyM - :: State s :> es + :: (HasCallStack, State s :> es) => (s -> Eff es s) -- ^ The monadic function to modify the state. -> Eff es () modifyM f = stateM (\s -> ((), ) <$> f s) -- $setup --- >>> import Control.Exception (ErrorCall) --- >>> import Control.Monad.Catch +-- >>> import Effectful.Exception diff --git a/src/Effectful/State/Static/Shared.hs b/src/Effectful/State/Static/Shared.hs --- a/src/Effectful/State/Static/Shared.hs +++ b/src/Effectful/State/Static/Shared.hs @@ -7,7 +7,7 @@ -- the @transformers@ library, the 'State' effect doesn't discard state updates -- when an exception is received: -- --- >>> import qualified Control.Monad.Trans.State.Strict as S +-- >>> import Control.Monad.Trans.State.Strict qualified as S -- -- >>> :{ -- (`S.execStateT` "Hi") . handle (\(_::ErrorCall) -> pure ()) $ do @@ -45,22 +45,22 @@ , modifyM ) where -import Control.Concurrent.MVar +import Control.Concurrent.MVar.Strict +import Data.Kind 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 +data State (s :: Type) :: Effect type instance DispatchOf (State s) = Static NoSideEffects 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 :: HasCallStack => s -> Eff (State s : es) a -> Eff es (a, s) runState s m = do v <- unsafeEff_ $ newMVar' s a <- evalStaticRep (State v) m @@ -68,44 +68,40 @@ -- | 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 :: HasCallStack => s -> Eff (State s : es) a -> Eff es a evalState s m = do 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 :: HasCallStack => s -> Eff (State s : es) a -> Eff es s execState s m = do v <- unsafeEff_ $ newMVar' s _ <- evalStaticRep (State v) m unsafeEff_ $ readMVar' v --- | Run the 'State' effect with the given initial state 'MVar' and return the +-- | 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 :: HasCallStack => MVar' s -> Eff (State s : es) a -> Eff es (a, s) runStateMVar v m = do - v' <- unsafeEff_ $ toMVar' v - a <- evalStaticRep (State v') m - (a, ) <$> unsafeEff_ (readMVar v) + a <- evalStaticRep (State v) m + (a, ) <$> unsafeEff_ (readMVar' v) --- | Run the 'State' effect with the given initial state 'MVar' and return the +-- | 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 - v' <- unsafeEff_ $ toMVar' v - evalStaticRep (State v') m +evalStateMVar :: HasCallStack => MVar' s -> Eff (State s : es) a -> Eff es a +evalStateMVar v = evalStaticRep (State v) --- | Run the 'State' effect with the given initial state 'MVar' and return the +-- | 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 :: HasCallStack => MVar' s -> Eff (State s : es) a -> Eff es s execStateMVar v m = do - v' <- unsafeEff_ $ toMVar' v - _ <- evalStaticRep (State v') m - unsafeEff_ $ readMVar v + _ <- evalStaticRep (State v) m + unsafeEff_ $ readMVar' v -- | Fetch the current value of the state. -get :: State s :> es => Eff es s +get :: (HasCallStack, State s :> es) => Eff es s get = unsafeEff $ \es -> do State v <- getEnv es readMVar' v @@ -113,19 +109,19 @@ -- | Get a function of the current state. -- -- @'gets' f ≡ f '<$>' 'get'@ -gets :: State s :> es => (s -> a) -> Eff es a +gets :: (HasCallStack, State s :> es) => (s -> a) -> Eff es a gets f = f <$> get -- | Set the current state to the given value. -put :: State s :> es => s -> Eff es () +put :: (HasCallStack, State s :> es) => s -> Eff es () put s = unsafeEff $ \es -> do State v <- getEnv es - modifyMVar_' v $ \_ -> pure s + modifyMVar'_ v $ \_ -> pure s -- | Apply the function to the current state and return a value. -- -- /Note:/ this function gets an exclusive access to the state for its duration. -state :: State s :> es => (s -> (a, s)) -> Eff es a +state :: (HasCallStack, 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 pure (s, a) @@ -135,13 +131,13 @@ -- @'modify' f ≡ 'state' (\\s -> ((), f s))@ -- -- /Note:/ this function gets an exclusive access to the state for its duration. -modify :: State s :> es => (s -> s) -> Eff es () +modify :: (HasCallStack, State s :> es) => (s -> s) -> Eff es () modify f = state (\s -> ((), f s)) -- | Apply the monadic function to the current state and return a value. -- -- /Note:/ this function gets an exclusive access to the state for its duration. -stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a +stateM :: (HasCallStack, State s :> es) => (s -> Eff es (a, s)) -> Eff es a stateM f = unsafeEff $ \es -> do State v <- getEnv es modifyMVar' v $ \s0 -> do @@ -153,9 +149,8 @@ -- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@ -- -- /Note:/ this function gets an exclusive access to the state for its duration. -modifyM :: State s :> es => (s -> Eff es s) -> Eff es () +modifyM :: (HasCallStack, State s :> es) => (s -> Eff es s) -> Eff es () modifyM f = stateM (\s -> ((), ) <$> f s) -- $setup --- >>> import Control.Exception (ErrorCall) --- >>> import Control.Monad.Catch +-- >>> import Effectful.Exception diff --git a/src/Effectful/Writer/Dynamic.hs b/src/Effectful/Writer/Dynamic.hs --- a/src/Effectful/Writer/Dynamic.hs +++ b/src/Effectful/Writer/Dynamic.hs @@ -40,19 +40,15 @@ -- | Run the 'Writer' effect and return the final value along with the final -- output (via "Effectful.Writer.Static.Local"). -runWriterLocal :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w) +runWriterLocal :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w) runWriterLocal = reinterpret L.runWriter localWriter -- | Run a 'Writer' effect and return the final output, discarding the final -- value (via "Effectful.Writer.Static.Local"). -execWriterLocal :: Monoid w => Eff (Writer w : es) a -> Eff es w +execWriterLocal :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w execWriterLocal = reinterpret L.execWriter localWriter -localWriter - :: (L.Writer w :> es, Monoid w) - => LocalEnv localEs es - -> Writer w (Eff localEs) a - -> Eff es a +localWriter :: (L.Writer w :> es, Monoid w) => EffectHandler (Writer w) es localWriter env = \case Tell w -> L.tell w Listen m -> localSeqUnlift env $ \unlift -> L.listen (unlift m) @@ -62,19 +58,15 @@ -- | Run the 'Writer' effect and return the final value along with the final -- output (via "Effectful.Writer.Static.Shared"). -runWriterShared :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w) +runWriterShared :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w) runWriterShared = reinterpret S.runWriter sharedWriter -- | Run the 'Writer' effect and return the final output, discarding the final -- value (via "Effectful.Writer.Static.Shared"). -execWriterShared :: Monoid w => Eff (Writer w : es) a -> Eff es w +execWriterShared :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w execWriterShared = reinterpret S.execWriter sharedWriter -sharedWriter - :: (S.Writer w :> es, Monoid w) - => LocalEnv localEs es - -> Writer w (Eff localEs) a - -> Eff es a +sharedWriter :: (S.Writer w :> es, Monoid w) => EffectHandler (Writer w) es sharedWriter env = \case Tell w -> S.tell w Listen m -> localSeqUnlift env $ \unlift -> S.listen (unlift m) diff --git a/src/Effectful/Writer/Static/Local.hs b/src/Effectful/Writer/Static/Local.hs --- a/src/Effectful/Writer/Static/Local.hs +++ b/src/Effectful/Writer/Static/Local.hs @@ -28,6 +28,7 @@ ) where import Control.Exception (onException, mask) +import Data.Kind import Effectful import Effectful.Dispatch.Static @@ -35,27 +36,27 @@ -- | Provide access to a strict (WHNF), thread local, write only value of type -- @w@. -data Writer w :: Effect +data Writer (w :: Type) :: Effect type instance DispatchOf (Writer w) = Static NoSideEffects newtype instance StaticRep (Writer w) = Writer 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 :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w) runWriter m = do (a, Writer w) <- runStaticRep (Writer mempty) m pure (a, w) -- | 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 :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w execWriter m = do Writer w <- execStaticRep (Writer mempty) m pure w -- | Append the given output to the overall output of the 'Writer'. -tell :: (Writer w :> es, Monoid w) => w -> Eff es () +tell :: (HasCallStack, Writer w :> es, Monoid w) => w -> Eff es () tell w = stateStaticRep $ \(Writer w0) -> ((), Writer (w0 <> w)) -- | Execute an action and append its output to the overall output of the @@ -75,26 +76,30 @@ -- error "oops" -- :} -- "Hi there!" -listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w) +listen :: (HasCallStack, Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w) listen m = unsafeEff $ \es -> mask $ \unmask -> do - w0 <- stateEnv es $ \(Writer w) -> pure (w, Writer mempty) + w0 <- stateEnv es $ \(Writer w) -> (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) -> pure (w1, Writer (w0 <> w1)) + stateEnv es $ \(Writer w1) -> (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 -- output. -- -- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@ -listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b) +listens + :: (HasCallStack, Writer w :> es, Monoid w) + => (w -> b) + -> Eff es a + -> Eff es (a, b) listens f m = do (a, w) <- listen m pure (a, f w) -- $setup -- >>> import Control.Exception (ErrorCall) --- >>> import Control.Monad.Catch +-- >>> import Effectful.Exception diff --git a/src/Effectful/Writer/Static/Shared.hs b/src/Effectful/Writer/Static/Shared.hs --- a/src/Effectful/Writer/Static/Shared.hs +++ b/src/Effectful/Writer/Static/Shared.hs @@ -27,22 +27,23 @@ , listens ) where +import Control.Concurrent.MVar.Strict import Control.Exception (onException, uninterruptibleMask) +import Data.Kind 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 +data Writer (w :: Type) :: Effect type instance DispatchOf (Writer w) = Static NoSideEffects 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 :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w) runWriter m = do v <- unsafeEff_ $ newMVar' mempty a <- evalStaticRep (Writer v) m @@ -50,17 +51,17 @@ -- | 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 :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w execWriter m = do v <- unsafeEff_ $ newMVar' mempty _ <- evalStaticRep (Writer v) m unsafeEff_ $ readMVar' v -- | Append the given output to the overall output of the 'Writer'. -tell :: (Writer w :> es, Monoid w) => w -> Eff es () +tell :: (HasCallStack, 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 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'. @@ -79,7 +80,7 @@ -- error "oops" -- :} -- "Hi there!" -listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w) +listen :: (HasCallStack, Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w) listen m = unsafeEff $ \es -> do -- The mask is uninterruptible because modifyMVar_ v0 in the merge function -- might block and if an async exception is received while waiting, w1 will be @@ -87,7 +88,7 @@ uninterruptibleMask $ \unmask -> do v1 <- newMVar' mempty -- Replace thread local MVar with a fresh one for isolated listening. - v0 <- stateEnv es $ \(Writer v) -> pure (v, Writer v1) + v0 <- stateEnv es $ \(Writer v) -> (v, Writer v1) a <- unmask (unEff m es) `onException` merge es v0 v1 (a, ) <$> merge es v0 v1 where @@ -96,7 +97,7 @@ merge es v0 v1 = do putEnv es $ Writer v0 w1 <- readMVar' v1 - modifyMVar_' v0 $ \w0 -> let w = w0 <> w1 in pure w + 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 @@ -104,11 +105,15 @@ -- output. -- -- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@ -listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b) +listens + :: (HasCallStack, Writer w :> es, Monoid w) + => (w -> b) + -> Eff es a + -> Eff es (a, b) listens f m = do (a, w) <- listen m pure (a, f w) -- $setup -- >>> import Control.Exception (ErrorCall) --- >>> import Control.Monad.Catch +-- >>> import Effectful.Exception