From: simonpj Date: Fri, 28 Jan 2005 17:45:03 +0000 (+0000) Subject: [project @ 2005-01-28 17:44:55 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~1155 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=c51fdf4422e1c45aa99e0151c2ac1132cecea128;p=ghc-hetmet.git [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. --- diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index 95b7172..1fc1172 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -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} diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index ec59f0b..a7c3591 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.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. diff --git a/ghc/compiler/iface/IfaceSyn.lhs b/ghc/compiler/iface/IfaceSyn.lhs index c6a8eb2..d4f5545 100644 --- a/ghc/compiler/iface/IfaceSyn.lhs +++ b/ghc/compiler/iface/IfaceSyn.lhs @@ -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} diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs index 0ebfa0d..19226e9 100644 --- a/ghc/compiler/iface/IfaceType.lhs +++ b/ghc/compiler/iface/IfaceType.lhs @@ -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 diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index c33fae0..b63849d 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -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 diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index a27335e..29110c7 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -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 diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 8935f6f..4868ba7 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -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} diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 9abaa9e..8316359 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -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}