Commit c51fdf44 authored by simonpj's avatar simonpj
Browse files

[project @ 2005-01-28 17:44:55 by simonpj]

Arrange that when seeking instance decls in GHCi, in response
to a :info command, we only print ones whose types are in scope
unqualified.  This eliminates an alarmingly long list when
simply typing ':info Show', say.

On the way, I reorganised a bit.  GHCi printing happens by
converting a TyThing to an IfaceDecl, and printing that.
I now arrange to generate unqualifed IfaceExtNames directly
during this conversion, based on what is in scope.  Previously
it was done during the pretty-printing part via the UserStyle.
But this is nicer.
parent 550efe6e
......@@ -161,7 +161,7 @@ instance Outputable SrcLoc where
hcat [text "{-# LINE ", int src_line, space,
char '\"', ftext src_path, text " #-}"]
ppr (ImportedLoc mod) = ptext SLIT("Imported from") <+> quotes (text mod)
ppr (ImportedLoc mod) = ptext SLIT("Imported from") <+> text mod
ppr (UnhelpfulLoc s) = ftext s
\end{code}
......
{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
-- $Id: InteractiveUI.hs,v 1.185 2005/01/28 12:55:23 simonmar Exp $
-- $Id: InteractiveUI.hs,v 1.186 2005/01/28 17:44:56 simonpj Exp $
--
-- GHC Interactive User Interface
--
......@@ -15,8 +15,7 @@ module InteractiveUI (
#include "HsVersions.h"
import CompManager
import HscTypes ( HomeModInfo(hm_linkable), HomePackageTable,
isObjectLinkable, GhciMode(..) )
import HscTypes ( GhciMode(..) )
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..),
IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart )
import FunDeps ( pprFundeps )
......@@ -29,7 +28,7 @@ import Name ( Name, NamedThing(..) )
import OccName ( OccName, isSymOcc, occNameUserString )
import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) )
import Outputable
import CmdLineOpts ( DynFlag(..), DynFlags(..), dopt_unset )
import CmdLineOpts ( DynFlags(..) )
import Panic hiding ( showException )
import Config
import SrcLoc ( SrcLoc, isGoodSrcLoc )
......@@ -51,7 +50,7 @@ import System.Console.Readline as Readline
import Control.Exception as Exception
import Data.Dynamic
import Control.Concurrent
-- import Control.Concurrent
import Numeric
import Data.List
......@@ -497,9 +496,8 @@ info s = do { let names = words s
showThing :: GetInfoResult -> SDoc
showThing (wanted_str, (thing, fixity, src_loc, insts))
= vcat [ showDecl want_name thing,
= vcat [ showWithLoc src_loc (showDecl want_name thing),
show_fixity fixity,
show_loc src_loc,
vcat (map show_inst insts)]
where
want_name occ = wanted_str == occNameUserString occ
......@@ -508,15 +506,19 @@ showThing (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))
showWithLoc :: SrcLoc -> SDoc -> SDoc
showWithLoc loc doc
= hang doc 2 (char '\t' <> show_loc loc)
-- The tab tries to make them line up a bit
where
show_loc loc -- The ppr function for SrcLocs is a bit wonky
| isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc
| otherwise = comment <+> ppr loc
comment = ptext SLIT("--")
show_inst (iface_inst, loc)
= hang (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst))
2 (char '\t' <> show_loc loc)
-- The tab tries to make them line up a bit
-- 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.
......
......@@ -23,7 +23,7 @@ module IfaceSyn (
visibleIfConDecls,
-- Converting things to IfaceSyn
tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule,
tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule,
-- Equality
IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
......@@ -57,12 +57,11 @@ import TyCon ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCo
import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks,
dataConTyCon, dataConIsInfix, isVanillaDataCon )
import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon )
import OccName ( OccName, OccEnv, lookupOccEnv, emptyOccEnv,
lookupOccEnv, extendOccEnv, emptyOccEnv,
import OccName ( OccName, OccEnv, emptyOccEnv,
lookupOccEnv, extendOccEnv,
OccSet, unionOccSets, unitOccSet )
import Name ( Name, NamedThing(..), getOccName, nameOccName, nameModule, isExternalName )
import Name ( Name, NamedThing(..), nameOccName, isExternalName )
import NameSet ( NameSet, elemNameSet )
import Module ( Module )
import CostCentre ( CostCentre, pprCostCentreCore )
import Literal ( Literal )
import ForeignCall ( ForeignCall )
......@@ -556,13 +555,12 @@ tyThingToIfaceDecl dis abstr ext (ADataCon dc)
--------------------------
dfunToIfaceInst :: DFunId -> IfaceInst
dfunToIfaceInst dfun_id
dfunToIfaceInst :: (Name -> IfaceExtName) -> DFunId -> IfaceInst
dfunToIfaceInst ext_lhs dfun_id
= IfaceInst { ifDFun = nameOccName dfun_name,
ifInstHead = toIfaceType (mkLhsNameFn mod) tidy_ty }
ifInstHead = toIfaceType ext_lhs tidy_ty }
where
dfun_name = idName dfun_id
mod = nameModule dfun_name
(tvs, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
head_ty = mkForAllTys tvs (mkPredTy (mkClassPred cls tys))
-- No need to record the instance context;
......@@ -621,17 +619,18 @@ toIfaceIdInfo ext id_info
| otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs))
--------------------------
coreRuleToIfaceRule :: Module -> (Name -> IfaceExtName) -> IdCoreRule -> IfaceRule
coreRuleToIfaceRule mod ext (IdCoreRule id _ (BuiltinRule _ _))
coreRuleToIfaceRule :: (Name -> IfaceExtName) -- For the LHS names
-> (Name -> IfaceExtName) -- For the RHS names
-> IdCoreRule -> IfaceRule
coreRuleToIfaceRule ext_lhs ext_rhs (IdCoreRule id _ (BuiltinRule _ _))
= pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule (mkIfaceExtName (getName id)))
coreRuleToIfaceRule mod ext (IdCoreRule id _ (Rule name act bndrs args rhs))
coreRuleToIfaceRule ext_lhs ext_rhs (IdCoreRule id _ (Rule name act bndrs args rhs))
= IfaceRule { ifRuleName = name, ifActivation = act,
ifRuleBndrs = map (toIfaceBndr ext) bndrs,
ifRuleHead = ext (idName id),
ifRuleArgs = map (toIfaceExpr (mkLhsNameFn mod)) args,
-- Use LHS name-fn for the args
ifRuleRhs = toIfaceExpr ext rhs }
ifRuleBndrs = map (toIfaceBndr ext_lhs) bndrs,
ifRuleHead = ext_lhs (idName id),
ifRuleArgs = map (toIfaceExpr ext_lhs) args,
ifRuleRhs = toIfaceExpr ext_rhs rhs }
bogusIfaceRule :: IfaceExtName -> IfaceRule
bogusIfaceRule id_name
......@@ -700,18 +699,6 @@ toIfaceVar ext v
| otherwise = IfaceLcl (nameOccName name)
where
name = idName v
---------------------
-- mkLhsNameFn ignores versioning info altogether
-- Used for the LHS of instance decls and rules, where we
-- there's no point in recording version info
mkLhsNameFn :: Module -> Name -> IfaceExtName
mkLhsNameFn this_mod name
| mod == this_mod = LocalTop occ
| otherwise = ExtPkg mod occ
where
mod = nameModule name
occ = nameOccName name
\end{code}
......
......@@ -9,7 +9,8 @@ module IfaceType (
IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..),
IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr,
IfaceExtName(..), mkIfaceExtName, ifaceTyConName, ifPrintUnqual,
IfaceExtName(..), mkIfaceExtName, isLocalIfaceExtName,
ifaceTyConName, interactiveExtNameFun,
-- Conversion from Type -> IfaceType
toIfaceType, toIfacePred, toIfaceContext,
......@@ -25,7 +26,7 @@ module IfaceType (
#include "HsVersions.h"
import Kind ( Kind(..) )
import TypeRep ( Type(..), TyNote(..), PredType(..), Kind, ThetaType )
import TypeRep ( Type(..), TyNote(..), PredType(..), ThetaType )
import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity )
import Var ( isId, tyVarKind, idType )
import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName )
......@@ -63,13 +64,21 @@ data IfaceExtName
-- LocalTopSub is written into iface files as LocalTop; the parent
-- info is only used when computing version information in MkIface
isLocalIfaceExtName :: IfaceExtName -> Bool
isLocalIfaceExtName (LocalTop _) = True
isLocalIfaceExtName (LocalTopSub _ _) = True
isLocalIfaceExtName other = False
mkIfaceExtName name = ExtPkg (nameModule name) (nameOccName name)
-- Local helper for wired-in names
ifPrintUnqual :: PrintUnqualified -> IfaceExtName -> Bool
ifPrintUnqual print_unqual (ExtPkg mod occ) = print_unqual mod occ
ifPrintUnqual print_unqual (HomePkg mod occ _) = print_unqual mod occ
ifPrintUnqual print_unqual other = True
interactiveExtNameFun :: PrintUnqualified -> Name-> IfaceExtName
interactiveExtNameFun print_unqual name
| print_unqual mod occ = LocalTop occ
| otherwise = ExtPkg mod occ
where
mod = nameModule name
occ = nameOccName name
\end{code}
......@@ -189,12 +198,9 @@ instance Outputable IfaceExtName where
ppr (LocalTopSub occ _) = ppr occ -- from an ordinary occurrence?
pprExt :: Module -> OccName -> SDoc
pprExt mod occ
= getPprStyle $ \ sty ->
if unqualStyle sty mod occ then
ppr occ
else
ppr mod <> dot <> ppr occ
-- No need to worry about printing unqualified becuase that was handled
-- in the transiation to IfaceSyn
pprExt mod occ = ppr mod <> dot <> ppr occ
instance Outputable IfaceBndr where
ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr
......
......@@ -503,11 +503,11 @@ ifaceInstGates :: IfaceType -> (IfaceExtName, [IfaceTyCon])
ifaceInstGates (IfaceForAllTy _ t) = ifaceInstGates t
ifaceInstGates (IfaceFunTy _ t) = ifaceInstGates t
ifaceInstGates (IfacePredTy (IfaceClassP cls tys)) = instHeadGates cls tys
ifaceInstGates (IfacePredTy (IfaceClassP cls tys)) = (cls, instHeadTyconGates tys)
ifaceInstGates other = pprPanic "ifaceInstGates" (ppr other)
-- The other cases should not happen
instHeadGates cls tys = (cls, mapCatMaybes root_tycon tys)
instHeadTyconGates tys = mapCatMaybes root_tycon tys
where
root_tycon (IfaceFunTy _ _) = Just (IfaceTc funTyConExtName)
root_tycon (IfaceTyConApp tc _) = Just tc
......
......@@ -269,7 +269,8 @@ mkIface hsc_env location maybe_old_iface
mg_rules = rules,
mg_types = type_env }
= do { eps <- hscEPS hsc_env
; let { ext_nm = mkExtNameFn hsc_env eps this_mod
; let { ext_nm_rhs = mkExtNameFn hsc_env eps this_mod
; ext_nm_lhs = mkLhsNameFn this_mod
; local_things = [thing | thing <- typeEnvElts type_env,
not (isWiredInName (getName thing)) ]
-- Do not export anything about wired-in things
......@@ -282,7 +283,7 @@ mkIface hsc_env location maybe_old_iface
| thing <- local_things
, not (mustExposeThing exports thing)]
; decls = [ tyThingToIfaceDecl omit_prags abstract_tcs ext_nm thing
; decls = [ tyThingToIfaceDecl omit_prags abstract_tcs ext_nm_rhs thing
| thing <- local_things, wantDeclFor exports abstract_tcs thing ]
-- Don't put implicit Ids and class tycons in the interface file
......@@ -291,8 +292,8 @@ mkIface hsc_env location maybe_old_iface
; iface_rules
| omit_prags = []
| otherwise = sortLe le_rule $
map (coreRuleToIfaceRule this_mod ext_nm) rules
; iface_insts = sortLe le_inst (map dfunToIfaceInst insts)
map (coreRuleToIfaceRule ext_nm_lhs ext_nm_rhs) rules
; iface_insts = sortLe le_inst (map (dfunToIfaceInst ext_nm_lhs) insts)
; intermediate_iface = ModIface {
mi_module = this_mod,
......@@ -421,6 +422,20 @@ mkExtNameFn hsc_env eps this_mod
iface = lookupIfaceByModule hpt pit mod `orElse`
pprPanic "lookupVers2" (ppr mod <+> ppr occ)
---------------------
-- mkLhsNameFn ignores versioning info altogether
-- It is used for the LHS of instance decls and rules, where we
-- there's no point in recording version info
mkLhsNameFn :: Module -> Name -> IfaceExtName
mkLhsNameFn this_mod name
| mod == this_mod = LocalTop occ
| otherwise = ExtPkg mod occ
where
mod = nameModule name
occ = nameOccName name
-----------------------------
-- Compute version numbers for local decls
......
......@@ -22,7 +22,7 @@ import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
import TcRnMonad
import Type ( liftedTypeKind, splitTyConApp,
mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred )
mkTyVarTys, mkGenTyConApp, ThetaType, pprClassPred )
import TypeRep ( Type(..), PredType(..) )
import TyCon ( TyCon, tyConName )
import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv,
......@@ -577,9 +577,9 @@ tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule)
; returnM (IdCoreRule fn (isOrphNm fn_rdr) core_rule) }
isOrphNm :: IfaceExtName -> Bool
isOrphNm (LocalTop _) = False
isOrphNm (LocalTopSub _ _) = False
isOrphNm other = True
-- An orphan name comes from somewhere other than this module,
-- so it has a non-local name
isOrphNm name = not (isLocalIfaceExtName name)
\end{code}
......
......@@ -16,6 +16,7 @@ module TcRnDriver (
#include "HsVersions.h"
import IO
#ifdef GHCI
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
#endif
......@@ -105,7 +106,7 @@ import LoadIface ( loadSrcInterface, ifaceInstGates )
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
tyThingToIfaceDecl, dfunToIfaceInst )
import IfaceType ( IfaceTyCon(..), ifPrintUnqual )
import IfaceType ( IfaceTyCon(..), interactiveExtNameFun, isLocalIfaceExtName )
import IfaceEnv ( lookupOrig )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
import Id ( Id, isImplicitId, setIdType, globalIdDetails )
......@@ -117,7 +118,7 @@ import IdInfo ( GlobalIdDetails(..) )
import SrcLoc ( interactiveSrcLoc, unLoc )
import Kind ( Kind )
import Var ( globaliseId )
import Name ( nameOccName, nameModule )
import Name ( nameOccName )
import NameEnv ( delListFromNameEnv )
import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses,
......@@ -1091,7 +1092,7 @@ getModuleContents hsc_env ictxt mod exports_only
-- so it had better be a home module
= do { hpt <- getHpt
; case lookupModuleEnv hpt mod of
Just mod_info -> return (map toIfaceDecl $
Just mod_info -> return (map (toIfaceDecl ext_nm) $
filter wantToSee $
typeEnvElts $
md_types (hm_details mod_info))
......@@ -1108,7 +1109,9 @@ getModuleContents hsc_env ictxt mod exports_only
get_decl (mod, avail)
= do { main_name <- lookupOrig mod (availName avail)
; thing <- tcLookupGlobal main_name
; return (filter_decl (availNames avail) (toIfaceDecl thing)) }
; return (filter_decl (availNames avail) (toIfaceDecl ext_nm thing)) }
ext_nm = interactiveExtNameFun (icPrintUnqual ictxt)
---------------------
filter_decl occs decl@(IfaceClass {ifSigs = sigs})
......@@ -1186,8 +1189,8 @@ tcRnGetInfo hsc_env ictxt rdr_name
-- their parent declaration
let { do_one name = do { thing <- tcLookupGlobal name
; fixity <- lookupFixityRn name
; insts <- lookupInsts print_unqual thing
; return (toIfaceDecl thing, fixity,
; insts <- lookupInsts ext_nm thing
; return (toIfaceDecl ext_nm thing, fixity,
getSrcLoc thing, insts) } } ;
-- For the SrcLoc, the 'thing' has better info than
-- the 'name' because getting the former forced the
......@@ -1198,28 +1201,26 @@ tcRnGetInfo hsc_env ictxt rdr_name
}
where
cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2
print_unqual :: PrintUnqualified
print_unqual = icPrintUnqual ictxt
ext_nm = interactiveExtNameFun (icPrintUnqual ictxt)
lookupInsts :: PrintUnqualified -> TyThing -> TcM [(IfaceInst, SrcLoc)]
lookupInsts :: (Name -> IfaceExtName) -> TyThing -> TcM [(IfaceInst, SrcLoc)]
-- Filter the instances by the ones whose tycons (or clases resp)
-- are in scope unqualified. Otherwise we list a whole lot too many!
lookupInsts print_unqual (AClass cls)
lookupInsts ext_nm (AClass cls)
= do { loadImportedInsts cls [] -- [] means load all instances for cls
; inst_envs <- tcGetInstEnvs
; return [ (inst, getSrcLoc dfun)
| (_,_,dfun) <- classInstances inst_envs cls
, let inst = dfunToIfaceInst dfun
, let inst = dfunToIfaceInst ext_nm dfun
(_, tycons) = ifaceInstGates (ifInstHead inst)
, all print_tycon_unqual tycons ] }
where
print_tycon_unqual (IfaceTc ext_nm) = ifPrintUnqual print_unqual ext_nm
print_tycon_unqual (IfaceTc nm) = isLocalIfaceExtName nm
print_tycon_unqual other = True -- Int etc
lookupInsts print_unqual (ATyCon tc)
lookupInsts ext_nm (ATyCon tc)
= do { eps <- getEps -- Load all instances for all classes that are
-- in the type environment (which are all the ones
-- we've seen in any interface file so far)
......@@ -1229,24 +1230,22 @@ lookupInsts print_unqual (ATyCon tc)
; return [ (inst, getSrcLoc dfun)
| (_, _, dfun) <- instEnvElts home_ie ++ instEnvElts pkg_ie
, relevant dfun
, let inst = dfunToIfaceInst dfun
, let inst = dfunToIfaceInst ext_nm dfun
(cls, _) = ifaceInstGates (ifInstHead inst)
, ifPrintUnqual print_unqual cls ] }
, isLocalIfaceExtName cls ] }
where
relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
tc_name = tyConName tc
lookupInsts print_unqual other = return []
lookupInsts ext_nm other = return []
toIfaceDecl :: TyThing -> IfaceDecl
toIfaceDecl thing
toIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl
toIfaceDecl ext_nm thing
= tyThingToIfaceDecl True -- Discard IdInfo
emptyNameSet -- Show data cons
ext_nm (munge thing)
where
ext_nm n = ExtPkg (nameModule n) (nameOccName n)
-- munge transforms a thing to its "parent" thing
munge (ADataCon dc) = ATyCon (dataConTyCon dc)
munge (AnId id) = case globalIdDetails id of
......@@ -1254,7 +1253,6 @@ toIfaceDecl thing
ClassOpId cls -> AClass cls
other -> AnId id
munge other_thing = other_thing
#endif /* GHCI */
\end{code}
......
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