Commit a271ad7e authored by simonpj's avatar simonpj
Browse files

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

Print full instances in ghci; merge
parent 3e12bb2d
{-# 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
......
......@@ -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}
......
......@@ -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,
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment