From a271ad7e6d2b92779a63ab1cc88bc95dc17d6981 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 8 Mar 2005 09:47:43 +0000 Subject: [PATCH] [project @ 2005-03-08 09:47:35 by simonpj] Print full instances in ghci; merge --- ghc/compiler/ghci/InteractiveUI.hs | 10 +++---- ghc/compiler/main/HscMain.lhs | 16 ++++------- ghc/compiler/typecheck/TcMType.lhs | 4 +-- ghc/compiler/typecheck/TcRnDriver.lhs | 47 +++++++++++++++++++++------------ 4 files changed, 42 insertions(+), 35 deletions(-) diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 6fe4755..143fb6a 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.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 diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 7b3e84b..81015ac 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/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} diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index 4a9df50..b4a0ac7 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/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, diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index b3a31f8..fd8cdae 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/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) -- 1.7.10.4