[project @ 2004-07-21 10:07:29 by simonpj]

Add location information to :i command

diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index 76902f2..82183f1 100644 (file)
--- a/ghc/compiler/compMan/CompManager.lhs
+++ b/ghc/compiler/compMan/CompManager.lhs
@@ -95,6 +95,7 @@ import BasicTypes     ( Fixity )
 import Linker          ( HValue, unload, extendLinkEnv )
 import GHC.Exts                ( unsafeCoerce# )
 import Foreign
+import SrcLoc          ( SrcLoc )
 import Control.Exception as Exception ( Exception, try )
 #endif
 
@@ -219,7 +220,7 @@ cmSetDFlags cm_state dflags
 -- A string may refer to more than one TyThing (eg. a constructor,
 -- and type constructor), so we return a list of all the possible TyThings.
 
-cmInfoThing :: CmState -> String -> IO [(IfaceDecl,Fixity)]
+cmInfoThing :: CmState -> String -> IO [(IfaceDecl,Fixity,SrcLoc)]
 cmInfoThing cmstate id
    = hscThing (cm_hsc cmstate) (cm_ic cmstate) id
 

diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index 3b0baa2..a3aa85f 100644 (file)
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,6 +1,6 @@
 {-# OPTIONS -#include "Linker.h" #-}
 -----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.167 2004/07/21 09:25:42 simonpj Exp $
+-- $Id: InteractiveUI.hs,v 1.168 2004/07/21 10:07:33 simonpj Exp $
 --
 -- GHC Interactive User Interface
 --
@@ -37,6 +37,7 @@ import CmdLineOpts    ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
                          restoreDynFlags, dopt_unset )
 import Panic           hiding ( showException )
 import Config
+import SrcLoc          ( SrcLoc, isGoodSrcLoc )
 
 #ifndef mingw32_HOST_OS
 import DriverUtil( handle )
@@ -481,15 +482,20 @@ info s  = do { let names = words s
             ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $
                   vcat (intersperse (text "") (map (showThing name) stuff)))) }
 
-showThing :: String -> (IfaceDecl, Fixity) -> SDoc
-showThing name (thing, fixity) 
+showThing :: String -> (IfaceDecl, Fixity, SrcLoc) -> SDoc
+showThing name (thing, fixity, src_loc) 
     = vcat [ showDecl (\occ -> name == occNameUserString occ) thing, 
-            showFixity fixity ]
+            showFixity fixity,
+            showLoc src_loc]
   where
     showFixity fix 
        | fix == defaultFixity = empty
        | otherwise            = ppr fix <+> text name
 
+    showLoc loc        -- The ppr function for SrcLocs is a bit wonky
+       | isGoodSrcLoc loc = ptext SLIT("Defined at") <+> ppr loc
+       | otherwise        = ppr loc
+
 -- Now there is rather a lot of goop just to print declarations in a civilised way
 -- with "..." for the parts we are less interested in.
 
@@ -560,16 +566,6 @@ ppr_bndr :: OccName -> SDoc
 ppr_bndr occ | isSymOcc occ = parens (ppr occ)
             | otherwise    = ppr occ
 
-{-
-       -- also print out the source location for home things
-    showSrcLoc name
-       | isHomePackageName name && isGoodSrcLoc loc
-       = hsep [ text ", defined at", ppr loc ]
-       | otherwise
-       = empty
-       where loc = nameSrcLoc name
--}
-
 
 -----------------------------------------------------------------------------
 -- Commands

diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 7437718..8187bab 100644 (file)
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -29,7 +29,7 @@ import RdrName                ( RdrName )
 import Type            ( Type )
 import PrelNames       ( iNTERACTIVE )
 import StringBuffer    ( stringToStringBuffer )
-import SrcLoc          ( noSrcLoc, Located(..) )
+import SrcLoc          ( SrcLoc, noSrcLoc, Located(..) )
 import Kind            ( Kind )
 import Var             ( Id )
 import CoreLint                ( lintUnfolding )
@@ -631,7 +631,7 @@ hscThing -- like hscStmt, but deals with a single identifier
   :: HscEnv
   -> InteractiveContext                -- Context for compiling
   -> String                    -- The identifier
-  -> IO [(IfaceDecl, Fixity)]
+  -> IO [(IfaceDecl, Fixity, SrcLoc)]
 
 hscThing hsc_env ic str
    = do maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str

diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index c322d98..016e405 100644 (file)
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -56,10 +56,10 @@ import Id           ( mkExportedLocalId, isLocalId, idName, idType )
 import Var             ( Var )
 import Module           ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts )
 import OccName         ( mkVarOcc )
-import Name            ( Name, isExternalName, getSrcLoc, getOccName )
+import Name            ( Name, isExternalName, getSrcLoc, getOccName, nameSrcLoc )
 import NameSet
 import TyCon           ( tyConHasGenerics )
-import SrcLoc          ( srcLocSpan, Located(..), noLoc )
+import SrcLoc          ( SrcLoc, srcLocSpan, Located(..), noLoc )
 import Outputable
 import HscTypes                ( ModGuts(..), HscEnv(..),
                          GhciMode(..), Dependencies(..), noDependencies,
@@ -461,7 +461,7 @@ tcRnType hsc_env ictxt rdr_type
 tcRnThing :: HscEnv
          -> InteractiveContext
          -> RdrName
-         -> IO (Maybe [(IfaceDecl, Fixity)])
+         -> IO (Maybe [(IfaceDecl, Fixity, SrcLoc)])
 -- Look up a RdrName and return all the TyThings it might be
 -- A capitalised RdrName is given to us in the DataName namespace,
 -- but we want to treat it as *both* a data constructor 
@@ -501,8 +501,11 @@ tcRnThing hsc_env ictxt rdr_name
     let { do_one name = do { thing <- tcLookupGlobal name
                           ; let decl = toIfaceDecl ictxt thing
                           ; fixity <- lookupFixityRn name
-                          ; return (decl, fixity) } ;
-         cmp (d1,_) (d2,_) = ifName d1 `compare` ifName d2 } ;
+                          ; return (decl, fixity, getSrcLoc thing) } ;
+               -- For the SrcLoc, the 'thing' has better info than
+               -- the 'name' because getting the former forced the
+               -- declaration to be loaded into the cache
+         cmp (d1,_,_) (d2,_,_) = ifName d1 `compare` ifName d2 } ;
     results <- mapM do_one good_names ;
     return (fst (removeDups cmp results))
     }