[project @ 2005-03-08 09:47:35 by simonpj]

Print full instances in ghci; merge

ghc/compiler/ghci/InteractiveUI.hs

 {-# OPTIONS -#include "Linker.h" #-}
 -----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.192 2005/02/28 16:01:52 simonpj Exp $
+-- $Id: InteractiveUI.hs,v 1.193 2005/03/08 09:47:43 simonpj Exp $
 --
 -- GHC Interactive User Interface
 --
@@ -18,7 +18,7 @@ import CompManager
 import HscTypes		( GhciMode(..) )
 import IfaceSyn		( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..),
 			  IfaceConDecl(..), IfaceType,
-		   	  IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType,
+		   	  pprIfaceDeclHead, pprParendIfaceType,
 			  pprIfaceForAllPart, pprIfaceType )
 import FunDeps		( pprFundeps )
 import DriverFlags
@@ -509,7 +509,7 @@ info s  = do { let names = words s
      		   vcat (intersperse (text "") (map (showThing exts) stuff)))) }
 
 showThing :: Bool -> GetInfoResult -> SDoc
-showThing exts (wanted_str, (thing, fixity, src_loc, insts)) 
+showThing exts (wanted_str, thing, fixity, src_loc, insts) 
     = vcat [ showWithLoc src_loc (showDecl exts want_name thing),
 	     show_fixity fixity,
 	     vcat (map show_inst insts)]
@@ -520,8 +520,8 @@ showThing exts (wanted_str, (thing, fixity, src_loc, insts))
 	| fix == defaultFixity = empty
 	| otherwise            = ppr fix <+> text wanted_str
 
-    show_inst (iface_inst, loc)
-	= showWithLoc loc (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst))
+    show_inst (inst_ty, loc)
+	= showWithLoc loc (ptext SLIT("instance") <+> ppr inst_ty)
 
 showWithLoc :: SrcLoc -> SDoc -> SDoc
 showWithLoc loc doc 

ghc/compiler/main/HscMain.lhs

@@ -28,7 +28,7 @@ import Linker		( HValue, linkExpr )
 import TidyPgm		( tidyCoreExpr )
 import CorePrep		( corePrepExpr )
 import Flattening	( flattenExpr )
-import TcRnDriver	( tcRnStmt, tcRnExpr, tcRnGetInfo, tcRnType ) 
+import TcRnDriver	( tcRnStmt, tcRnExpr, tcRnGetInfo, GetInfoResult, tcRnType ) 
 import RdrName		( rdrNameOcc )
 import OccName		( occNameUserString )
 import Type		( Type )
@@ -697,8 +697,6 @@ hscParseThing parser dflags str
 
 \begin{code}
 #ifdef GHCI
-type GetInfoResult = (String, (IfaceDecl, Fixity, SrcLoc, [(IfaceInst,SrcLoc)]))
-
 hscGetInfo -- like hscStmt, but deals with a single identifier
   :: HscEnv
   -> InteractiveContext		-- Context for compiling
@@ -713,14 +711,10 @@ hscGetInfo hsc_env ic str
 
 	maybe_tc_result <- tcRnGetInfo hsc_env ic rdr_name
 
-	let 	-- str' is the the naked occurrence name
-		-- after stripping off qualification and parens (+)
-	   str' = occNameUserString (rdrNameOcc rdr_name)
-
-	case maybe_tc_result of {
-	     Nothing     -> return [] ;
-	     Just things -> return [(str', t) | t <- things]
- 	}}
+	case maybe_tc_result of
+	     Nothing     -> return []
+	     Just things -> return things
+ 	}
 #endif
 \end{code}
 

ghc/compiler/typecheck/TcMType.lhs

