From: simonpj <unknown>
Date: Wed, 21 Jul 2004 10:07:39 +0000 (+0000)
Subject: [project @ 2004-07-21 10:07:29 by simonpj]
X-Git-Tag: Initial_conversion_from_CVS_complete~1776
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=1004a5a31ae62ab53000f6d1248f117a6c22c5e5

[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
--- 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
--- 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
--- 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
--- 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))
     }