From 10ab808b4c8575f62bcc7998e5ab45fa0e0d33c5 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 21 Jul 2004 09:25:45 +0000 Subject: [PATCH] [project @ 2004-07-21 09:25:42 by simonpj] ------------------------------- Sort out the :i command for GHCi ------------------------------- The :info command has been broken in the HEAD for some time, since the new IfaceSyn story. This commit sorts it out, and makes it nicer than before. For example, when you :i a record selector, you get a cut-down data type declaration, so you can see the context. --- ghc/compiler/ghci/InteractiveUI.hs | 145 +++++++++++++++++++++------------ ghc/compiler/iface/IfaceSyn.lhs | 29 ++----- ghc/compiler/typecheck/TcRnDriver.lhs | 36 +++++--- 3 files changed, 130 insertions(+), 80 deletions(-) diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 681987b..3b0baa2 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.166 2004/05/27 09:29:29 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.167 2004/07/21 09:25:42 simonpj Exp $ -- -- GHC Interactive User Interface -- @@ -18,7 +18,9 @@ module InteractiveUI ( import CompManager import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable, isObjectLinkable, GhciMode(..) ) -import IfaceSyn ( IfaceDecl( ifName ) ) +import IfaceSyn ( IfaceType, IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..), + pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart ) +import FunDeps ( pprFundeps ) import DriverFlags import DriverState import DriverUtil ( remove_spaces ) @@ -27,8 +29,8 @@ import Util import Module ( showModMsg, lookupModuleEnv ) import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName, NamedThing(..) ) -import OccName ( isSymOcc ) -import BasicTypes ( defaultFixity, SuccessFlag(..) ) +import OccName ( OccName, isSymOcc, occNameUserString ) +import BasicTypes ( StrictnessMark(..), Fixity, defaultFixity, SuccessFlag(..) ) import Packages import Outputable import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags, @@ -470,53 +472,95 @@ help _ = io (putStr helpText) info :: String -> GHCi () info "" = throwDyn (CmdLineError "syntax: `:i '") -info s = do - let names = words s - init_cms <- getCmState - let - infoThings cms [] = return cms - infoThings cms (name:names) = do - stuff <- io (cmInfoThing cms name) - io (putStrLn (showSDocForUser unqual ( - vcat (intersperse (text "") (map showThing stuff)))) - ) - infoThings cms names - - unqual = cmGetPrintUnqual init_cms - - showThing (decl, fixity) - = vcat [ text "-- " <> showTyThing decl, - showFixity fixity (ifName decl), - showTyThing decl ] - - showFixity fix name +info s = do { let names = words s + ; init_cms <- getCmState + ; mapM_ (infoThing init_cms) names } + where + infoThing cms name + = do { stuff <- io (cmInfoThing cms name) + ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $ + vcat (intersperse (text "") (map (showThing name) stuff)))) } + +showThing :: String -> (IfaceDecl, Fixity) -> SDoc +showThing name (thing, fixity) + = vcat [ showDecl (\occ -> name == occNameUserString occ) thing, + showFixity fixity ] + where + showFixity fix | fix == defaultFixity = empty - | otherwise = ppr fix <+> - (if isSymOcc name - then ppr name - else char '`' <> ppr name <> char '`') + | otherwise = ppr fix <+> text name - showTyThing decl = ppr decl +-- 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. -{- - showTyThing (AClass cl) - = hcat [ppr cl, text " is a class", showSrcLoc (className cl)] - showTyThing (ADataCon dc) - = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)] - showTyThing (ATyCon ty) - | isPrimTyCon ty - = hcat [ppr ty, text " is a primitive type constructor"] - | otherwise - = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)] - showTyThing (AnId id) - = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)] - - idDescr id - = case globalIdDetails id of - RecordSelId lbl -> text "record selector for type" <+> ppr (fieldLabelTyCon lbl) - ClassOpId cls -> text "method in class" <+> ppr cls - otherwise -> text "variable" +showDecl :: (OccName -> Bool) -> IfaceDecl -> SDoc +showDecl want_name (IfaceId {ifName = var, ifType = ty}) + = ppr var <+> dcolon <+> ppr ty + +showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty}) + = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) + 2 (equals <+> ppr mono_ty) +showDecl want_name (IfaceData {ifCtxt = context, ifName = tycon, + ifTyVars = tyvars, ifCons = condecls}) + = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) + 2 (add_bars (ppr_trim show_con cs)) + where + show_con (IfaceConDecl con_name is_infix ex_tvs ex_cxt tys strs flds) + | want_name tycon || want_name con_name || any want_name flds + = Just (pprIfaceForAllPart ex_tvs ex_cxt (show_guts con_name is_infix tys_w_strs flds)) + | otherwise = Nothing + where + tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict) + + show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2] + show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys) + show_guts con _ tys flds + = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds)))) + where + show_fld (bty, fld) | want_name tycon || want_name con || want_name fld + = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty) + | otherwise = Nothing + + (pp_nd, cs) = case condecls of + IfAbstractTyCon -> (ptext SLIT("data"), []) + IfDataTyCon cs -> (ptext SLIT("data"), cs) + IfNewTyCon c -> (ptext SLIT("newtype"), [c]) + + add_bars [] = empty + add_bars [c] = equals <+> c + add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs) + + ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty + ppr_str MarkedStrict = char '!' + ppr_str MarkedUnboxed = ptext SLIT("!!") + ppr_str NotMarkedStrict = empty + +showDecl want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, + ifFDs = fds, ifSigs = sigs}) + = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars + <+> pprFundeps fds <+> ptext SLIT("where")) + 2 (vcat (ppr_trim show_op sigs)) + where + show_op (IfaceClassOp op dm ty) + | want_name clas || want_name op = Just (ppr_bndr op <+> dcolon <+> ppr ty) + | otherwise = Nothing + +ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc] +ppr_trim show xs + = snd (foldr go (False, []) xs) + where + go x (eliding, so_far) + | Just doc <- show x = (False, doc : so_far) + | otherwise = if eliding then (True, so_far) + else (True, ptext SLIT("...") : so_far) + +ppr_bndr :: OccName -> SDoc +-- Wrap operators in () +ppr_bndr occ | isSymOcc occ = parens (ppr occ) + | otherwise = ppr occ + +{- -- also print out the source location for home things showSrcLoc name | isHomePackageName name && isGoodSrcLoc loc @@ -526,8 +570,9 @@ info s = do where loc = nameSrcLoc name -} - infoThings init_cms names - return () + +----------------------------------------------------------------------------- +-- Commands addModule :: [FilePath] -> GHCi () addModule files = do @@ -714,7 +759,7 @@ browseModule m exports_only = do let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context io (putStrLn (showSDocForUser unqual ( - vcat (map ppr things) + vcat (map (showDecl (const True)) things) ))) ----------------------------------------------------------------------------- diff --git a/ghc/compiler/iface/IfaceSyn.lhs b/ghc/compiler/iface/IfaceSyn.lhs index 3e8d873..a529088 100644 --- a/ghc/compiler/iface/IfaceSyn.lhs +++ b/ghc/compiler/iface/IfaceSyn.lhs @@ -30,7 +30,7 @@ module IfaceSyn ( eqIfDecl, eqIfInst, eqIfRule, -- Pretty printing - pprIfaceExpr, pprIfaceDecl + pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead ) where #include "HsVersions.h" @@ -249,13 +249,13 @@ pprIfaceDecl (IfaceForeign {ifName = tycon}) = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon] pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, ifVrcs = vrcs}) - = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars) + = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) 4 (vcat [equals <+> ppr mono_ty, pprVrcs vrcs]) pprIfaceDecl (IfaceData {ifCtxt = context, ifName = tycon, ifGeneric = gen, ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifVrcs = vrcs}) - = hang (pp_nd <+> pp_decl_head context tycon tyvars) + = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls condecls]) where pp_nd = case condecls of @@ -265,7 +265,7 @@ pprIfaceDecl (IfaceData {ifCtxt = context, ifName = tycon, ifGeneric = gen, pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec}) - = hang (ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds) + = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds) 4 (vcat [pprVrcs vrcs, pprRec isrec, sep (map ppr sigs)]) @@ -278,8 +278,8 @@ pprGen False = ptext SLIT("Generics: no") instance Outputable IfaceClassOp where ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty -pp_decl_head :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc -pp_decl_head context thing tyvars +pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc +pprIfaceDeclHead context thing tyvars = hsep [pprIfaceContext context, ppr thing, pprIfaceTvBndrs tyvars] pp_condecls IfAbstractTyCon = ptext SLIT("{- abstract -}") @@ -505,20 +505,9 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) field_labels = dataConFieldLabels data_con strict_marks = dataConStrictMarks data_con - -- This case only happens in the call to ifaceThing in InteractiveUI - -- Otherwise DataCons are filtered out in ifaceThing_acc -tyThingToIfaceDecl _ _ ext (ADataCon dc) - = IfaceId { ifName = getOccName dc, - ifType = toIfaceType ext full_ty, - ifIdInfo = NoInfo } - where - (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig dc - - -- The "stupid context" isn't part of the wrapper-Id type - -- (for better or worse -- see note in DataCon.lhs), so we - -- have to make it up here - full_ty = mkSigmaTy (tvs ++ ex_tvs) (stupid_theta ++ ex_theta) - (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tvs))) +tyThingToIfaceDecl dis abstr ext (ADataCon dc) + = pprPanic "toIfaceDecl" (ppr dc) + -------------------------- dfunToIfaceInst :: ModuleName -> DFunId -> IfaceInst diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index c4707d9..c322d98 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -94,8 +94,10 @@ import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceExtName(..), IfaceConDecls(..), tyThingToIfaceDecl ) import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) -import Id ( Id, isImplicitId ) +import Id ( Id, isImplicitId, globalIdDetails ) +import FieldLabel ( fieldLabelTyCon ) import MkId ( unsafeCoerceId ) +import DataCon ( dataConTyCon ) import TysWiredIn ( mkListTy, unitTy ) import IdInfo ( GlobalIdDetails(..) ) import SrcLoc ( interactiveSrcLoc, unLoc ) @@ -111,6 +113,7 @@ import HscTypes ( InteractiveContext(..), ModIface(..), ModDetails(..) ) import BasicTypes ( RecFlag(..), Fixity ) import Bag ( unitBag ) +import ListSetOps ( removeDups ) import Panic ( ghcError, GhcException(..) ) #endif @@ -492,22 +495,35 @@ tcRnThing hsc_env ictxt rdr_name else -- Add deprecation warnings mapM_ addMessages warns_s ; - -- And lookup up the entities - mapM do_one good_names + -- And lookup up the entities, avoiding duplicates, which arise + -- because constructors and record selectors are represented by + -- their parent declaration + let { do_one name = do { thing <- tcLookupGlobal name + ; let decl = toIfaceDecl ictxt thing + ; fixity <- lookupFixityRn name + ; return (decl, fixity) } ; + cmp (d1,_) (d2,_) = ifName d1 `compare` ifName d2 } ; + results <- mapM do_one good_names ; + return (fst (removeDups cmp results)) } - where - do_one name = do { thing <- tcLookupGlobal name - ; fixity <- lookupFixityRn name - ; return (toIfaceDecl ictxt thing, fixity) } toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl toIfaceDecl ictxt thing - = tyThingToIfaceDecl True {- Discard IdInfo -} emptyNameSet {- Show data cons -} - ext_nm thing + = tyThingToIfaceDecl True -- Discard IdInfo + emptyNameSet -- Show data cons + ext_nm (munge thing) where unqual = icPrintUnqual ictxt ext_nm n | unqual n = LocalTop (nameOccName n) -- What a hack | otherwise = ExtPkg (nameModuleName n) (nameOccName n) + + -- munge transforms a thing to it's "parent" thing + munge (ADataCon dc) = ATyCon (dataConTyCon dc) + munge (AnId id) = case globalIdDetails id of + RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl) + ClassOpId cls -> AClass cls + other -> AnId id + munge other_thing = other_thing \end{code} @@ -874,7 +890,7 @@ getModuleContents hsc_env ictxt mod exports_only = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only) where get_mod_contents exports_only - | not exports_only -- We want the whole top-level type env + | not exports_only -- We want the whole top-level type env -- so it had better be a home module = do { hpt <- getHpt ; case lookupModuleEnvByName hpt mod of -- 1.7.10.4