Commit d2b6e767 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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.
parent 696f2cfd
......@@ -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
......
......@@ -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)
......
......@@ -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.
......
......@@ -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
......
......@@ -491,9 +491,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
......
......@@ -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
......@@ -1741,7 +1749,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 ;
......@@ -1895,10 +1904,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.
......
......@@ -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 }
{-
************************************************************************
......@@ -640,11 +642,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
......@@ -947,9 +949,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
{-
......@@ -1214,7 +1216,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'
......
......@@ -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
......@@ -1821,7 +1821,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
......@@ -1844,10 +1844,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
......
Top level: Not in scope: ‘Test2’
<interactive>:1:1: Not in scope: ‘Test2’
Top level: Not in scope: ‘Data.Maybe.->’
<interactive>:1:1: Not in scope: ‘Data.Maybe.->’
......@@ -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 #)
Top level: Not in scope: ‘thisIsNotDefined’
<interactive>:1:1: Not in scope: ‘thisIsNotDefined’
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment