From 14bbcfd0739d72851bc71bddc545df66519e93cb Mon Sep 17 00:00:00 2001 From: Andrzej Rybczak Date: Fri, 9 Aug 2024 15:56:50 +0200 Subject: [PATCH] Utility functions for handling effects (#231) * Add utility functions for first order effects * Add utility functions that take the effect handler as the last parameter * Annotate type parameters of EffectHandler with their kinds --- effectful-core/CHANGELOG.md | 6 + effectful-core/effectful-core.cabal | 2 +- .../src/Effectful/Dispatch/Dynamic.hs | 180 +++++++++++++++++- effectful-core/src/Effectful/Fail.hs | 4 +- .../src/Effectful/Internal/Monad.hs | 4 +- effectful-core/src/Effectful/Provider.hs | 4 +- effectful-plugin/tests/PluginTests.hs | 4 +- effectful/CHANGELOG.md | 6 + effectful/bench/FileSizes.hs | 4 +- effectful/effectful.cabal | 4 +- effectful/tests/EnvTests.hs | 8 +- effectful/tests/ErrorTests.hs | 2 +- effectful/tests/NonDetTests.hs | 2 +- effectful/tests/StateTests.hs | 2 +- 14 files changed, 209 insertions(+), 23 deletions(-) diff --git a/effectful-core/CHANGELOG.md b/effectful-core/CHANGELOG.md index 60240f5a..8aae557c 100644 --- a/effectful-core/CHANGELOG.md +++ b/effectful-core/CHANGELOG.md @@ -1,3 +1,9 @@ +# effectful-core-2.4.0.0 (????-??-??) +* 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`. + # 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/effectful-core.cabal b/effectful-core/effectful-core.cabal index f37d68ae..134d571b 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.3.1.0 +version: 2.4.0.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 12b7c276..3b9a5643 100644 --- a/effectful-core/src/Effectful/Dispatch/Dynamic.hs +++ b/effectful-core/src/Effectful/Dispatch/Dynamic.hs @@ -23,9 +23,13 @@ module Effectful.Dispatch.Dynamic -- * Handling effects , EffectHandler , interpret + , interpretWith , reinterpret + , reinterpretWith , interpose + , interposeWith , impose + , imposeWith -- ** Handling local 'Eff' computations , LocalEnv @@ -53,6 +57,17 @@ module Effectful.Dispatch.Dynamic , localBorrow , SharedSuffix + -- ** Utils for first order effects + , EffectHandler_ + , interpret_ + , interpretWith_ + , reinterpret_ + , reinterpretWith_ + , interpose_ + , interposeWith_ + , impose_ + , imposeWith_ + -- * Re-exports , HasCallStack ) where @@ -212,6 +227,9 @@ import Effectful.Internal.Utils -- -- 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 +361,7 @@ import Effectful.Internal.Utils -- -- >>> :{ -- runDummyRNG :: Eff (RNG : es) a -> Eff es a --- runDummyRNG = interpret $ \_ -> \case +-- runDummyRNG = interpret_ $ \case -- RandomInt -> pure 55 -- :} -- @@ -418,6 +436,17 @@ interpret handler m = unsafeEff $ \es -> do 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 + :: 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'@ @@ -435,6 +464,19 @@ reinterpret runHandlerEs handler m = unsafeEff $ \es -> do 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 + :: 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 @@ -448,7 +490,7 @@ reinterpret runHandlerEs handler m = unsafeEff $ \es -> do -- -- >>> :{ -- runE :: IOE :> es => Eff (E : es) a -> Eff es a --- runE = interpret $ \_ Op -> liftIO (putStrLn "op") +-- runE = interpret_ $ \Op -> liftIO (putStrLn "op") -- :} -- -- >>> runEff . runE $ send Op @@ -456,7 +498,7 @@ reinterpret runHandlerEs handler m = unsafeEff $ \es -> do -- -- >>> :{ -- augmentE :: (E :> es, IOE :> es) => Eff es a -> Eff es a --- augmentE = interpose $ \_ Op -> liftIO (putStrLn "augmented op") >> send Op +-- augmentE = interpose_ $ \Op -> liftIO (putStrLn "augmented op") >> send Op -- :} -- -- >>> runEff . runE . augmentE $ send Op @@ -489,6 +531,17 @@ interpose handler m = unsafeEff $ \es -> do 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 + :: (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. -- @@ -523,6 +576,127 @@ impose runHandlerEs handler m = unsafeEff $ \es -> do 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 + :: (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_ + :: 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_ + :: DispatchOf e ~ Dynamic + => Eff (e : es) a + -> EffectHandler_ e es + -- ^ The effect handler. + -> Eff es a +interpretWith_ m handler = interpretWith m (const handler) + +-- | 'reinterpret' for first order effects. +-- +-- @since 2.4.0.0 +reinterpret_ + :: 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_ + :: 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 = reinterpretWith runHandlerEs m (const handler) + +-- | 'interpose' for first order effects. +-- +-- @since 2.4.0.0 +interpose_ + :: (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_ + :: (DispatchOf e ~ Dynamic, e :> es) + => Eff es a + -> EffectHandler_ e es + -- ^ The effect handler. + -> Eff es a +interposeWith_ m handler = interposeWith m (const handler) + +-- | 'impose' for first order effects. +-- +-- @since 2.4.0.0 +impose_ + :: (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_ + :: (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 = imposeWith runHandlerEs m (const handler) + ---------------------------------------- -- Unlifts diff --git a/effectful-core/src/Effectful/Fail.hs b/effectful-core/src/Effectful/Fail.hs index c45fb7d7..1f968571 100644 --- a/effectful-core/src/Effectful/Fail.hs +++ b/effectful-core/src/Effectful/Fail.hs @@ -15,10 +15,10 @@ 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 = 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 = interpret_ $ \case Fail msg -> liftIO $ fail msg diff --git a/effectful-core/src/Effectful/Internal/Monad.hs b/effectful-core/src/Effectful/Internal/Monad.hs index af9b855c..ea3a2057 100644 --- a/effectful-core/src/Effectful/Internal/Monad.hs +++ b/effectful-core/src/Effectful/Internal/Monad.hs @@ -494,13 +494,13 @@ type role LocalEnv nominal nominal 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 diff --git a/effectful-core/src/Effectful/Provider.hs b/effectful-core/src/Effectful/Provider.hs index 34007c6e..1b8d947a 100644 --- a/effectful-core/src/Effectful/Provider.hs +++ b/effectful-core/src/Effectful/Provider.hs @@ -74,7 +74,7 @@ import Effectful.Internal.Utils -- => FilePath -- -> Eff (Write : es) a -- -> Eff es a --- runWriteIO fp = interpret $ \_ -> \case +-- runWriteIO fp = interpret_ $ \case -- Write msg -> liftIO . putStrLn $ fp ++ ": " ++ msg -- :} -- @@ -84,7 +84,7 @@ import Effectful.Internal.Utils -- => FilePath -- -> Eff (Write : es) a -- -> Eff es a --- runWritePure fp = interpret $ \_ -> \case +-- runWritePure fp = interpret_ $ \case -- Write msg -> modify $ M.insertWith (++) fp [msg] -- :} -- diff --git a/effectful-plugin/tests/PluginTests.hs b/effectful-plugin/tests/PluginTests.hs index 47c5aad9..3a28bc0d 100644 --- a/effectful-plugin/tests/PluginTests.hs +++ b/effectful-plugin/tests/PluginTests.hs @@ -96,7 +96,7 @@ data TaggedState k s :: Effect where type instance DispatchOf (TaggedState k s) = Dynamic runTaggedState :: s -> Eff (TaggedState k s : es) a -> Eff es (a, s) -runTaggedState s = reinterpret (runState s) $ \_ -> \case +runTaggedState s = reinterpret_ (runState s) $ \case TaggedGet -> get TaggedPut s' -> put s' @@ -112,5 +112,5 @@ data DBAction whichDb :: Effect where type instance DispatchOf (DBAction whichDb) = Dynamic runDBAction :: Eff (DBAction which : es) a -> Eff es a -runDBAction = interpret $ \_ -> \case +runDBAction = interpret_ $ \case DoSelect (Select a) -> pure $ Just a diff --git a/effectful/CHANGELOG.md b/effectful/CHANGELOG.md index c7b44aa1..4321cdc2 100644 --- a/effectful/CHANGELOG.md +++ b/effectful/CHANGELOG.md @@ -1,3 +1,9 @@ +# effectful-2.4.0.0 (????-??-??) +* 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`. + # effectful-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/bench/FileSizes.hs b/effectful/bench/FileSizes.hs index b373834f..3efd31d8 100644 --- a/effectful/bench/FileSizes.hs +++ b/effectful/bench/FileSizes.hs @@ -102,7 +102,7 @@ effectful_tryFileSize :: Effectful_File E.:> es => FilePath -> E.Eff es (Maybe I effectful_tryFileSize = E.send . Effectful_tryFileSize effectful_runFile :: E.IOE E.:> es => E.Eff (Effectful_File : es) a -> E.Eff es a -effectful_runFile = E.interpret \_ -> \case +effectful_runFile = E.interpret_ \case Effectful_tryFileSize path -> liftIO $ tryGetFileSize path data Effectful_Logging :: E.Effect where @@ -116,7 +116,7 @@ effectful_logMsg = E.send . Effectful_logMsg . T.pack effectful_runLogging :: E.Eff (Effectful_Logging : es) a -> E.Eff es (a, [Text]) -effectful_runLogging = E.reinterpret (E.runState []) \_ -> \case +effectful_runLogging = E.reinterpret_ (E.runState []) \case Effectful_logMsg msg -> E.modify (msg :) ---------- diff --git a/effectful/effectful.cabal b/effectful/effectful.cabal index 88d120bc..28bfcb2f 100644 --- a/effectful/effectful.cabal +++ b/effectful/effectful.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: effectful -version: 2.3.1.0 +version: 2.4.0.0 license: BSD-3-Clause license-file: LICENSE category: Control @@ -69,7 +69,7 @@ library , async >= 2.2.2 , bytestring >= 0.10 , directory >= 1.3.2 - , effectful-core >= 2.3.1.0 && < 2.3.2.0 + , effectful-core >= 2.4.0.0 && < 2.4.1.0 , process >= 1.6.9 , time >= 1.9.2 diff --git a/effectful/tests/EnvTests.hs b/effectful/tests/EnvTests.hs index c0aeba85..5966c41e 100644 --- a/effectful/tests/EnvTests.hs +++ b/effectful/tests/EnvTests.hs @@ -191,11 +191,11 @@ data A :: Effect where type instance DispatchOf A = Dynamic runA :: Int -> Eff (A : es) a -> Eff es a -runA n = interpret $ \_ -> \case +runA n = interpret_ $ \case A -> pure n doubleA :: A :> es => Eff es a -> Eff es a -doubleA = interpose $ \_ -> \case +doubleA = interpose_ $ \case A -> (+) <$> send A <*> send A data B :: Effect where @@ -203,9 +203,9 @@ data B :: Effect where type instance DispatchOf B = Dynamic runB :: A :> es => Eff (B : es) a -> Eff es a -runB = interpret $ \_ -> \case +runB = interpret_ $ \case B -> send A doubleB :: B :> es => Eff es a -> Eff es a -doubleB = interpose $ \_ -> \case +doubleB = interpose_ $ \case B -> (+) <$> send B <*> send B diff --git a/effectful/tests/ErrorTests.hs b/effectful/tests/ErrorTests.hs index 3c900048..c502f5cb 100644 --- a/effectful/tests/ErrorTests.hs +++ b/effectful/tests/ErrorTests.hs @@ -42,5 +42,5 @@ outerThrow :: (HasCallStack, OuterThrow :> es) => Eff es () outerThrow = send OuterThrow runOuterThrow :: Error String :> es => Eff (OuterThrow : es) a -> Eff es a -runOuterThrow = interpret $ \_ -> \case +runOuterThrow = interpret_ $ \case OuterThrow -> throwError "outer" diff --git a/effectful/tests/NonDetTests.hs b/effectful/tests/NonDetTests.hs index 3b675c92..8cb558ef 100644 --- a/effectful/tests/NonDetTests.hs +++ b/effectful/tests/NonDetTests.hs @@ -84,7 +84,7 @@ outerEmpty :: (HasCallStack, OuterEmpty :> es) => Eff es a outerEmpty = send OuterEmpty runOuterEmpty :: NonDet :> es => Eff (OuterEmpty : es) a -> Eff es a -runOuterEmpty = interpret $ \_ -> \case +runOuterEmpty = interpret_ $ \case OuterEmpty -> emptyEff ---- diff --git a/effectful/tests/StateTests.hs b/effectful/tests/StateTests.hs index cbbcf5df..b5d6ae76 100644 --- a/effectful/tests/StateTests.hs +++ b/effectful/tests/StateTests.hs @@ -117,7 +117,7 @@ putInt = send . PutInt runHasInt :: Int -> Eff (HasInt : es) a -> Eff es a runHasInt n = -- reinterpret with redundant local effects - reinterpret (evalState () . evalState n . evalState True) $ \_ -> \case + reinterpret_ (evalState () . evalState n . evalState True) $ \case GetInt -> get PutInt i -> put i