WIPwip/ds-no-hsc-env

4 files changed, 44 insertions, 29 deletions

diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs
index 63a5eb86cb..d92b0025a9 100644
--- a/compiler/GHC/Driver/Env/Types.hs
+++ b/compiler/GHC/Driver/Env/Types.hs
@@ -44,6 +44,11 @@ instance ContainsDynFlags HscEnv where
 instance HasLogger Hsc where
     getLogger = Hsc $ \e w -> return (hsc_logger e, w)
 
+instance ContainsLogger HscEnv where
+    extractLogger h = hsc_logger h
+
+instance ContainsHooks HscEnv where
+    extractHooks h = hsc_hooks h
 
 -- | HscEnv is like 'GHC.Driver.Monad.Session', except that some of the fields are immutable.
 -- An HscEnv is used to compile a single module from plain Haskell source
diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs
index 59db2c9372..a3ec64d735 100644
--- a/compiler/GHC/HsToCore/Types.hs
+++ b/compiler/GHC/HsToCore/Types.hs
@@ -17,7 +17,7 @@ import GHC.Types.SrcLoc
 import GHC.Types.Var
 import GHC.Types.Name.Reader (GlobalRdrEnv)
 import GHC.Hs (LForeignDecl, HsExpr, GhcTc)
-import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv, CompleteMatches)
+import GHC.Tc.Types (TcRnIfDs, IfGblEnv, IfLclEnv, CompleteMatches)
 import GHC.HsToCore.Pmc.Types (Nablas)
 import GHC.HsToCore.Errors.Types
 import GHC.Core (CoreExpr)
@@ -25,6 +25,7 @@ import GHC.Core.FamInstEnv
 import GHC.Utils.Outputable as Outputable
 import GHC.Unit.Module
 import GHC.Driver.Hooks (DsForeignsHook)
+import GHC.Driver.Session (DynFlags)
 import GHC.Data.OrdList (OrdList)
 import GHC.Types.ForeignStubs (ForeignStubs)
 
@@ -87,8 +88,13 @@ data DsMetaVal
   | DsSplice (HsExpr GhcTc) -- These bindings are introduced by
                             -- the PendingSplices on a Hs*Bracket
 
+data DsTopEnv = DsTopEnv
+  { ds_dflags :: DynFlags
+  , ds_hook :: DsForeignsHook
+  }
+
 -- | Desugaring monad. See also 'TcM'.
