From fb82da79aed65b076f881b852f2eb98b97859211 Mon Sep 17 00:00:00 2001
From: Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io>
Date: Sat, 18 May 2019 18:08:57 +0200
Subject: [PATCH] Introduce HasHscEnv class, parallel to HasDynFlags
---
compiler/ghci/ByteCodeGen.hs | 4 ++--
compiler/main/HscMain.hs | 4 ----
compiler/main/HscTypes.hs | 8 ++++++++
compiler/simplCore/CoreMonad.hs | 8 ++++----
4 files changed, 14 insertions(+), 10 deletions(-)
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index c4a08c4e408..6af9cdf77fc 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 911d52cbfd9..7698b55ddca 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 8c41f9b9fc8..cb1cc7e862d 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 013b1414ee7..dde4cb6c502 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
--
GitLab