Make the location in TcLclEnv and CtLoc into a RealSrcSpan
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 6 Jan 2015 12:28:37 +0000 (12:28 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 6 Jan 2015 12:29:35 +0000 (12:29 +0000)
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.

12 files changed:
compiler/ghci/RtClosureInspect.hs
compiler/main/HscMain.hs
compiler/main/HscTypes.hs
compiler/main/InteractiveEval.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
testsuite/tests/ghci.debugger/scripts/break019.stderr
testsuite/tests/ghci/scripts/T7894.stderr
testsuite/tests/ghci/scripts/T9140.stdout
testsuite/tests/ghci/scripts/ghci034.stderr

index fa97743..56efbb8 100644 (file)
@@ -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
index 4fe74c6..42acd1a 100644 (file)
@@ -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)
index 2d32039..4fdfa95 100644 (file)
@@ -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.
 
index 6f60efe..6f16d4e 100644 (file)
@@ -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
index ca3a878..9a47276 100644 (file)
@@ -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
index f640039..8cfd43c 100644 (file)
@@ -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.
index 77f2f61..44c71e4 100644 (file)
@@ -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'
index c2cc36d..583bc97 100644 (file)
@@ -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
index d9675a8..3ae67a9 100644 (file)
@@ -1,2 +1,2 @@
-
-Top level: Not in scope: ‘Test2’
+\r
+<interactive>:1:1: Not in scope: ‘Test2’\r
index 4cd2a75..71739d1 100644 (file)
@@ -1,2 +1,2 @@
-
-Top level: Not in scope: ‘Data.Maybe.->’
+\r
+<interactive>:1:1: Not in scope: ‘Data.Maybe.->’\r
index a5cb42f..401c874 100644 (file)
@@ -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 #)
index 1983b7d..459ab82 100644 (file)
@@ -1,2 +1,2 @@
-
-Top level: Not in scope: ‘thisIsNotDefined’
+\r
+<interactive>:1:1: Not in scope: ‘thisIsNotDefined’\r