-type DsM = TcRnIf DsGblEnv DsLclEnv
+type DsM = TcRnIfDs DsTopEnv DsGblEnv DsLclEnv
 
 -- See Note [The Decoupling Abstract Data Hack]
 type instance DsForeignsHook = [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr))
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index c56cbc1322..138d57fdb8 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -24,11 +24,12 @@
 -- For state that is global and should be returned at the end (e.g not part
 -- of the stack mechanism), you should use a TcRef (= IORef) to store them.
 module GHC.Tc.Types(
-        TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module
+        TcRnIfDs, TcRnIf, TcRn,
+        TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module
         TcRef,
 
         -- The environment types
-        Env(..),
+        Env'(..), Env,
         TcGblEnv(..), TcLclEnv(..),
         setLclEnvTcLevel, getLclEnvTcLevel,
         setLclEnvLoc, getLclEnvLoc, lclEnvInGeneratedCode,
@@ -216,7 +217,8 @@ data NameShape = NameShape {
 The monad itself has to be defined here, because it is mentioned by ErrCtxt
 -}
 
-type TcRnIf a b = IOEnv (Env a b)
+type TcRnIfDs t a b = IOEnv (Env' t a b)
+type TcRnIf a b = TcRnIfDs HscEnv a b
 type TcRn       = TcRnIf TcGblEnv TcLclEnv    -- Type inference
 type IfM lcl    = TcRnIf IfGblEnv lcl         -- Iface stuff
 type IfG        = IfM ()                      --    Top level
@@ -238,9 +240,9 @@ type TcM  = TcRn
 -- We 'stack' these envs through the Reader like monad infrastructure
 -- as we move into an expression (although the change is focused in
 -- the lcl type).
-data Env gbl lcl
+data Env' top gbl lcl
   = Env {
-        env_top  :: !HscEnv, -- Top-level stuff that never changes
+        env_top  :: !top,    -- Top-level stuff that never changes
                              -- Includes all info about imported things
                              -- BangPattern is to fix leak, see #15111
 
@@ -252,16 +254,18 @@ data Env gbl lcl
         env_lcl  :: lcl      -- Nested stuff; changes as we go into
     }
 
-instance ContainsDynFlags (Env gbl lcl) where
-    extractDynFlags env = hsc_dflags (env_top env)
+type Env = Env' HscEnv
 
-instance ContainsHooks (Env gbl lcl) where
-    extractHooks env = hsc_hooks (env_top env)
+instance ContainsDynFlags top => ContainsDynFlags (Env' top gbl lcl) where
+    extractDynFlags env = extractDynFlags (env_top env)
 
-instance ContainsLogger (Env gbl lcl) where
-    extractLogger env = hsc_logger (env_top env)
+instance ContainsHooks top => ContainsHooks (Env' top gbl lcl) where
+    extractHooks env = extractHooks (env_top env)
 
-instance ContainsModule gbl => ContainsModule (Env gbl lcl) where
+instance ContainsLogger top => ContainsLogger (Env' top gbl lcl) where
+    extractLogger env = extractLogger (env_top env)
+
+instance ContainsModule gbl => ContainsModule (Env' top gbl lcl) where
     extractModule env = extractModule (env_gbl env)
 
 {-
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 571e02c7cf..11e7216a0b 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -471,32 +471,32 @@ initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside
 discardResult :: TcM a -> TcM ()
 discardResult a = a >> return ()
 
-getTopEnv :: TcRnIf gbl lcl HscEnv
+getTopEnv :: TcRnIfDs top gbl lcl top
 getTopEnv = do { env <- getEnv; return (env_top env) }
 
-updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+updTopEnv :: (top -> top) -> TcRnIfDs top gbl lcl a -> TcRnIfDs top gbl lcl a
 updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->
                           env { env_top = upd top })
 
-getGblEnv :: TcRnIf gbl lcl gbl
+getGblEnv :: TcRnIfDs top gbl lcl gbl
 getGblEnv = do { Env{..} <- getEnv; return env_gbl }
 
-updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+updGblEnv :: (gbl -> gbl) -> TcRnIfDs top gbl lcl a -> TcRnIfDs top gbl lcl a
 updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
                           env { env_gbl = upd gbl })
 
-setGblEnv :: gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
+setGblEnv :: gbl' -> TcRnIfDs top gbl' lcl a -> TcRnIfDs top gbl lcl a
 setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
 
-getLclEnv :: TcRnIf gbl lcl lcl
+getLclEnv :: TcRnIfDs top gbl lcl lcl
 getLclEnv = do { Env{..} <- getEnv; return env_lcl }
 
-updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+updLclEnv :: (lcl -> lcl) -> TcRnIfDs top gbl lcl a -> TcRnIfDs top gbl lcl a
 updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
                           env { env_lcl = upd lcl })
 
 
-setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
+setLclEnv :: lcl' -> TcRnIfDs top gbl lcl' a -> TcRnIfDs top gbl lcl a
 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
 
 restoreLclEnv :: TcLclEnv -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
@@ -507,13 +507,13 @@ restoreLclEnv new_lcl_env = updLclEnv upd
                                    , tcl_lie   = tcl_lie   old_lcl_env
                                    , tcl_usage = tcl_usage old_lcl_env }
 
-getEnvs :: TcRnIf gbl lcl (gbl, lcl)
+getEnvs :: TcRnIfDs top gbl lcl (gbl, lcl)
 getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
 
-setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
+setEnvs :: (gbl', lcl') -> TcRnIfDs top gbl' lcl' a -> TcRnIfDs top gbl lcl a
 setEnvs (gbl_env, lcl_env) = setGblEnv gbl_env . setLclEnv lcl_env
 
-updEnvs :: ((gbl,lcl) -> (gbl, lcl)) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+updEnvs :: ((gbl,lcl) -> (gbl, lcl)) -> TcRnIfDs top gbl lcl a -> TcRnIfDs top gbl lcl a
 updEnvs upd_envs = updEnv upd
   where
     upd env@(Env { env_gbl = gbl, env_lcl = lcl })
@@ -749,13 +749,13 @@ instance MonadUnique (IOEnv (Env gbl lcl)) where
 newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
 newTcRef = newMutVar
 
-readTcRef :: TcRef a -> TcRnIf gbl lcl a
+readTcRef :: TcRef a -> TcRnIfDs top gbl lcl a
 readTcRef = readMutVar
 
-writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
+writeTcRef :: TcRef a -> a -> TcRnIfDs top gbl lcl ()
 writeTcRef = writeMutVar
 
-updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
+updTcRef :: TcRef a -> (a -> a) -> TcRnIfDs top gbl lcl ()
 -- Returns ()
 updTcRef ref fn = liftIO $ modifyIORef' ref fn
 
@@ -2263,7 +2263,7 @@ we can use uninterruptibleMask_ to avoid the situation.
 -}
 
 -- | Get the next cost centre index associated with a given name.
-getCCIndexM :: (gbl -> TcRef CostCentreState) -> FastString -> TcRnIf gbl lcl CostCentreIndex
+getCCIndexM :: (gbl -> TcRef CostCentreState) -> FastString -> TcRnIfDs top gbl lcl CostCentreIndex
 getCCIndexM get_ccs nm = do
   env <- getGblEnv
   let cc_st_ref = get_ccs env