From 34bc1b509d8f4fa677363f5ad86e15e48e50495b Mon Sep 17 00:00:00 2001 From: Andrzej Rybczak Date: Mon, 4 May 2026 15:36:06 +0200 Subject: [PATCH] Remove Effectful.Internal.MTL module 1. Less orphan instances to worry about. 2. No confusing 'MTL' shown if these are fully qualified in GHC error messages. --- effectful-core/effectful-core.cabal | 1 - effectful-core/src/Effectful.hs | 1 - effectful-core/src/Effectful/Error/Dynamic.hs | 2 +- effectful-core/src/Effectful/Internal/MTL.hs | 90 ----------------- .../src/Effectful/Internal/Monad.hs | 96 +++++++++++++++++++ .../src/Effectful/Reader/Dynamic.hs | 2 +- effectful-core/src/Effectful/State/Dynamic.hs | 2 +- .../src/Effectful/Writer/Dynamic.hs | 2 +- 8 files changed, 100 insertions(+), 96 deletions(-) delete mode 100644 effectful-core/src/Effectful/Internal/MTL.hs diff --git a/effectful-core/effectful-core.cabal b/effectful-core/effectful-core.cabal index 5b82b4b2..39fc9f0c 100644 --- a/effectful-core/effectful-core.cabal +++ b/effectful-core/effectful-core.cabal @@ -92,7 +92,6 @@ library Effectful.Fail Effectful.Internal.Effect Effectful.Internal.Env - Effectful.Internal.MTL Effectful.Internal.Monad Effectful.Internal.Unlift Effectful.Internal.Utils diff --git a/effectful-core/src/Effectful.hs b/effectful-core/src/Effectful.hs index 5b580de0..fbd8edf1 100644 --- a/effectful-core/src/Effectful.hs +++ b/effectful-core/src/Effectful.hs @@ -64,7 +64,6 @@ import Control.Monad.IO.Unlift import Effectful.Internal.Effect import Effectful.Internal.Env -import Effectful.Internal.MTL () import Effectful.Internal.Monad -- $intro diff --git a/effectful-core/src/Effectful/Error/Dynamic.hs b/effectful-core/src/Effectful/Error/Dynamic.hs index 174b57ad..d9fbcac1 100644 --- a/effectful-core/src/Effectful/Error/Dynamic.hs +++ b/effectful-core/src/Effectful/Error/Dynamic.hs @@ -34,7 +34,7 @@ import GHC.Stack (withFrozenCallStack) import Effectful import Effectful.Dispatch.Dynamic import Effectful.Error.Static qualified as E -import Effectful.Internal.MTL (Error(..)) +import Effectful.Internal.Monad (Error(..)) -- | Handle errors of type @e@ (via "Effectful.Error.Static"). runError diff --git a/effectful-core/src/Effectful/Internal/MTL.hs b/effectful-core/src/Effectful/Internal/MTL.hs deleted file mode 100644 index 8358522e..00000000 --- a/effectful-core/src/Effectful/Internal/MTL.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} --- | Definitions and instances for MTL compatibility. --- --- This module is intended for internal use only, and may change without warning --- in subsequent releases. -module Effectful.Internal.MTL where - -import Control.Monad.Except qualified as MTL -import Control.Monad.Reader qualified as MTL -import Control.Monad.State qualified as MTL -import Control.Monad.Writer qualified as MTL -import GHC.Stack (CallStack) - -import Effectful.Internal.Effect -import Effectful.Internal.Env -import Effectful.Internal.Monad - --- | Provide the ability to handle errors of type @e@. -data Error e :: Effect where - -- | @since 2.4.0.0 - ThrowErrorWith :: (e -> String) -> e -> Error e m a - CatchError :: m a -> (CallStack -> e -> m a) -> Error e m a - -type instance DispatchOf (Error e) = Dynamic - --- | Instance included for compatibility with existing code. -instance - ( Show e - , Error e :> es - , MTL.MonadError e (Eff es) - ) => MTL.MonadError e (Eff es) where - throwError = send . ThrowErrorWith show - catchError action = send . CatchError action . const - ----------------------------------------- - -data Reader r :: Effect where - Ask :: Reader r m r - Local :: (r -> r) -> m a -> Reader r m a - -type instance DispatchOf (Reader r) = Dynamic - --- | Instance included for compatibility with existing code. -instance - ( Reader r :> es - , MTL.MonadReader r (Eff es) - ) => MTL.MonadReader r (Eff es) where - ask = send Ask - local f = send . Local f - reader f = f <$> send Ask - ----------------------------------------- - --- | Provide access to a mutable value of type @s@. -data State s :: Effect where - Get :: State s m s - Put :: s -> State s m () - State :: (s -> (a, s)) -> State s m a - StateM :: (s -> m (a, s)) -> State s m a - -type instance DispatchOf (State s) = Dynamic - --- | Instance included for compatibility with existing code. -instance - ( State s :> es - , MTL.MonadState s (Eff es) - ) => MTL.MonadState s (Eff es) where - get = send Get - put = send . Put - state = send . State - ----------------------------------------- - --- | Provide access to a write only value of type @w@. -data Writer w :: Effect where - Tell :: w -> Writer w m () - Listen :: m a -> Writer w m (a, w) - -type instance DispatchOf (Writer w) = Dynamic - --- | Instance included for compatibility with existing code. -instance - ( Monoid w - , Writer w :> es - , MTL.MonadWriter w (Eff es) - ) => MTL.MonadWriter w (Eff es) where - writer (a, w) = a <$ send (Tell w) - tell = send . Tell - listen = send . Listen - pass = error "pass is not implemented due to ambiguous semantics in presence of runtime exceptions" diff --git a/effectful-core/src/Effectful/Internal/Monad.hs b/effectful-core/src/Effectful/Internal/Monad.hs index 3c22f98b..fa29522a 100644 --- a/effectful-core/src/Effectful/Internal/Monad.hs +++ b/effectful-core/src/Effectful/Internal/Monad.hs @@ -30,6 +30,18 @@ module Effectful.Internal.Monad , PrimStateEff , runPrim + -- * Error + , Error(..) + + -- * Reader + , Reader(..) + + -- * State + , State(..) + + -- * Writer + , Writer(..) + -- * Lifting , raise , raiseWith @@ -83,11 +95,15 @@ import Control.Exception qualified as E import Control.Monad import Control.Monad.Base import Control.Monad.Catch qualified as C +import Control.Monad.Except qualified as MTL import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Primitive +import Control.Monad.Reader qualified as MTL +import Control.Monad.State qualified as MTL import Control.Monad.Trans.Control +import Control.Monad.Writer qualified as MTL import Data.Kind (Constraint) import GHC.Exts (oneShot) import GHC.IO (IO(..)) @@ -472,6 +488,86 @@ instance Prim :> es => PrimMonad (Eff es) where type PrimState (Eff es) = PrimStateEff primitive = unsafeEff_ . IO . unsafeCoerce +---------------------------------------- +-- Error + +-- | Provide the ability to handle errors of type @e@. +data Error e :: Effect where + -- | @since 2.4.0.0 + ThrowErrorWith :: (e -> String) -> e -> Error e m a + CatchError :: m a -> (CallStack -> e -> m a) -> Error e m a + +type instance DispatchOf (Error e) = Dynamic + +-- | Instance included for compatibility with existing code. +instance + ( Show e + , Error e :> es + , MTL.MonadError e (Eff es) + ) => MTL.MonadError e (Eff es) where + throwError = send . ThrowErrorWith show + catchError action = send . CatchError action . const + +---------------------------------------- +-- Reader + +data Reader r :: Effect where + Ask :: Reader r m r + Local :: (r -> r) -> m a -> Reader r m a + +type instance DispatchOf (Reader r) = Dynamic + +-- | Instance included for compatibility with existing code. +instance + ( Reader r :> es + , MTL.MonadReader r (Eff es) + ) => MTL.MonadReader r (Eff es) where + ask = send Ask + local f = send . Local f + reader f = f <$> send Ask + +---------------------------------------- +-- State + +-- | Provide access to a mutable value of type @s@. +data State s :: Effect where + Get :: State s m s + Put :: s -> State s m () + State :: (s -> (a, s)) -> State s m a + StateM :: (s -> m (a, s)) -> State s m a + +type instance DispatchOf (State s) = Dynamic + +-- | Instance included for compatibility with existing code. +instance + ( State s :> es + , MTL.MonadState s (Eff es) + ) => MTL.MonadState s (Eff es) where + get = send Get + put = send . Put + state = send . State + +---------------------------------------- +-- Writer + +-- | Provide access to a write only value of type @w@. +data Writer w :: Effect where + Tell :: w -> Writer w m () + Listen :: m a -> Writer w m (a, w) + +type instance DispatchOf (Writer w) = Dynamic + +-- | Instance included for compatibility with existing code. +instance + ( Monoid w + , Writer w :> es + , MTL.MonadWriter w (Eff es) + ) => MTL.MonadWriter w (Eff es) where + writer (a, w) = a <$ send (Tell w) + tell = send . Tell + listen = send . Listen + pass = error "pass is not implemented due to ambiguous semantics in presence of runtime exceptions" + ---------------------------------------- -- Lifting diff --git a/effectful-core/src/Effectful/Reader/Dynamic.hs b/effectful-core/src/Effectful/Reader/Dynamic.hs index 7ffc7be4..742b2d2f 100644 --- a/effectful-core/src/Effectful/Reader/Dynamic.hs +++ b/effectful-core/src/Effectful/Reader/Dynamic.hs @@ -20,7 +20,7 @@ module Effectful.Reader.Dynamic import Effectful import Effectful.Dispatch.Dynamic -import Effectful.Internal.MTL (Reader(..)) +import Effectful.Internal.Monad (Reader(..)) -- | Run the 'Reader' effect with the given initial environment. runReader diff --git a/effectful-core/src/Effectful/State/Dynamic.hs b/effectful-core/src/Effectful/State/Dynamic.hs index ef324545..a22095fc 100644 --- a/effectful-core/src/Effectful/State/Dynamic.hs +++ b/effectful-core/src/Effectful/State/Dynamic.hs @@ -32,7 +32,7 @@ module Effectful.State.Dynamic import Effectful import Effectful.Dispatch.Dynamic -import Effectful.Internal.MTL (State(..)) +import Effectful.Internal.Monad (State(..)) import Effectful.State.Static.Local qualified as L import Effectful.State.Static.Shared qualified as S diff --git a/effectful-core/src/Effectful/Writer/Dynamic.hs b/effectful-core/src/Effectful/Writer/Dynamic.hs index b9e29d72..f8978367 100644 --- a/effectful-core/src/Effectful/Writer/Dynamic.hs +++ b/effectful-core/src/Effectful/Writer/Dynamic.hs @@ -27,7 +27,7 @@ module Effectful.Writer.Dynamic import Effectful import Effectful.Dispatch.Dynamic -import Effectful.Internal.MTL (Writer(..)) +import Effectful.Internal.Monad (Writer(..)) import Effectful.Writer.Static.Local qualified as L import Effectful.Writer.Static.Shared qualified as S