tmpwip/eta-reader-t

2 files changed, 14 insertions, 16 deletions

diff --git a/compiler/GHC/Data/IOEnv.hs b/compiler/GHC/Data/IOEnv.hs
index cbdac011ab..f3d74ce517 100644
--- a/compiler/GHC/Data/IOEnv.hs
+++ b/compiler/GHC/Data/IOEnv.hs
@@ -116,7 +116,7 @@ runIOEnv env (IOEnv m) = runEtaReaderT m env
   -- thunks.  Sigh.
 
 fixM :: (a -> IOEnv env a) -> IOEnv env a
-fixM f = IOEnv (EtaReaderT (\ env -> fixIO (\ r -> runIOEnv env (f r))))
+fixM f = IOEnv (NoEtaReaderT (\ env -> fixIO (\ r -> runIOEnv env (f r))))
 
 
 ---------------------------
@@ -128,7 +128,7 @@ tryM :: IOEnv env r -> IOEnv env (Either IOEnvFailure r)
 -- to UserErrors.  But, say, pattern-match failures in GHC itself should
 -- not be caught here, else they'll be reported as errors in the program
 -- begin compiled!
-tryM (IOEnv (EtaReaderT thing)) = IOEnv (EtaReaderT (\ env -> tryIOEnvFailure (thing env)))
+tryM (IOEnv (EtaReaderT thing)) = IOEnv (NoEtaReaderT (\ env -> tryIOEnvFailure (thing env)))
 
 tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a)
 tryIOEnvFailure = try
@@ -137,7 +137,7 @@ tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r)
 -- Catch *all* synchronous exceptions
 -- This is used when running a Template-Haskell splice, when
 -- even a pattern-match failure is a programmer error
-tryAllM (IOEnv (EtaReaderT thing)) = IOEnv (EtaReaderT (\ env -> safeTry (thing env)))
+tryAllM (IOEnv (EtaReaderT thing)) = IOEnv (NoEtaReaderT (\ env -> safeTry (thing env)))
 
 -- | Like 'try', but doesn't catch asynchronous exceptions
 safeTry :: IO a -> IO (Either SomeException a)
@@ -155,14 +155,14 @@ safeTry act = do
         throwIO e
 
 tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r)
-tryMostM (IOEnv (EtaReaderT thing)) = IOEnv (EtaReaderT (\ env -> tryMost (thing env)))
+tryMostM (IOEnv (EtaReaderT thing)) = IOEnv (NoEtaReaderT (\ env -> tryMost (thing env)))
 
 ---------------------------
 unsafeInterleaveM :: IOEnv env a -> IOEnv env a
-unsafeInterleaveM (IOEnv (EtaReaderT m)) = IOEnv (EtaReaderT (\ env -> unsafeInterleaveIO (m env)))
+unsafeInterleaveM (IOEnv (EtaReaderT m)) = IOEnv (NoEtaReaderT (\ env -> unsafeInterleaveIO (m env)))
 
 uninterruptibleMaskM_ :: IOEnv env a -> IOEnv env a
-uninterruptibleMaskM_ (IOEnv (EtaReaderT m)) = IOEnv (EtaReaderT (\ env -> uninterruptibleMask_ (m env)))
+uninterruptibleMaskM_ (IOEnv (EtaReaderT m)) = IOEnv (NoEtaReaderT (\ env -> uninterruptibleMask_ (m env)))
 
 ----------------------------------------------------------------------
 -- Accessing input/output
diff --git a/compiler/GHC/Utils/Monad/EtaReader.hs b/compiler/GHC/Utils/Monad/EtaReader.hs
index 45eaa7a86f..62035e00a1 100644
--- a/compiler/GHC/Utils/Monad/EtaReader.hs
+++ b/compiler/GHC/Utils/Monad/EtaReader.hs
@@ -22,7 +22,7 @@ module GHC.Utils.Monad.EtaReader (
     mapEtaReader,
     withEtaReader,
     -- * The EtaReaderT monad transformer
-    EtaReaderT(EtaReaderT),
+    EtaReaderT(NoEtaReaderT, EtaReaderT),
     runEtaReaderT,
     mapEtaReaderT,
     withEtaReaderT,
@@ -42,7 +42,6 @@ import Control.Monad.Signatures
 import Control.Monad.Trans.Class
 import Data.Functor.Contravariant
 import Data.Functor.Identity
-import Data.Coerce
 
 import Control.Applicative
 import Control.Monad
@@ -93,23 +92,22 @@ withEtaReader = withEtaReaderT
 
 -- | 'Control.Monad.Trans.Reader.ReaderT', but eta-expanded.
 -- See Note [The one-shot state monad trick] in GHC.Utils.Monad.
-newtype EtaReaderT r m a = EtaReaderT' (r -> m a)
-    deriving (Generic, Generic1)
+newtype EtaReaderT r m a
+  = NoEtaReaderT { runEtaReaderT :: r -> m a }
+  -- ^ Using 'NoEtaReaderT' will *not* try to eagerly eta-expand the wrapped function.
+  -- Sometimes this is desirable,
+  deriving (Generic, Generic1)
 
 -- This pattern synonym makes the monad eta-expand,
 -- which as a very beneficial effect on compiler performance
 -- See #18202.
 -- See Note [The one-shot state monad trick] in GHC.Utils.Monad
 pattern EtaReaderT :: (r -> m a) -> EtaReaderT r m a
-pattern EtaReaderT m <- EtaReaderT' m
+pattern EtaReaderT m <- NoEtaReaderT m
   where
-    EtaReaderT m = EtaReaderT' (oneShot $ \r -> m r)
+    EtaReaderT m = NoEtaReaderT (oneShot $ \r -> m r)
 {-# COMPLETE EtaReaderT #-}
 
-runEtaReaderT :: EtaReaderT r m a -> r -> m a
-runEtaReaderT = coerce
-{-# INLINE runEtaReaderT #-}
-
 -- | Transform the computation inside a @EtaReaderT@.
 --
 -- * @'runEtaReaderT' ('mapEtaReaderT' f m) = f . 'runEtaReaderT' m@