From 0ef04f2fc86a5f6d254227942e6766a05c2f9fb7 Mon Sep 17 00:00:00 2001 From: Andrzej Rybczak Date: Thu, 22 Aug 2024 20:59:21 +0200 Subject: [PATCH] Improve Labeled and add labeled versions of base effects (#228) * Improve Labeled and add labeled versions of base effects * Remove .VDQ modules for now * tests * doctest * more doctest * ci * run doctest with 9.10 * run polysemy with 9.10 --- .github/workflows/haskell-ci.yml | 20 +- cabal.haskell-ci | 2 +- doctest.sh | 1 + effectful-core/CHANGELOG.md | 3 + effectful-core/effectful-core.cabal | 5 + effectful-core/src/Effectful/Error/Dynamic.hs | 2 +- effectful-core/src/Effectful/Error/Static.hs | 3 +- effectful-core/src/Effectful/Labeled.hs | 71 +++----- effectful-core/src/Effectful/Labeled/Error.hs | 111 ++++++++++++ .../src/Effectful/Labeled/Reader.hs | 66 +++++++ effectful-core/src/Effectful/Labeled/State.hs | 171 ++++++++++++++++++ .../src/Effectful/Labeled/Writer.hs | 106 +++++++++++ effectful-core/src/Effectful/Reader/Static.hs | 4 +- .../src/Effectful/State/Static/Local.hs | 4 +- .../src/Effectful/State/Static/Shared.hs | 3 +- .../src/Effectful/Writer/Static/Local.hs | 3 +- .../src/Effectful/Writer/Static/Shared.hs | 3 +- effectful-plugin/effectful-plugin.cabal | 1 + effectful-th/effectful-th.cabal | 1 + effectful-th/tests/ThTests.hs | 1 - effectful/CHANGELOG.md | 3 + effectful/bench/Countdown.hs | 41 +++++ effectful/bench/Main.hs | 8 + effectful/effectful.cabal | 10 +- effectful/tests/LabeledTests.hs | 61 +++++++ effectful/tests/Main.hs | 2 + effectful/tests/ReaderTests.hs | 1 + 27 files changed, 645 insertions(+), 62 deletions(-) create mode 100644 effectful-core/src/Effectful/Labeled/Error.hs create mode 100644 effectful-core/src/Effectful/Labeled/Reader.hs create mode 100644 effectful-core/src/Effectful/Labeled/State.hs create mode 100644 effectful-core/src/Effectful/Labeled/Writer.hs create mode 100644 effectful/tests/LabeledTests.hs diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index a221b00..6eecdc0 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -145,7 +145,7 @@ jobs: - name: cache (tools) uses: actions/cache/restore@v4 with: - key: ${{ runner.os }}-${{ matrix.compiler }}-tools-36dffdd0 + key: ${{ runner.os }}-${{ matrix.compiler }}-tools-caa01dbf path: ~/.haskell-ci-tools - name: install cabal-plan run: | @@ -158,13 +158,13 @@ jobs: cabal-plan --version - name: install doctest run: | - if [ $((HCNUMVER < 91000)) -ne 0 ] ; then $CABAL --store-dir=$HOME/.haskell-ci-tools/store v2-install $ARG_COMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.22.0' ; fi - if [ $((HCNUMVER < 91000)) -ne 0 ] ; then doctest --version ; fi + $CABAL --store-dir=$HOME/.haskell-ci-tools/store v2-install $ARG_COMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.22.0' + doctest --version - name: save cache (tools) uses: actions/cache/save@v4 if: always() with: - key: ${{ runner.os }}-${{ matrix.compiler }}-tools-36dffdd0 + key: ${{ runner.os }}-${{ matrix.compiler }}-tools-caa01dbf path: ~/.haskell-ci-tools - name: checkout uses: actions/checkout@v4 @@ -247,12 +247,12 @@ jobs: $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct - name: doctest run: | - if [ $((HCNUMVER < 91000)) -ne 0 ] ; then cd ${PKGDIR_effectful_core} || false ; fi - if [ $((HCNUMVER < 91000)) -ne 0 ] ; then doctest -XHaskell2010 -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XImportQualifiedPost -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src ; fi - if [ $((HCNUMVER < 91000)) -ne 0 ] ; then cd ${PKGDIR_effectful_th} || false ; fi - if [ $((HCNUMVER < 91000)) -ne 0 ] ; then doctest -XHaskell2010 -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XImportQualifiedPost -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src ; fi - if [ $((HCNUMVER < 91000)) -ne 0 ] ; then cd ${PKGDIR_effectful} || false ; fi - if [ $((HCNUMVER < 91000)) -ne 0 ] ; then doctest -XHaskell2010 -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XImportQualifiedPost -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src ; fi + cd ${PKGDIR_effectful_core} || false + doctest -XHaskell2010 -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XImportQualifiedPost -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XPolyKinds -XRankNTypes -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src + cd ${PKGDIR_effectful_th} || false + doctest -XHaskell2010 -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XImportQualifiedPost -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XPolyKinds -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src + cd ${PKGDIR_effectful} || false + doctest -XHaskell2010 -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XImportQualifiedPost -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XPolyKinds -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src - name: cabal check run: | cd ${PKGDIR_effectful_core} || false diff --git a/cabal.haskell-ci b/cabal.haskell-ci index d9de3f1..38fcbeb 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -1,6 +1,6 @@ branches: master -doctest: <9.9 +doctest: <9.11 doctest-skip: effectful-plugin tests: True diff --git a/doctest.sh b/doctest.sh index 7b9167c..38f2780 100755 --- a/doctest.sh +++ b/doctest.sh @@ -27,6 +27,7 @@ run_doctest() { -XLambdaCase \ -XMultiParamTypeClasses \ -XNoStarIsType \ + -XPolyKinds \ -XRankNTypes \ -XRecordWildCards \ -XRoleAnnotations \ diff --git a/effectful-core/CHANGELOG.md b/effectful-core/CHANGELOG.md index 8aae557..71f2113 100644 --- a/effectful-core/CHANGELOG.md +++ b/effectful-core/CHANGELOG.md @@ -3,6 +3,9 @@ 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`. # effectful-core-2.3.1.0 (2024-06-07) * Drop support for GHC 8.8. diff --git a/effectful-core/effectful-core.cabal b/effectful-core/effectful-core.cabal index 134d571..cff9aee 100644 --- a/effectful-core/effectful-core.cabal +++ b/effectful-core/effectful-core.cabal @@ -47,6 +47,7 @@ common language LambdaCase MultiParamTypeClasses NoStarIsType + PolyKinds RankNTypes RoleAnnotations ScopedTypeVariables @@ -88,6 +89,10 @@ library 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/effectful-core/src/Effectful/Error/Dynamic.hs b/effectful-core/src/Effectful/Error/Dynamic.hs index 5564d49..69eb863 100644 --- a/effectful-core/src/Effectful/Error/Dynamic.hs +++ b/effectful-core/src/Effectful/Error/Dynamic.hs @@ -102,7 +102,7 @@ catchError m = send . CatchError m -- | 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/effectful-core/src/Effectful/Error/Static.hs b/effectful-core/src/Effectful/Error/Static.hs index f73aacf..c73158b 100644 --- a/effectful-core/src/Effectful/Error/Static.hs +++ b/effectful-core/src/Effectful/Error/Static.hs @@ -99,6 +99,7 @@ module Effectful.Error.Static ) where import Control.Exception +import Data.Kind import GHC.Stack import Effectful @@ -107,7 +108,7 @@ import Effectful.Dispatch.Static.Primitive 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 diff --git a/effectful-core/src/Effectful/Labeled.hs b/effectful-core/src/Effectful/Labeled.hs index 27498a6..1471f4b 100644 --- a/effectful-core/src/Effectful/Labeled.hs +++ b/effectful-core/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,42 +21,30 @@ import Unsafe.Coerce (unsafeCoerce) import Effectful import Effectful.Dispatch.Static --- $example --- --- An effect can be assigned multiple labels and you can have all of them --- available at the same time. --- --- >>> import Effectful.Reader.Static --- --- >>> :{ --- 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 --- :} --- --- >>> :{ --- runPureEff @String --- . runLabeled @"a" (runReader "a") --- . runLabeled @"b" (runReader "b") --- . runReader "c" --- $ action --- :} --- "ab" - -- | Assign a label to an effect. -data Labeled (label :: k) (e :: Effect) :: Effect +-- +-- The constructor is for sending labeled operations of a dynamically dispatched +-- effect to the handler: +-- +-- >>> import Effectful.Dispatch.Dynamic +-- +-- >>> :{ +-- data X :: Effect where +-- X :: X m Int +-- type instance DispatchOf X = Dynamic +-- :} +-- +-- >>> :{ +-- runPureEff . runLabeled @"x" (interpret_ $ \X -> pure 333) $ do +-- send $ Labeled @"x" X +-- :} +-- 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) @@ -70,7 +57,9 @@ runLabeled -> 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 diff --git a/effectful-core/src/Effectful/Labeled/Error.hs b/effectful-core/src/Effectful/Labeled/Error.hs new file mode 100644 index 0000000..fef8114 --- /dev/null +++ b/effectful-core/src/Effectful/Labeled/Error.hs @@ -0,0 +1,111 @@ +{-# 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 + , 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 + . 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 + . (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 + . 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 + . (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@. +throwError + :: forall label e es a + . (HasCallStack, Labeled label (Error e) :> es) + => e + -- ^ The error. + -> Eff es a +throwError e = withFrozenCallStack $ send (Labeled @label $ ThrowError e) + +-- | 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/effectful-core/src/Effectful/Labeled/Reader.hs b/effectful-core/src/Effectful/Labeled/Reader.hs new file mode 100644 index 0000000..3652295 --- /dev/null +++ b/effectful-core/src/Effectful/Labeled/Reader.hs @@ -0,0 +1,66 @@ +{-# 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 + . 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/effectful-core/src/Effectful/Labeled/State.hs b/effectful-core/src/Effectful/Labeled/State.hs new file mode 100644 index 0000000..fabd909 --- /dev/null +++ b/effectful-core/src/Effectful/Labeled/State.hs @@ -0,0 +1,171 @@ +{-# 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 + . 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 + . 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 + . 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 + . 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 + . 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 + . 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/effectful-core/src/Effectful/Labeled/Writer.hs b/effectful-core/src/Effectful/Labeled/Writer.hs new file mode 100644 index 0000000..c23f206 --- /dev/null +++ b/effectful-core/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 + . 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 + . 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 + . 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 + . 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/effectful-core/src/Effectful/Reader/Static.hs b/effectful-core/src/Effectful/Reader/Static.hs index 10acc10..9b50e45 100644 --- a/effectful-core/src/Effectful/Reader/Static.hs +++ b/effectful-core/src/Effectful/Reader/Static.hs @@ -13,12 +13,14 @@ module Effectful.Reader.Static , 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 diff --git a/effectful-core/src/Effectful/State/Static/Local.hs b/effectful-core/src/Effectful/State/Static/Local.hs index 159eb63..c23a7eb 100644 --- a/effectful-core/src/Effectful/State/Static/Local.hs +++ b/effectful-core/src/Effectful/State/Static/Local.hs @@ -41,11 +41,13 @@ module Effectful.State.Static.Local , 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 diff --git a/effectful-core/src/Effectful/State/Static/Shared.hs b/effectful-core/src/Effectful/State/Static/Shared.hs index 5d4236b..900c43e 100644 --- a/effectful-core/src/Effectful/State/Static/Shared.hs +++ b/effectful-core/src/Effectful/State/Static/Shared.hs @@ -46,6 +46,7 @@ module Effectful.State.Static.Shared ) where import Control.Concurrent.MVar +import Data.Kind import Effectful import Effectful.Dispatch.Static @@ -53,7 +54,7 @@ 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) diff --git a/effectful-core/src/Effectful/Writer/Static/Local.hs b/effectful-core/src/Effectful/Writer/Static/Local.hs index 49943da..0e73450 100644 --- a/effectful-core/src/Effectful/Writer/Static/Local.hs +++ b/effectful-core/src/Effectful/Writer/Static/Local.hs @@ -28,6 +28,7 @@ module Effectful.Writer.Static.Local ) where import Control.Exception (onException, mask) +import Data.Kind import Effectful import Effectful.Dispatch.Static @@ -35,7 +36,7 @@ import Effectful.Dispatch.Static.Primitive -- | 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 diff --git a/effectful-core/src/Effectful/Writer/Static/Shared.hs b/effectful-core/src/Effectful/Writer/Static/Shared.hs index a4b8c61..2d2c915 100644 --- a/effectful-core/src/Effectful/Writer/Static/Shared.hs +++ b/effectful-core/src/Effectful/Writer/Static/Shared.hs @@ -28,6 +28,7 @@ module Effectful.Writer.Static.Shared ) where import Control.Exception (onException, uninterruptibleMask) +import Data.Kind import Effectful import Effectful.Dispatch.Static @@ -35,7 +36,7 @@ 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) diff --git a/effectful-plugin/effectful-plugin.cabal b/effectful-plugin/effectful-plugin.cabal index 5b71271..f83774b 100644 --- a/effectful-plugin/effectful-plugin.cabal +++ b/effectful-plugin/effectful-plugin.cabal @@ -43,6 +43,7 @@ common language LambdaCase MultiParamTypeClasses NoStarIsType + PolyKinds RankNTypes RecordWildCards RoleAnnotations diff --git a/effectful-th/effectful-th.cabal b/effectful-th/effectful-th.cabal index b4ad3c1..37eec6a 100644 --- a/effectful-th/effectful-th.cabal +++ b/effectful-th/effectful-th.cabal @@ -43,6 +43,7 @@ common language LambdaCase MultiParamTypeClasses NoStarIsType + PolyKinds RankNTypes RecordWildCards RoleAnnotations diff --git a/effectful-th/tests/ThTests.hs b/effectful-th/tests/ThTests.hs index 634f2d9..29d23da 100644 --- a/effectful-th/tests/ThTests.hs +++ b/effectful-th/tests/ThTests.hs @@ -1,6 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TemplateHaskell #-} module Main where diff --git a/effectful/CHANGELOG.md b/effectful/CHANGELOG.md index 4321cdc..a5fde59 100644 --- a/effectful/CHANGELOG.md +++ b/effectful/CHANGELOG.md @@ -3,6 +3,9 @@ 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`. # effectful-2.3.1.0 (2024-06-07) * Drop support for GHC 8.8. diff --git a/effectful/bench/Countdown.hs b/effectful/bench/Countdown.hs index aa8657f..92ceae6 100644 --- a/effectful/bench/Countdown.hs +++ b/effectful/bench/Countdown.hs @@ -285,6 +285,47 @@ countdownEffectfulDoubleDynSharedDeep n = E.runPureEff where runR = E.runReader () +---------------------------------------- +-- effectful (labeled-dynamic-send) + +programEffectfulLabeledDynamicSend + :: E.Labeled "s" (ED.State Integer) E.:> es + => E.Eff es Integer +programEffectfulLabeledDynamicSend = do + n <- E.send . E.Labeled @"s" $ ED.Get @Integer + if n <= 0 + then pure n + else do + E.send . E.Labeled @"s" $ ED.Put (n - 1) + programEffectfulLabeledDynamicSend +{-# NOINLINE programEffectfulLabeledDynamicSend #-} + +countdownEffectfulLabeledDynSendLocal :: Integer -> (Integer, Integer) +countdownEffectfulLabeledDynSendLocal n = + E.runPureEff . E.runLabeled @"s" (ED.runStateLocal n) $ programEffectfulLabeledDynamicSend + +countdownEffectfulLabeledDynSendShared :: Integer -> (Integer, Integer) +countdownEffectfulLabeledDynSendShared n = + E.runPureEff . E.runLabeled @"s" (ED.runStateShared n) $ programEffectfulLabeledDynamicSend + +countdownEffectfulLabeledDynSendLocalDeep :: Integer -> (Integer, Integer) +countdownEffectfulLabeledDynSendLocalDeep n = E.runPureEff + . runR . runR . runR . runR . runR + . E.runLabeled @"s" (ED.runStateLocal n) + . runR . runR . runR . runR . runR + $ programEffectfulLabeledDynamicSend + where + runR = E.runReader () + +countdownEffectfulLabeledDynSendSharedDeep :: Integer -> (Integer, Integer) +countdownEffectfulLabeledDynSendSharedDeep n = E.runPureEff + . runR . runR . runR . runR . runR + . E.runLabeled @"s" (ED.runStateShared n) + . runR . runR . runR . runR . runR + $ programEffectfulLabeledDynamicSend + where + runR = E.runReader () + ---------------------------------------- -- effectful (labeled-dynamic) diff --git a/effectful/bench/Main.hs b/effectful/bench/Main.hs index ec8870c..2d998bf 100644 --- a/effectful/bench/Main.hs +++ b/effectful/bench/Main.hs @@ -64,6 +64,10 @@ countdown n = bgroup (show n) [ bench "shallow" $ nf countdownEffectfulDynLocal n , bench "deep" $ nf countdownEffectfulDynLocalDeep n ] + , bgroup "effectful (local/dynamic/labeled/send)" + [ bench "shallow" $ nf countdownEffectfulLabeledDynSendLocal n + , bench "deep" $ nf countdownEffectfulLabeledDynSendLocalDeep n + ] , bgroup "effectful (shared/static)" [ bench "shallow" $ nf countdownEffectfulShared n , bench "deep" $ nf countdownEffectfulSharedDeep n @@ -72,6 +76,10 @@ countdown n = bgroup (show n) [ bench "shallow" $ nf countdownEffectfulDynShared n , bench "deep" $ nf countdownEffectfulDynSharedDeep n ] + , bgroup "effectful (shared/dynamic/labeled/send)" + [ bench "shallow" $ nf countdownEffectfulLabeledDynSendShared n + , bench "deep" $ nf countdownEffectfulLabeledDynSendSharedDeep n + ] #ifdef VERSION_cleff , bgroup "cleff (local)" [ bench "shallow" $ nf countdownCleffLocal n diff --git a/effectful/effectful.cabal b/effectful/effectful.cabal index 28bfcb2..965a7ab 100644 --- a/effectful/effectful.cabal +++ b/effectful/effectful.cabal @@ -52,6 +52,7 @@ common language LambdaCase MultiParamTypeClasses NoStarIsType + PolyKinds RankNTypes RecordWildCards RoleAnnotations @@ -110,6 +111,10 @@ library , Effectful.Error.Dynamic , Effectful.Fail , Effectful.Labeled + , Effectful.Labeled.Error + , Effectful.Labeled.Reader + , Effectful.Labeled.State + , Effectful.Labeled.Writer , Effectful.NonDet , Effectful.Prim , Effectful.Provider @@ -149,6 +154,7 @@ test-suite test EnvTests EnvironmentTests ErrorTests + LabeledTests NonDetTests PrimTests ReaderTests @@ -174,8 +180,8 @@ benchmark bench if impl(ghc < 9.11) build-depends: fused-effects >= 1.1.2.2 - if impl(ghc < 9.9) - build-depends: polysemy >= 1.9.1.3 + if impl(ghc < 9.11) + build-depends: polysemy >= 1.9.2.0 build-depends: base , async diff --git a/effectful/tests/LabeledTests.hs b/effectful/tests/LabeledTests.hs new file mode 100644 index 0000000..8b084b3 --- /dev/null +++ b/effectful/tests/LabeledTests.hs @@ -0,0 +1,61 @@ +module LabeledTests (labeledTests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Labeled +import Effectful.Reader.Static +import Utils qualified as U + +labeledTests :: TestTree +labeledTests = testGroup "Labeled" + [ testCase "labeled behaves correctly" $ test_labeledBehavior + , testCase "(labeled . send) and (send . Labeled) behave the same" $ test_labeledSend + ] + +test_labeledBehavior :: Assertion +test_labeledBehavior = do + v <- runEff + . runLabeled @"a" (runReader "a") + . runLabeled @"b" (runReader "b") + . runReader "c" + $ action + assertEqual "expected result" "abc" v + where + 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 + c <- ask + pure $ a ++ b ++ c + +test_labeledSend :: Assertion +test_labeledSend = runEff $ do + runX 1 . runLabeled @"x" (runX 2) $ do + v0 <- send X2 + U.assertEqual "expected result" 1 v0 + v1 <- (labeled @"x" @X . send) X2 + U.assertEqual "expected result" 2 v1 + v2 <- (send . Labeled @"x") X2 + U.assertEqual "expected result" 2 v2 + +data X :: Effect where + X1 :: X m Int + X2 :: (X :> es, Labeled "x" X :> es) => X (Eff es) Int + +type instance DispatchOf X = Dynamic + +runX :: Int -> Eff (X : es) a -> Eff es a +runX x = interpret $ \env -> \case + X1 -> pure x + X2 -> localSeqUnlift env $ \unlift -> unlift $ send X1 diff --git a/effectful/tests/Main.hs b/effectful/tests/Main.hs index 63ed3d2..c2aa400 100644 --- a/effectful/tests/Main.hs +++ b/effectful/tests/Main.hs @@ -7,6 +7,7 @@ import ConcurrencyTests import EnvTests import EnvironmentTests import ErrorTests +import LabeledTests import NonDetTests import PrimTests import ReaderTests @@ -21,6 +22,7 @@ main = defaultMain $ testGroup "effectful" , envTests , environmentTests , errorTests + , labeledTests , nonDetTests , primTests , readerTests diff --git a/effectful/tests/ReaderTests.hs b/effectful/tests/ReaderTests.hs index 9b3a41a..882e281 100644 --- a/effectful/tests/ReaderTests.hs +++ b/effectful/tests/ReaderTests.hs @@ -5,6 +5,7 @@ import Test.Tasty.HUnit import Effectful import Effectful.Dispatch.Dynamic +import Effectful.Labeled import Effectful.Reader.Dynamic import Utils qualified as U