summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs9
-rw-r--r--compiler/GHC/Tc/Module.hs84
-rw-r--r--compiler/GHC/Tc/Utils/Env.hs47
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs14
4 files changed, 80 insertions, 74 deletions
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 4c6279a6d9..378f29fb57 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -78,6 +78,7 @@ import GHC.Iface.Load
import GHCi.Message
import GHCi.RemoteTypes
import GHC.Runtime.Interpreter
+import GHC.Runtime.Context ( emptyInteractiveContext )
import GHC.Rename.Splice( traceSplice, SpliceInfo(..))
import GHC.Rename.Expr
@@ -1237,8 +1238,10 @@ runMeta' show_code ppr_hs run_and_convert expr
-- Compile and link it; might fail if linking fails
; src_span <- getSrcSpanM
; traceTc "About to run (desugared)" (ppr ds_expr)
+ -- TODO Template Haskell is not GHCi, should not need this
+ ; let ic = emptyInteractiveContext $ hsc_dflags hsc_env
; either_hval <- tryM $ liftIO $
- GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr
+ GHC.Driver.Main.hscCompileCoreExpr hsc_env ic src_span ds_expr
; case either_hval of {
Left exn -> fail_with_exn "compile and link" exn ;
Right (hval, needed_mods, needed_pkgs) -> do
@@ -1606,7 +1609,9 @@ getExternalModIface nm = do
Nothing -> pure Nothing
Just modNm -> do
hsc_env <- getTopEnv
- iface <- liftIO $ hscGetModuleInterface hsc_env modNm
+ -- TODO Template Haskell is not GHCi, should not need this
+ let ic = emptyInteractiveContext $ hsc_dflags hsc_env
+ iface <- liftIO $ hscGetModuleInterface hsc_env ic modNm
pure (Just iface)
-- | Find the GHC name of the first instance that matches the TH type
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index a332d61fb1..d7ee5db572 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -2047,11 +2047,11 @@ get two defns for 'main' in the interface file!
*********************************************************
-}
-runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
+runTcInteractive :: HscEnv -> InteractiveContext -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
-- Initialise the tcg_inst_env with instances from all home modules.
-- This mimics the more selective call to hptInstances in tcRnImports
-runTcInteractive hsc_env thing_inside
- = initTcInteractive hsc_env $ withTcPlugins hsc_env $
+runTcInteractive hsc_env icxt thing_inside
+ = initTcInteractive hsc_env icxt $ withTcPlugins hsc_env $
withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $
do { traceTc "setInteractiveContext" $
vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))
@@ -2099,7 +2099,6 @@ runTcInteractive hsc_env thing_inside
where
(home_insts, home_fam_insts) = hptAllInstances hsc_env
- icxt = hsc_IC hsc_env
(ic_insts, ic_finsts) = ic_instances icxt
(lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt)
@@ -2158,13 +2157,13 @@ We don't bother with the tcl_th_bndrs environment either.
--
-- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound
-- values, coerced to ().
-tcRnStmt :: HscEnv -> GhciLStmt GhcPs
+tcRnStmt :: HscEnv -> InteractiveContext -> GhciLStmt GhcPs
-> IO (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
-tcRnStmt hsc_env rdr_stmt
- = runTcInteractive hsc_env $ do {
+tcRnStmt hsc_env ic rdr_stmt
+ = runTcInteractive hsc_env ic $ do {
-- The real work is done here
- ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ;
+ ((bound_ids, tc_expr), fix_env) <- tcUserStmt ic rdr_stmt ;
zonked_expr <- zonkTopLExpr tc_expr ;
zonked_ids <- zonkTopBndrs bound_ids ;
@@ -2235,19 +2234,19 @@ runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p
-- in GHCi] in GHC.Driver.Env for more details. We do this lifting by trying
-- different ways ('plans') of lifting the code into the IO monad and
-- type checking each plan until one succeeds.
-tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)
+tcUserStmt :: InteractiveContext -> GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)
-- An expression typed at the prompt is treated very specially
-tcUserStmt (L loc (BodyStmt _ expr _ _))
+tcUserStmt ic (L loc (BodyStmt _ expr _ _))
= do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)
; dumpOptTcRn Opt_D_dump_rn_ast "Renamer" FormatHaskell
(showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_expr)
-- Don't try to typecheck if the renamer fails!
- ; ghciStep <- getGhciStepIO
+ ; ghciStep <- getGhciStepIO ic
; uniq <- newUnique
; let loc' = noAnnSrcSpan $ locA loc
- ; interPrintName <- getInteractivePrintName
+ ; let interPrintName = ic_int_print ic
; let fresh_it = itName uniq (locA loc)
matches = [mkMatch (mkPrefixFunRhs (L loc' fresh_it)) [] rn_expr
emptyLocalBinds]
@@ -2393,7 +2392,7 @@ But for naked expressions, you will have
In an equation for ‘x’: x = putStrLn True
-}
-tcUserStmt rdr_stmt@(L loc _)
+tcUserStmt ic rdr_stmt@(L loc _)
= do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $
rnStmts (HsDoStmt GhciStmtCtxt) rnExpr [rdr_stmt] $ \_ -> do
fix_env <- getFixityEnv
@@ -2402,7 +2401,7 @@ tcUserStmt rdr_stmt@(L loc _)
; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
; rnDump rn_stmt ;
- ; ghciStep <- getGhciStepIO
+ ; ghciStep <- getGhciStepIO ic
; let gi_stmt
| (L loc (BindStmt x pat expr)) <- rn_stmt
= L loc $ BindStmt x pat (nlHsApp ghciStep expr)
@@ -2511,9 +2510,9 @@ tcGhciStmts stmts
}
-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
-getGhciStepIO :: TcM (LHsExpr GhcRn)
-getGhciStepIO = do
- ghciTy <- getGHCiMonad
+getGhciStepIO :: InteractiveContext -> TcM (LHsExpr GhcRn)
+getGhciStepIO ic = do
+ let ghciTy = ic_monad ic
a_tv <- newName (mkTyVarOccFS (fsLit "a"))
let ghciM = nlHsAppTy (nlHsTyVar NotPromoted ghciTy) (nlHsTyVar NotPromoted a_tv)
ioM = nlHsAppTy (nlHsTyVar NotPromoted ioTyConName) (nlHsTyVar NotPromoted a_tv)
@@ -2529,9 +2528,9 @@ getGhciStepIO = do
return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy)
-isGHCiMonad :: HscEnv -> String -> IO (Messages TcRnMessage, Maybe Name)
-isGHCiMonad hsc_env ty
- = runTcInteractive hsc_env $ do
+isGHCiMonad :: HscEnv -> InteractiveContext -> String -> IO (Messages TcRnMessage, Maybe Name)
+isGHCiMonad hsc_env ic ty
+ = runTcInteractive hsc_env ic $ do
rdrEnv <- getGlobalRdrEnv
let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty)
case occIO of
@@ -2554,11 +2553,12 @@ data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:typ
-- | tcRnExpr just finds the type of an expression
-- for :type
tcRnExpr :: HscEnv
+ -> InteractiveContext
-> TcRnExprMode
-> LHsExpr GhcPs
-> IO (Messages TcRnMessage, Maybe Type)
-tcRnExpr hsc_env mode rdr_expr
- = runTcInteractive hsc_env $
+tcRnExpr hsc_env ic mode rdr_expr
+ = runTcInteractive hsc_env ic $
do {
(rn_expr, _fvs) <- rnLExpr rdr_expr ;
@@ -2647,12 +2647,13 @@ anything here is ad-hoc, and it's a user-sought improvement.
--------------------------
tcRnImportDecls :: HscEnv
+ -> InteractiveContext
-> [LImportDecl GhcPs]
-> IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
-- Find the new chunk of GlobalRdrEnv created by this list of import
-- decls. In contract tcRnImports *extends* the TcGblEnv.
-tcRnImportDecls hsc_env import_decls
- = runTcInteractive hsc_env $
+tcRnImportDecls hsc_env ic import_decls
+ = runTcInteractive hsc_env ic $
do { gbl_env <- updGblEnv zap_rdr_env $
tcRnImports hsc_env $ map (,text "is directly imported") import_decls
; return (tcg_rdr_env gbl_env) }
@@ -2661,12 +2662,13 @@ tcRnImportDecls hsc_env import_decls
-- tcRnType just finds the kind of a type
tcRnType :: HscEnv
+ -> InteractiveContext
-> ZonkFlexi
-> Bool -- Normalise the returned type
-> LHsType GhcPs
-> IO (Messages TcRnMessage, Maybe (Type, Kind))
-tcRnType hsc_env flexi normalise rdr_type
- = runTcInteractive hsc_env $
+tcRnType hsc_env ic flexi normalise rdr_type
+ = runTcInteractive hsc_env ic $
setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType]
do { (HsWC { hswc_ext = wcs, hswc_body = rn_type }, _fvs)
<- rnHsWcType GHCiCtx (mkHsWildCardBndrs rdr_type)
@@ -2797,10 +2799,11 @@ tcRnDeclsi exists to allow class, data, and other declarations in GHCi.
-}
tcRnDeclsi :: HscEnv
+ -> InteractiveContext
-> [LHsDecl GhcPs]
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
-tcRnDeclsi hsc_env local_decls
- = runTcInteractive hsc_env $
+tcRnDeclsi hsc_env ic local_decls
+ = runTcInteractive hsc_env ic $
tcRnSrcDecls False Nothing local_decls
externaliseAndTidyId :: Module -> Id -> TcM Id
@@ -2823,16 +2826,16 @@ externaliseAndTidyId this_mod id
-- a package module with an interface on disk. If neither of these is
-- true, then the result will be an error indicating the interface
-- could not be found.
-getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface)
-getModuleInterface hsc_env mod
- = runTcInteractive hsc_env $
+getModuleInterface :: HscEnv -> InteractiveContext -> Module -> IO (Messages TcRnMessage, Maybe ModIface)
+getModuleInterface hsc_env ic mod
+ = runTcInteractive hsc_env ic $
loadModuleInterface (text "getModuleInterface") mod
-tcRnLookupRdrName :: HscEnv -> LocatedN RdrName
+tcRnLookupRdrName :: HscEnv -> InteractiveContext -> LocatedN RdrName
-> IO (Messages TcRnMessage, Maybe [Name])
-- ^ Find all the Names that this RdrName could mean, in GHCi
-tcRnLookupRdrName hsc_env (L loc rdr_name)
- = runTcInteractive hsc_env $
+tcRnLookupRdrName hsc_env ic (L loc rdr_name)
+ = runTcInteractive hsc_env ic $
setSrcSpanA loc $
do { -- If the identifier is a constructor (begins with an
-- upper-case letter), then we need to consider both
@@ -2844,9 +2847,9 @@ tcRnLookupRdrName hsc_env (L loc rdr_name)
(text "Not in scope:" <+> quotes (ppr rdr_name)))
; return names }
-tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing)
-tcRnLookupName hsc_env name
- = runTcInteractive hsc_env $
+tcRnLookupName :: HscEnv -> InteractiveContext -> Name -> IO (Messages TcRnMessage, Maybe TyThing)
+tcRnLookupName hsc_env ic name
+ = runTcInteractive hsc_env ic $
tcRnLookupName' name
-- To look up a name we have to look in the local environment (tcl_lcl)
@@ -2862,6 +2865,7 @@ tcRnLookupName' name = do
_ -> panic "tcRnLookupName'"
tcRnGetInfo :: HscEnv
+ -> InteractiveContext
-> Name
-> IO ( Messages TcRnMessage
, Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
@@ -2873,9 +2877,9 @@ tcRnGetInfo :: HscEnv
-- but we want to treat it as *both* a data constructor
-- *and* as a type or class constructor;
-- hence the call to dataTcOccs, and we return up to two results
-tcRnGetInfo hsc_env name
- = runTcInteractive hsc_env $
- do { loadUnqualIfaces hsc_env (hsc_IC hsc_env)
+tcRnGetInfo hsc_env ic name
+ = runTcInteractive hsc_env ic $
+ do { loadUnqualIfaces hsc_env ic
-- Load the interface for all unqualified types and classes
-- That way we will find all the instance declarations
-- (Packages have not orphan modules, and we assume that
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index 01fde4cd1a..1eca96d1b7 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -143,34 +143,37 @@ import GHC.Driver.Env.KnotVars
* *
********************************************************************* -}
-lookupGlobal :: HscEnv -> Name -> IO TyThing
+lookupGlobal :: HscEnv -> Maybe InteractiveContext -> Name -> IO TyThing
-- A variant of lookupGlobal_maybe for the clients which are not
-- interested in recovering from lookup failure and accept panic.
-lookupGlobal hsc_env name
+lookupGlobal hsc_env m_ic name
= do {
- mb_thing <- lookupGlobal_maybe hsc_env name
+ mb_thing <- lookupGlobal_maybe hsc_env m_ic name
; case mb_thing of
Succeeded thing -> return thing
Failed msg -> pprPanic "lookupGlobal" msg
}
-lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
+lookupGlobal_maybe :: HscEnv -> Maybe InteractiveContext -> Name -> IO (MaybeErr SDoc TyThing)
-- This may look up an Id that one has previously looked up.
-- If so, we are going to read its interface file, and add its bindings
-- to the ExternalPackageTable.
-lookupGlobal_maybe hsc_env name
+lookupGlobal_maybe hsc_env m_ic name
= do { -- Try local envt
- let mod = icInteractiveModule (hsc_IC hsc_env)
- mhome_unit = hsc_home_unit_maybe hsc_env
- tcg_semantic_mod = homeModuleInstantiation mhome_unit mod
-
- ; if nameIsLocalOrFrom tcg_semantic_mod name
- then (return
- (Failed (text "Can't find local name: " <+> ppr name)))
- -- Internal names can happen in GHCi
- else
- -- Try home package table and external package table
- lookupImported_maybe hsc_env name
+ let m_tcg_semantic_mod = flip fmap m_ic $ \ic -> let
+ mod = icInteractiveModule ic
+ mhome_unit = hsc_home_unit_maybe hsc_env
+ in homeModuleInstantiation mhome_unit mod
+
+ ; case m_tcg_semantic_mod of
+ Just tcg_semantic_mod
+ | nameIsLocalOrFrom tcg_semantic_mod name
+ -> return
+ (Failed (text "Can't find local name: " <+> ppr name))
+ -- Internal names can happen in GHCi
+ _ ->
+ -- Try home package table and external package table
+ lookupImported_maybe hsc_env name
}
lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
@@ -192,16 +195,16 @@ importDecl_maybe hsc_env name
| otherwise
= initIfaceLoad hsc_env (importDecl name)
-ioLookupDataCon :: HscEnv -> Name -> IO DataCon
-ioLookupDataCon hsc_env name = do
- mb_thing <- ioLookupDataCon_maybe hsc_env name
+ioLookupDataCon :: HscEnv -> Maybe InteractiveContext -> Name -> IO DataCon
+ioLookupDataCon hsc_env m_ic name = do
+ mb_thing <- ioLookupDataCon_maybe hsc_env m_ic name
case mb_thing of
Succeeded thing -> return thing
Failed msg -> pprPanic "lookupDataConIO" msg
-ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc DataCon)
-ioLookupDataCon_maybe hsc_env name = do
- thing <- lookupGlobal hsc_env name
+ioLookupDataCon_maybe :: HscEnv -> Maybe InteractiveContext -> Name -> IO (MaybeErr SDoc DataCon)
+ioLookupDataCon_maybe hsc_env m_ic name = do
+ thing <- lookupGlobal hsc_env m_ic name
return $ case thing of
AConLike (RealDataCon con) -> Succeeded con
_ -> Failed $
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 571e02c7cf..cb27824863 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -53,7 +53,7 @@ module GHC.Tc.Utils.Monad(
debugTc,
-- * Typechecker global environment
- getIsGHCi, getGHCiMonad, getInteractivePrintName,
+ getIsGHCi,
tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv,
getRdrEnvs, getImports,
getFixityEnv, extendFixityEnv, getRecFieldEnv,
@@ -418,11 +418,11 @@ initTcWithGbl hsc_env gbl_env loc do_this
; return (msgs, final_res)
}
-initTcInteractive :: HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
+initTcInteractive :: HscEnv -> InteractiveContext -> TcM a -> IO (Messages TcRnMessage, Maybe a)
-- Initialise the type checker monad for use in GHCi
-initTcInteractive hsc_env thing_inside
+initTcInteractive hsc_env ic thing_inside
= initTc hsc_env HsSrcFile False
- (icInteractiveModule (hsc_IC hsc_env))
+ (icInteractiveModule ic)
(realSrcLocSpan interactive_src_loc)
thing_inside
where
@@ -910,12 +910,6 @@ getIsGHCi :: TcRn Bool
getIsGHCi = do { mod <- getModule
; return (isInteractiveModule mod) }
-getGHCiMonad :: TcRn Name
-getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
-
-getInteractivePrintName :: TcRn Name
-getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }
-
tcIsHsBootOrSig :: TcRn Bool
tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
View Lorry Controller Status