diff --git a/effectful-core/CHANGELOG.md b/effectful-core/CHANGELOG.md index 73f48db..ac07181 100644 --- a/effectful-core/CHANGELOG.md +++ b/effectful-core/CHANGELOG.md @@ -1,3 +1,8 @@ +# effectful-core-2.5.1.0 (????-??-??) +* Add `passthrough` to `Effectful.Dispatch.Dynamic` for passing operations to + the upstream handler within `interpose` and `impose` without having to fully + pattern match on them. + # effectful-core-2.5.0.0 (2024-10-23) * Add `plusEff` (specialized version of `<|>`) to `Effectful.NonDet` and make `emptyEff` and `sumEff` generate better call stacks. diff --git a/effectful-core/effectful-core.cabal b/effectful-core/effectful-core.cabal index 9d48564..b98ab8c 100644 --- a/effectful-core/effectful-core.cabal +++ b/effectful-core/effectful-core.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: effectful-core -version: 2.5.0.0 +version: 2.5.1.0 license: BSD-3-Clause license-file: LICENSE category: Control diff --git a/effectful-core/src/Effectful/Dispatch/Dynamic.hs b/effectful-core/src/Effectful/Dispatch/Dynamic.hs index 912c523..6962a96 100644 --- a/effectful-core/src/Effectful/Dispatch/Dynamic.hs +++ b/effectful-core/src/Effectful/Dispatch/Dynamic.hs @@ -20,6 +20,7 @@ module Effectful.Dispatch.Dynamic -- * Sending operations to the handler send + , passthrough -- * Handling effects , EffectHandler @@ -74,8 +75,9 @@ module Effectful.Dispatch.Dynamic , HasCallStack ) where +import Control.Monad import Data.Primitive.PrimArray -import GHC.Stack (HasCallStack) +import GHC.Stack import GHC.TypeLits import Effectful.Internal.Effect @@ -414,6 +416,25 @@ import Effectful.Internal.Utils -- >>> runPureEff . runReader @Int 3 $ double -- 6 +-- | A variant of 'send' for passing operations to the upstream handler within +-- 'interpose' and 'impose' without having to fully pattern match on them. +passthrough + :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es, e :> localEs, SharedSuffix es handlerEs) + => LocalEnv localEs handlerEs + -> e (Eff localEs) a + -- ^ The operation. + -> Eff es a +passthrough (LocalEnv les) op = unsafeEff $ \es -> do + Handler handlerEs handler <- getEnv es + when (envStorage les /= envStorage handlerEs) $ do + error "les and handlerEs point to different Storages" + -- Prevent internal functions that rebind the effect handler from polluting + -- its call stack by freezing it. Note that functions 'interpret', + -- 'reinterpret', 'interpose' and 'impose' need to thaw it so that useful + -- stack frames from inside the effect handler continue to be added. + unEff (withFrozenCallStack handler (LocalEnv les) op) handlerEs +{-# NOINLINE passthrough #-} + ---------------------------------------- -- Handling effects @@ -482,6 +503,7 @@ reinterpretWith runHandlerEs m handler = reinterpret runHandlerEs handler m -- data E :: Effect where -- Op1 :: E m () -- Op2 :: E m () +-- Op3 :: E m () -- type instance DispatchOf E = Dynamic -- :} -- @@ -490,58 +512,31 @@ reinterpretWith runHandlerEs m handler = reinterpret runHandlerEs handler m -- runE = interpret_ $ \case -- Op1 -> liftIO (putStrLn "op1") -- Op2 -> liftIO (putStrLn "op2") +-- Op3 -> liftIO (putStrLn "op3") -- :} -- --- >>> runEff . runE $ send Op1 >> send Op2 +-- >>> let action = send Op1 >> send Op2 >> send Op3 +-- +-- >>> runEff . runE $ action -- op1 -- op2 +-- op3 +-- +-- You can modify only specific operations and send the rest to the upstream +-- handler with 'passthrough': -- -- >>> :{ -- augmentOp2 :: (E :> es, IOE :> es) => Eff es a -> Eff es a --- augmentOp2 = interpose_ $ \case --- Op1 -> send Op1 +-- augmentOp2 = interpose $ \env -> \case -- Op2 -> liftIO (putStrLn "augmented op2") >> send Op2 +-- op -> passthrough env op -- :} -- --- >>> runEff . runE . augmentOp2 $ send Op1 >> send Op2 +-- >>> runEff . runE . augmentOp2 $ action -- 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. --- +-- op3 interpose :: forall e es a. (HasCallStack, DispatchOf e ~ Dynamic, e :> es) => EffectHandler e es diff --git a/effectful/CHANGELOG.md b/effectful/CHANGELOG.md index 0017a94..d00a065 100644 --- a/effectful/CHANGELOG.md +++ b/effectful/CHANGELOG.md @@ -1,3 +1,8 @@ +# effectful-2.5.1.0 (????-??-??) +* Add `passthrough` to `Effectful.Dispatch.Dynamic` for passing operations to + the upstream handler within `interpose` and `impose` without having to fully + pattern match on them. + # effectful-2.5.0.0 (2024-10-23) * Add `plusEff` (specialized version of `<|>`) to `Effectful.NonDet` and make `emptyEff` and `sumEff` generate better call stacks. diff --git a/effectful/effectful.cabal b/effectful/effectful.cabal index 89733bc..0772fa5 100644 --- a/effectful/effectful.cabal +++ b/effectful/effectful.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: effectful -version: 2.5.0.0 +version: 2.5.1.0 license: BSD-3-Clause license-file: LICENSE category: Control @@ -74,7 +74,7 @@ library , async >= 2.2.2 , bytestring >= 0.10 , directory >= 1.3.2 - , effectful-core >= 2.5.0.0 && < 2.5.1.0 + , effectful-core >= 2.5.1.0 && < 2.5.2.0 , process >= 1.6.9 , strict-mutable-base >= 1.1.0.0 , time >= 1.9.2