From 00cd6173a620ef99739d97ac843258fee8e2dee9 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Tue, 6 Jan 2015 12:28:37 +0000
Subject: [PATCH] Make the location in TcLclEnv and CtLoc into a RealSrcSpan
Previously it was a SrcSpan, which can be an UnhelpulSrcSpan,
but actually for TcLclEnv and CtLoc we always know it is
a real source location, and it's good to make the types
reflect that fact.
There is a continuing slight awkwardness (not new with this
patch) about what "file name" to use for GHCi code. Current
we say "<interactive>" which seems just about OK.
---
compiler/ghci/RtClosureInspect.hs | 4 +-
compiler/main/HscMain.hs | 9 ++--
compiler/main/HscTypes.hs | 9 ++--
compiler/main/InteractiveEval.hs | 6 +--
compiler/typecheck/TcErrors.hs | 4 +-
compiler/typecheck/TcRnDriver.hs | 41 ++++++++++++-------
compiler/typecheck/TcRnMonad.hs | 33 +++++++++------
compiler/typecheck/TcRnTypes.hs | 8 ++--
.../ghci.debugger/scripts/break019.stderr | 4 +-
testsuite/tests/ghci/scripts/T7894.stderr | 4 +-
testsuite/tests/ghci/scripts/T9140.stdout | 2 +-
testsuite/tests/ghci/scripts/ghci034.stderr | 4 +-
12 files changed, 72 insertions(+), 56 deletions(-)
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index fa9774311f8d..56efbb8fadf7 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -572,9 +572,7 @@ runTR hsc_env thing = do
runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
runTR_maybe hsc_env thing_inside
- = do { (_errs, res) <- initTc hsc_env HsSrcFile False
- (icInteractiveModule (hsc_IC hsc_env))
- thing_inside
+ = do { (_errs, res) <- initTcInteractive hsc_env thing_inside
; return res }
-- | Term Reconstruction trace
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 690889358258..ecc4a2997159 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -271,10 +271,11 @@ ioMsgMaybe' ioA = do
-- | Lookup things in the compiler's environment
#ifdef GHCI
-hscTcRnLookupRdrName :: HscEnv -> RdrName -> IO [Name]
-hscTcRnLookupRdrName hsc_env0 rdr_name = runInteractiveHsc hsc_env0 $ do
- hsc_env <- getHscEnv
- ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
+hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name]
+hscTcRnLookupRdrName hsc_env0 rdr_name
+ = runInteractiveHsc hsc_env0 $
+ do { hsc_env <- getHscEnv
+ ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }
#endif
hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index dfc394d71576..f3769a9cc993 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -1200,12 +1200,11 @@ The details are a bit tricky though:
It stays as 'main' (or whatever -this-package-key says), and is the
package to which :load'ed modules are added to.
- * So how do we arrange that declarations at the command prompt get
- to be in the 'interactive' package? Simply by setting the tcg_mod
+ * So how do we arrange that declarations at the command prompt get to
+ be in the 'interactive' package? Simply by setting the tcg_mod
field of the TcGblEnv to "interactive:Ghci1". This is done by the
- call to initTc in initTcInteractive, initTcForLookup, which in
- turn get the module from it 'icInteractiveModule' field of the
- interactive context.
+ call to initTc in initTcInteractive, which in turn get the module
+ from it 'icInteractiveModule' field of the interactive context.
The 'thisPackage' field stays as 'main' (or whatever -this-package-key says.
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 6f31d9577881..a36030579830 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -950,9 +950,9 @@ greToRdrNames GRE{ gre_name = name, gre_prov = prov }
-- | Parses a string as an identifier, and returns the list of 'Name's that
-- the identifier can refer to in the current interactive context.
parseName :: GhcMonad m => String -> m [Name]
-parseName str = withSession $ \hsc_env -> do
- (L _ rdr_name) <- liftIO $ hscParseIdentifier hsc_env str
- liftIO $ hscTcRnLookupRdrName hsc_env rdr_name
+parseName str = withSession $ \hsc_env -> liftIO $
+ do { lrdr_name <- hscParseIdentifier hsc_env str
+ ; hscTcRnLookupRdrName hsc_env lrdr_name }
-- -----------------------------------------------------------------------------
-- Getting the type of an expression
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 3fdf4e967bfa..b07fbf900397 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -478,9 +478,9 @@ mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
mkErrorMsg ctxt ct msg
= do { let tcl_env = ctLocEnv (ctLoc ct)
; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
- ; mkLongErrAt (tcl_loc tcl_env) msg err_info }
+ ; mkLongErrAt (RealSrcSpan (tcl_loc tcl_env)) msg err_info }
-type UserGiven = ([EvVar], SkolemInfo, Bool, SrcSpan)
+type UserGiven = ([EvVar], SkolemInfo, Bool, RealSrcSpan)
getUserGivens :: ReportErrCtxt -> [UserGiven]
-- One item for each enclosing implication
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index ed88c2dd5aca..3992a39d3d57 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -123,22 +123,30 @@ tcRnModule :: HscEnv
tcRnModule hsc_env hsc_src save_rn_syntax
parsedModule@HsParsedModule {hpm_module=L loc this_module}
+ | RealSrcSpan real_loc <- loc
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
- ; let { this_pkg = thisPackage (hsc_dflags hsc_env)
- ; pair@(this_mod,_)
- = case hsmodName this_module of
- Nothing -- 'module M where' is omitted
- -> (mAIN, srcLocSpan (srcSpanStart loc))
+ ; initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
+ withTcPlugins hsc_env $
+ tcRnModuleTcRnM hsc_env hsc_src parsedModule pair }
- Just (L mod_loc mod) -- The normal case
- -> (mkModule this_pkg mod, mod_loc) } ;
+ | otherwise
+ = return ((emptyBag, unitBag err_msg), Nothing)
+
+ where
+ err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $
+ text "Module does not have a RealSrcSpan:" <+> ppr this_mod
+
+ this_pkg = thisPackage (hsc_dflags hsc_env)
+
+ pair :: (Module, SrcSpan)
+ pair@(this_mod,_)
+ | Just (L mod_loc mod) <- hsmodName this_module
+ = (mkModule this_pkg mod, mod_loc)
+
+ | otherwise -- 'module M where' is omitted
+ = (mAIN, srcLocSpan (srcSpanStart loc))
- ; res <- initTc hsc_env hsc_src save_rn_syntax this_mod $
- withTcPlugins hsc_env $
- tcRnModuleTcRnM hsc_env hsc_src parsedModule pair
- ; return res
- }
-- To be called at the beginning of renaming hsig files.
-- If we're processing a signature, load up the RdrEnv
@@ -1745,7 +1753,8 @@ tcRnExpr :: HscEnv
-> IO (Messages, Maybe Type)
-- Type checks the expression and returns its most general type
tcRnExpr hsc_env rdr_expr
- = runTcInteractive hsc_env $ do {
+ = runTcInteractive hsc_env $
+ do {
(rn_expr, _fvs) <- rnLExpr rdr_expr ;
failIfErrsM ;
@@ -1907,10 +1916,12 @@ getModuleInterface hsc_env mod
= runTcInteractive hsc_env $
loadModuleInterface (ptext (sLit "getModuleInterface")) mod
-tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name])
+tcRnLookupRdrName :: HscEnv -> Located RdrName
+ -> IO (Messages, Maybe [Name])
-- ^ Find all the Names that this RdrName could mean, in GHCi
-tcRnLookupRdrName hsc_env rdr_name
+tcRnLookupRdrName hsc_env (L loc rdr_name)
= runTcInteractive hsc_env $
+ setSrcSpan loc $
do { -- If the identifier is a constructor (begins with an
-- upper-case letter), then we need to consider both
-- constructor and type class identifiers.
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 2d74dfb7df02..74f80996b725 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -74,12 +74,13 @@ initTc :: HscEnv
-> HscSource
-> Bool -- True <=> retain renamed syntax trees
-> Module
+ -> RealSrcSpan
-> TcM r
-> IO (Messages, Maybe r)
-- Nothing => error thrown by the thing inside
-- (error messages should have been printed already)
-initTc hsc_env hsc_src keep_rn_syntax mod do_this
+initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
= do { errs_var <- newIORef (emptyBag, emptyBag) ;
tvs_var <- newIORef emptyVarSet ;
keep_var <- newIORef emptyNameSet ;
@@ -167,7 +168,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
} ;
lcl_env = TcLclEnv {
tcl_errs = errs_var,
- tcl_loc = mkGeneralSrcSpan (fsLit "Top level"),
+ tcl_loc = loc, -- Should be over-ridden very soon!
tcl_ctxt = [],
tcl_rdr = emptyLocalRdrEnv,
tcl_th_ctxt = topStage,
@@ -210,18 +211,19 @@ initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
initTcInteractive hsc_env thing_inside
= initTc hsc_env HsSrcFile False
(icInteractiveModule (hsc_IC hsc_env))
+ (realSrcLocSpan interactive_src_loc)
thing_inside
+ where
+ interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
initTcForLookup :: HscEnv -> TcM a -> IO a
-- The thing_inside is just going to look up something
-- in the environment, so we don't need much setup
initTcForLookup hsc_env thing_inside
- = do (msgs, m) <- initTc hsc_env HsSrcFile False
- (icInteractiveModule (hsc_IC hsc_env)) -- Irrelevant really
- thing_inside
- case m of
+ = do { (msgs, m) <- initTcInteractive hsc_env thing_inside
+ ; case m of
Nothing -> throwIO $ mkSrcErr $ snd msgs
- Just x -> return x
+ Just x -> return x }
{-
************************************************************************
@@ -637,11 +639,11 @@ addDependentFiles fs = do
getSrcSpanM :: TcRn SrcSpan
-- Avoid clash with Name.getSrcLoc
-getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
+getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) }
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
-setSrcSpan loc@(RealSrcSpan _) thing_inside
- = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
+setSrcSpan (RealSrcSpan real_loc) thing_inside
+ = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside
-- Don't overwrite useful info with useless:
setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
@@ -944,9 +946,9 @@ getCtLoc origin
setCtLoc :: CtLoc -> TcM a -> TcM a
-- Set the SrcSpan and error context from the CtLoc
setCtLoc (CtLoc { ctl_env = lcl }) thing_inside
- = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
+ = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
, tcl_bndrs = tcl_bndrs lcl
- , tcl_ctxt = tcl_ctxt lcl })
+ , tcl_ctxt = tcl_ctxt lcl })
thing_inside
{-
@@ -1211,7 +1213,12 @@ emitWildcardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
emitWildcardHoleConstraints wcs
= do { ctLoc <- getCtLoc HoleOrigin
; forM_ wcs $ \(name, tv) -> do {
- ; let ctLoc' = setCtLocSpan ctLoc (nameSrcSpan name)
+ ; let real_span = case nameSrcSpan name of
+ RealSrcSpan span -> span
+ UnhelpfulSpan str -> pprPanic "emitWildcardHoleConstraints"
+ (ppr name <+> quotes (ftext str))
+ -- Wildcards are defined locally, and so have RealSrcSpans
+ ctLoc' = setCtLocSpan ctLoc real_span
ty = mkTyVarTy tv
ev = mkLocalId name ty
can = CHoleCan { cc_ev = CtWanted ty ev ctLoc'
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 1f06ae31cb02..3039517651f3 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -602,7 +602,7 @@ Why? Because they are now Ids not TcIds. This final GlobalEnv is
data TcLclEnv -- Changes as we move inside an expression
-- Discarded after typecheck/rename; not passed on to desugarer
= TcLclEnv {
- tcl_loc :: SrcSpan, -- Source span
+ tcl_loc :: RealSrcSpan, -- Source span
tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top
tcl_tclvl :: TcLevel, -- Birthplace for new unification variables
@@ -1808,7 +1808,7 @@ data CtLoc = CtLoc { ctl_origin :: CtOrigin
, ctl_env :: TcLclEnv
, ctl_depth :: !SubGoalDepth }
-- The TcLclEnv includes particularly
- -- source location: tcl_loc :: SrcSpan
+ -- source location: tcl_loc :: RealSrcSpan
-- context: tcl_ctxt :: [ErrCtxt]
-- binder stack: tcl_bndrs :: [TcIdBinders]
-- level: tcl_tclvl :: TcLevel
@@ -1828,10 +1828,10 @@ ctLocDepth = ctl_depth
ctLocOrigin :: CtLoc -> CtOrigin
ctLocOrigin = ctl_origin
-ctLocSpan :: CtLoc -> SrcSpan
+ctLocSpan :: CtLoc -> RealSrcSpan
ctLocSpan (CtLoc { ctl_env = lcl}) = tcl_loc lcl
-setCtLocSpan :: CtLoc -> SrcSpan -> CtLoc
+setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc
setCtLocSpan ctl@(CtLoc { ctl_env = lcl }) loc = setCtLocEnv ctl (lcl { tcl_loc = loc })
bumpCtLocDepth :: SubGoalCounter -> CtLoc -> CtLoc
diff --git a/testsuite/tests/ghci.debugger/scripts/break019.stderr b/testsuite/tests/ghci.debugger/scripts/break019.stderr
index d9675a8db4f9..3ae67a9c8d15 100644
--- a/testsuite/tests/ghci.debugger/scripts/break019.stderr
+++ b/testsuite/tests/ghci.debugger/scripts/break019.stderr
@@ -1,2 +1,2 @@
-
-Top level: Not in scope: ‘Test2’
+
+<interactive>:1:1: Not in scope: ‘Test2’
diff --git a/testsuite/tests/ghci/scripts/T7894.stderr b/testsuite/tests/ghci/scripts/T7894.stderr
index 4cd2a75ff1d0..71739d1921e0 100644
--- a/testsuite/tests/ghci/scripts/T7894.stderr
+++ b/testsuite/tests/ghci/scripts/T7894.stderr
@@ -1,2 +1,2 @@
-
-Top level: Not in scope: ‘Data.Maybe.->’
+
+<interactive>:1:1: Not in scope: ‘Data.Maybe.->’
diff --git a/testsuite/tests/ghci/scripts/T9140.stdout b/testsuite/tests/ghci/scripts/T9140.stdout
index a5cb42f58ac1..401c8741c5e8 100644
--- a/testsuite/tests/ghci/scripts/T9140.stdout
+++ b/testsuite/tests/ghci/scripts/T9140.stdout
@@ -9,6 +9,6 @@
a = (# 1, 3 #)
Probable fix: use a bang pattern
-Top level:
+<interactive>:1:1:
GHCi can't bind a variable of unlifted type:
a :: (# Integer, Integer #)
diff --git a/testsuite/tests/ghci/scripts/ghci034.stderr b/testsuite/tests/ghci/scripts/ghci034.stderr
index 1983b7dd7e09..459ab8272d3a 100644
--- a/testsuite/tests/ghci/scripts/ghci034.stderr
+++ b/testsuite/tests/ghci/scripts/ghci034.stderr
@@ -1,2 +1,2 @@
-
-Top level: Not in scope: ‘thisIsNotDefined’
+
+<interactive>:1:1: Not in scope: ‘thisIsNotDefined’
--
GitLab