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

@@ -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
+          $CABAL --store-dir=$HOME/.haskell-ci-tools/store v2-install $ARG_COMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.22.0'
-          if [ $((HCNUMVER < 91000)) -ne 0 ] ; then doctest --version ; fi
+          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
+          cd ${PKGDIR_effectful_core} || false
-          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
+          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
-          if [ $((HCNUMVER < 91000)) -ne 0 ] ; then cd ${PKGDIR_effectful_th} || false ; fi
+          cd ${PKGDIR_effectful_th} || false
-          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
+          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
-          if [ $((HCNUMVER < 91000)) -ne 0 ] ; then cd ${PKGDIR_effectful} || false ; fi
+          cd ${PKGDIR_effectful} || false
-          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
+          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

cabal.haskell-ci

@@ -1,6 +1,6 @@
 branches:       master
 
-doctest:        <9.9
+doctest:        <9.11
 doctest-skip:   effectful-plugin
 
 tests:          True

doctest.sh

@@ -27,6 +27,7 @@ run_doctest() {
     -XLambdaCase \
     -XMultiParamTypeClasses \
     -XNoStarIsType \
+    -XPolyKinds \
     -XRankNTypes \
     -XRecordWildCards \
     -XRoleAnnotations \

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.

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

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

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

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
+  ( -- * Effect
-    -- $example
+    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

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))

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

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)

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)

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

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

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)

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

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)

effectful-plugin/effectful-plugin.cabal

@@ -43,6 +43,7 @@ common language
                         LambdaCase
                         MultiParamTypeClasses
                         NoStarIsType
+                        PolyKinds
                         RankNTypes
                         RecordWildCards
                         RoleAnnotations

effectful-th/effectful-th.cabal

@@ -43,6 +43,7 @@ common language
                         LambdaCase
                         MultiParamTypeClasses
                         NoStarIsType
+                        PolyKinds
                         RankNTypes
                         RecordWildCards
                         RoleAnnotations

effectful-th/tests/ThTests.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Main where
 

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.

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)
 

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

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)
+       if impl(ghc < 9.11)
-          build-depends: polysemy >= 1.9.1.3
+          build-depends: polysemy >= 1.9.2.0
 
     build-depends:    base
                     , async

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

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

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