diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index c4a08c4e408e07e8dba306ced56b15fae548da7e..6af9cdf77fc20942c271b4883df6703b028dd05c 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -1906,8 +1906,8 @@ instance Monad BcM where instance HasDynFlags BcM where getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st)) -getHscEnv :: BcM HscEnv -getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st) +instance HasHscEnv BcM where + getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st) emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name) emitBc bco diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 911d52cbfd956b1f379bea30d89835a3f3d1710f..7698b55ddca4b0a3d2bf3adbf243af10297e9e5c 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -73,7 +73,6 @@ module HscMain -- We want to make sure that we export enough to be able to redefine -- hscFileFrontEnd in client code , hscParse', hscSimplify', hscDesugar', tcRnModule' - , getHscEnv , hscSimpleIface', hscNormalIface' , oneShotMsg , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats @@ -216,9 +215,6 @@ clearWarnings = Hsc $ \_ _ -> return ((), emptyBag) logWarnings :: WarningMessages -> Hsc () logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) -getHscEnv :: Hsc HscEnv -getHscEnv = Hsc $ \e w -> return (e, w) - handleWarnings :: Hsc () handleWarnings = do dflags <- getDynFlags diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 8c41f9b9fc824a2f09ac236ec995649f40f061ac..cb1cc7e862d15fced9c246ccc9ef1629d3aeb262 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -12,6 +12,7 @@ module HscTypes ( -- * compilation state HscEnv(..), hscEPS, + HasHscEnv(..), FinderCache, FindResult(..), InstalledFindResult(..), Target(..), TargetId(..), pprTarget, pprTargetId, HscStatus(..), @@ -246,6 +247,9 @@ instance Monad Hsc where instance MonadIO Hsc where liftIO io = Hsc $ \_ w -> do a <- io; return (a, w) +instance HasHscEnv Hsc where + getHscEnv = Hsc $ \e w -> return (e, w) + instance HasDynFlags Hsc where getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) @@ -494,6 +498,10 @@ data IServ = IServ hscEPS :: HscEnv -> IO ExternalPackageState hscEPS hsc_env = readIORef (hsc_EPS hsc_env) + +class Monad m => HasHscEnv m where + getHscEnv :: m HscEnv + -- | A compilation target. -- -- A target may be supplied with the actual text of the diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index 013b1414ee71d05ef2b72337fd4ba3e528bf4b0e..dde4cb6c502b59be53070a4aab68d9a65aefe67f 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -25,7 +25,7 @@ module CoreMonad ( CoreM, runCoreM, -- ** Reading from the monad - getHscEnv, getRuleBase, getModule, + getRuleBase, getModule, getDynFlags, getOrigNameCache, getPackageFamInstEnv, getVisibleOrphanMods, getPrintUnqualified, getSrcSpanM, @@ -685,9 +685,6 @@ liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> re ************************************************************************ -} -getHscEnv :: CoreM HscEnv -getHscEnv = read cr_hsc_env - getRuleBase :: CoreM RuleBase getRuleBase = read cr_rule_base @@ -708,6 +705,9 @@ addSimplCount count = write (CoreWriter { cw_simpl_count = count }) instance HasDynFlags CoreM where getDynFlags = fmap hsc_dflags getHscEnv +instance HasHscEnv CoreM where + getHscEnv = read cr_hsc_env + instance HasModule CoreM where getModule = read cr_module