diff options
-rw-r--r-- | compiler/GHC/Driver/Env/Types.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Types.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/Tc/Types.hs | 28 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Monad.hs | 30 |
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 |