@@ -48,7 +48,7 @@ module TcMType (
 -- friends:
 import HsSyn		( LHsType )
 import TypeRep		( Type(..), PredType(..), TyNote(..),	 -- Friend; can see representation
-			  Kind, ThetaType
+			  ThetaType
 			) 
 import TcType		( TcType, TcThetaType, TcTauType, TcPredType,
 			  TcTyVarSet, TcKind, TcTyVar, TcTyVarDetails(..), 
@@ -56,7 +56,7 @@ import TcType		( TcType, TcThetaType, TcTauType, TcPredType,
 			  tcCmpPred, isClassPred, 
 			  tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, 
 			  tcSplitTyConApp_maybe, tcSplitForAllTys,
-			  tcIsTyVarTy, tcSplitSigmaTy, tcIsTyVarTy,
+			  tcIsTyVarTy, tcSplitSigmaTy, 
 			  isUnLiftedType, isIPPred, isImmutableTyVar,
 			  typeKind, isFlexi, isSkolemTyVar,
 			  mkAppTy, mkTyVarTy, mkTyVarTys, 

ghc/compiler/typecheck/TcRnDriver.lhs

@@ -7,7 +7,8 @@
 module TcRnDriver (
 #ifdef GHCI
 	mkExportEnv, getModuleContents, tcRnStmt, 
-	tcRnGetInfo, tcRnExpr, tcRnType,
+	tcRnGetInfo, GetInfoResult,
+	tcRnExpr, tcRnType,
 #endif
 	tcRnModule, 
 	tcTopSrcDecls,
@@ -99,14 +100,15 @@ import TcType		( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType,
 import TcEnv		( tcLookupTyCon, tcLookupId, tcLookupGlobal )
 import RnTypes		( rnLHsType )
 import Inst		( tcStdSyntaxName, tcGetInstEnvs )
-import InstEnv		( classInstances, instEnvElts )
+import InstEnv		( DFunId, classInstances, instEnvElts )
 import RnExpr		( rnStmts, rnLExpr )
 import RnNames		( exportsToAvails )
 import LoadIface	( loadSrcInterface, ifaceInstGates )
 import IfaceSyn		( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), 
 			  IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
 			  tyThingToIfaceDecl, dfunToIfaceInst )
-import IfaceType	( IfaceTyCon(..), interactiveExtNameFun, isLocalIfaceExtName )
+import IfaceType	( IfaceTyCon(..), IfaceType, toIfaceType, 
+			  interactiveExtNameFun, isLocalIfaceExtName )
 import IfaceEnv		( lookupOrig )
 import RnEnv		( lookupOccRn, dataTcOccs, lookupFixityRn )
 import Id		( Id, isImplicitId, setIdType, globalIdDetails )
@@ -119,6 +121,7 @@ import SrcLoc		( interactiveSrcLoc, unLoc )
 import Kind		( Kind )
 import Var		( globaliseId )
 import Name		( nameOccName )
+import OccName		( occNameUserString )
 import NameEnv		( delListFromNameEnv )
 import PrelNames	( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
 import HscTypes		( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses,
@@ -1142,12 +1145,15 @@ noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
 \end{code}
 
 \begin{code}
+type GetInfoResult = (String, IfaceDecl, Fixity, SrcLoc, 
+			      [(IfaceType,SrcLoc)]	-- Instances
+		     )
+
 tcRnGetInfo :: HscEnv
 	    -> InteractiveContext
 	    -> RdrName
-	    -> IO (Maybe [(IfaceDecl, 
-			   Fixity, SrcLoc, 
-			   [(IfaceInst, SrcLoc)])])
+	    -> IO (Maybe [GetInfoResult])
+
 -- Used to implemnent :info in GHCi
 --
 -- Look up a RdrName and return all the TyThings it might be
@@ -1189,9 +1195,17 @@ tcRnGetInfo hsc_env ictxt rdr_name
 	-- their parent declaration
     let { do_one name = do { thing  <- tcLookupGlobal name
 		           ; fixity <- lookupFixityRn name
-			   ; insts  <- lookupInsts ext_nm thing
-		           ; return (toIfaceDecl ext_nm thing, fixity, 
-				     getSrcLoc thing, insts) } } ;
+			   ; dfuns  <- lookupInsts ext_nm thing
+		           ; return (str, toIfaceDecl ext_nm thing, fixity, 
+				     getSrcLoc thing, 
+				     [(toIfaceType ext_nm (idType dfun), getSrcLoc dfun) | dfun <- dfuns]
+			     ) } 
+		where
+		 	-- str is the the naked occurrence name
+			-- after stripping off qualification and parens (+)
+		  str = occNameUserString (nameOccName name)
+	} ;
+
 		-- For the SrcLoc, the 'thing' has better info than
 		-- the 'name' because getting the former forced the
 		-- declaration to be loaded into the cache
@@ -1200,20 +1214,20 @@ tcRnGetInfo hsc_env ictxt rdr_name
     return (fst (removeDups cmp results))
     }
   where
-    cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2
+    cmp (_,d1,_,_,_) (_,d2,_,_,_) = ifName d1 `compare` ifName d2
     ext_nm = interactiveExtNameFun (icPrintUnqual ictxt)
 
 
-lookupInsts :: (Name -> IfaceExtName) -> TyThing -> TcM [(IfaceInst, SrcLoc)]
+lookupInsts :: (Name -> IfaceExtName) -> TyThing -> TcM [DFunId]
 -- Filter the instances by the ones whose tycons (or clases resp) 
 -- are in scope unqualified.  Otherwise we list a whole lot too many!
 lookupInsts ext_nm (AClass cls)
   = do	{ loadImportedInsts cls []	-- [] means load all instances for cls
 	; inst_envs <- tcGetInstEnvs
-	; return [ (inst, getSrcLoc dfun)
+	; return [ dfun
 		 | (_,_,dfun) <- classInstances inst_envs cls
-		 , let inst = dfunToIfaceInst ext_nm dfun
-		       (_, tycons) = ifaceInstGates (ifInstHead inst)
+		 , let (_, tycons) = ifaceInstGates (ifInstHead (dfunToIfaceInst ext_nm dfun))
+			-- Rather an indirect/inefficient test, but there we go
 		 , all print_tycon_unqual tycons ] }
   where
     print_tycon_unqual (IfaceTc nm) = isLocalIfaceExtName nm
@@ -1227,11 +1241,10 @@ lookupInsts ext_nm (ATyCon tc)
 	; mapM_ (\c -> loadImportedInsts c [])
 		(typeEnvClasses (eps_PTE eps))
 	; (pkg_ie, home_ie) <- tcGetInstEnvs	-- Search all
-	; return [ (inst, getSrcLoc dfun)
+	; return [ dfun
 		 | (_, _, dfun) <- instEnvElts home_ie ++ instEnvElts pkg_ie
 		 , relevant dfun
-		 , let inst     = dfunToIfaceInst ext_nm dfun
-		       (cls, _) = ifaceInstGates (ifInstHead inst)
+		 , let (cls, _) = ifaceInstGates (ifInstHead (dfunToIfaceInst ext_nm dfun))
 		 , isLocalIfaceExtName cls ]  }
   where
     relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)