Refactor pretty printing of TyThings to fix Trac #4015

diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index 8bdb072..b10a31d 100644 (file)
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -9,7 +9,7 @@
 module PprTyThing (
        PrintExplicitForalls,
        pprTyThing,
-       pprTyThingInContext,
+       pprTyThingInContext, pprTyThingParent_maybe,
        pprTyThingLoc,
        pprTyThingInContextLoc,
        pprTyThingHdr,
@@ -19,6 +19,9 @@ module PprTyThing (
 import qualified GHC
 
 import GHC ( TyThing(..) )
+import DataCon
+import Id
+import IdInfo
 import TyCon
 import TcType
 import Var
@@ -34,6 +37,12 @@ import FastString
 
 type PrintExplicitForalls = Bool
 
+type ShowMe = Name -> Bool
+-- The ShowMe function says which sub-components to print
+--   True  <=> print
+--   False <=> elide to "..."
+
+----------------------------
 -- | Pretty-prints a 'TyThing' with its defining location.
 pprTyThingLoc :: PrintExplicitForalls -> TyThing -> SDoc
 pprTyThingLoc pefas tyThing 
@@ -42,26 +51,41 @@ pprTyThingLoc pefas tyThing
 
 -- | Pretty-prints a 'TyThing'.
 pprTyThing :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThing pefas (AnId id)          = pprId         pefas id
-pprTyThing pefas (ADataCon dataCon) = pprDataConSig pefas dataCon
-pprTyThing pefas (ATyCon tyCon)     = pprTyCon      pefas tyCon
-pprTyThing pefas (AClass cls)       = pprClass      pefas cls
+pprTyThing pefas thing = ppr_ty_thing pefas (const True) thing
 
--- | Like 'pprTyThingInContext', but adds the defining location.
-pprTyThingInContextLoc :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThingInContextLoc pefas tyThing
-  = showWithLoc loc (pprTyThingInContext pefas tyThing)
-  where loc = pprNameLoc (GHC.getName tyThing)
+ppr_ty_thing :: PrintExplicitForalls -> ShowMe -> TyThing -> SDoc
+ppr_ty_thing pefas _    (AnId id)          = pprId         pefas id
+ppr_ty_thing pefas _    (ADataCon dataCon) = pprDataConSig pefas dataCon
+ppr_ty_thing pefas show_me (ATyCon tyCon)   = pprTyCon      pefas show_me tyCon
+ppr_ty_thing pefas show_me (AClass cls)     = pprClass      pefas show_me cls
 
 -- | Pretty-prints a 'TyThing' in context: that is, if the entity
 -- is a data constructor, record selector, or class method, then 
 -- the entity's parent declaration is pretty-printed with irrelevant
 -- parts omitted.
 pprTyThingInContext :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThingInContext pefas (AnId id)          = pprIdInContext pefas id
-pprTyThingInContext pefas (ADataCon dataCon) = pprDataCon pefas dataCon
-pprTyThingInContext pefas (ATyCon tyCon)     = pprTyCon   pefas tyCon
-pprTyThingInContext pefas (AClass cls)       = pprClass   pefas cls
+pprTyThingInContext pefas thing
+  | Just parent <- pprTyThingParent_maybe thing
+  = ppr_ty_thing pefas (== GHC.getName thing) parent
+  | otherwise
+  = pprTyThing pefas thing
+
+-- | Like 'pprTyThingInContext', but adds the defining location.
+pprTyThingInContextLoc :: PrintExplicitForalls -> TyThing -> SDoc
+pprTyThingInContextLoc pefas tyThing
+  = showWithLoc (pprNameLoc (GHC.getName tyThing))
+                (pprTyThingInContext pefas tyThing)
+
+pprTyThingParent_maybe :: TyThing -> Maybe TyThing
+-- (pprTyThingParent_maybe x) returns (Just p) 
+-- when pprTyThingInContext sould print a declaration for p
+-- (albeit with some "..." in it) when asked to show x
+pprTyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc))
+pprTyThingParent_maybe (AnId id)     = case idDetails id of
+                                        RecSelId { sel_tycon = tc } -> Just (ATyCon tc)
+                                        ClassOpId cls               -> Just (AClass cls)
+                                        _other                      -> Nothing
+pprTyThingParent_maybe _other = Nothing
 
 -- | Pretty-prints the 'TyThing' header. For functions and data constructors
 -- the function is equivalent to 'pprTyThing' but for type constructors
@@ -96,32 +120,19 @@ pprTyConHdr _ tyCon
        | otherwise        = empty      -- Returns 'empty' if null theta
 
 pprDataConSig :: PrintExplicitForalls -> GHC.DataCon -> SDoc
-pprDataConSig pefas dataCon =
-  ppr_bndr dataCon <+> dcolon <+> pprTypeForUser pefas (GHC.dataConType dataCon)
+pprDataConSig pefas dataCon
+  = ppr_bndr dataCon <+> dcolon <+> pprTypeForUser pefas (GHC.dataConType dataCon)
 
 pprClassHdr :: PrintExplicitForalls -> GHC.Class -> SDoc
-pprClassHdr _ cls =
-  let (tyVars, funDeps) = GHC.classTvsFds cls
-  in ptext (sLit "class") <+> 
-     GHC.pprThetaArrow (GHC.classSCTheta cls) <+>
-     ppr_bndr cls <+>
-     hsep (map ppr tyVars) <+>
-     GHC.pprFundeps funDeps
-
-pprIdInContext :: PrintExplicitForalls -> Var -> SDoc
-pprIdInContext pefas id
-  | GHC.isRecordSelector id              = pprRecordSelector pefas id
-  | Just cls <- GHC.isClassOpId_maybe id  = pprClassOneMethod pefas cls id
-  | otherwise                            = pprId pefas id
-
-pprRecordSelector :: PrintExplicitForalls -> Id -> SDoc
-pprRecordSelector pefas id
-  = pprAlgTyCon pefas tyCon show_con show_label
+pprClassHdr _ cls
+  = ptext (sLit "class") <+> 
+    GHC.pprThetaArrow (GHC.classSCTheta cls) <+>
+    ppr_bndr cls <+>
+    hsep (map ppr tyVars) <+>
+    GHC.pprFundeps funDeps
   where
-       (tyCon,label) = GHC.recordSelectorFieldLabel id
-       show_con dataCon  = label `elem` GHC.dataConFieldLabels dataCon
-       show_label label' = label == label'
-
+     (tyVars, funDeps) = GHC.classTvsFds cls
+     
 pprId :: PrintExplicitForalls -> Var -> SDoc
 pprId pefas ident
   = hang (ppr_bndr ident <+> dcolon)
@@ -143,8 +154,8 @@ pprTypeForUser print_foralls ty
     tidy_ty     = tidyTopType ty
     (ctxt, ty') = tcMultiSplitSigmaTy tidy_ty
 
-pprTyCon :: PrintExplicitForalls -> TyCon -> SDoc
-pprTyCon pefas tyCon
+pprTyCon :: PrintExplicitForalls -> ShowMe -> TyCon -> SDoc
+pprTyCon pefas show_me tyCon
   | GHC.isSynTyCon tyCon
   = if GHC.isOpenTyCon tyCon
     then pprTyConHdr pefas tyCon <+> dcolon <+> 
@@ -153,11 +164,10 @@ pprTyCon pefas tyCon
       let rhs_type = GHC.synTyConType tyCon
       in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type)
   | otherwise
-  = pprAlgTyCon pefas tyCon (const True) (const True)
+  = pprAlgTyCon pefas show_me tyCon
 
-pprAlgTyCon :: PrintExplicitForalls -> TyCon -> (GHC.DataCon -> Bool)
-            -> (FieldLabel -> Bool) -> SDoc
-pprAlgTyCon pefas tyCon ok_con ok_label
+pprAlgTyCon :: PrintExplicitForalls -> ShowMe -> TyCon -> SDoc
+pprAlgTyCon pefas show_me tyCon
   | gadt      = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$ 
                   nest 2 (vcat (ppr_trim show_con datacons))
   | otherwise = hang (pprTyConHdr pefas tyCon)
@@ -166,20 +176,16 @@ pprAlgTyCon pefas tyCon ok_con ok_label
     datacons = GHC.tyConDataCons tyCon
     gadt = any (not . GHC.isVanillaDataCon) datacons
 
-    show_con dataCon
-      | ok_con dataCon = Just (pprDataConDecl pefas gadt ok_label dataCon)
-      | otherwise      = Nothing
+    ok_con dc = show_me (dataConName dc) || any show_me (dataConFieldLabels dc)
+    show_con dc
+      | ok_con dc = Just (pprDataConDecl pefas show_me gadt dc)
+      | otherwise = Nothing
 
-pprDataCon :: PrintExplicitForalls -> GHC.DataCon -> SDoc
-pprDataCon pefas dataCon = pprAlgTyCon pefas tyCon (== dataCon) (const True)
-  where tyCon = GHC.dataConTyCon dataCon
-
-pprDataConDecl :: PrintExplicitForalls -> Bool -> (FieldLabel -> Bool)
-               -> GHC.DataCon -> SDoc
-pprDataConDecl _ gadt_style show_label dataCon
+pprDataConDecl :: PrintExplicitForalls -> ShowMe -> Bool -> GHC.DataCon -> SDoc
+pprDataConDecl pefas show_me gadt_style dataCon
   | not gadt_style = ppr_fields tys_w_strs
   | otherwise      = ppr_bndr dataCon <+> dcolon <+> 
-                       sep [ GHC.pprForAll forall_tvs, GHC.pprThetaArrow theta, pp_tau ]
+                       sep [ pp_foralls, GHC.pprThetaArrow theta, pp_tau ]
        -- Printing out the dataCon as a type signature, in GADT style
   where
     (forall_tvs, theta, tau) = tcSplitSigmaTy (GHC.dataConUserType dataCon)
@@ -187,6 +193,8 @@ pprDataConDecl _ gadt_style show_label dataCon
     labels     = GHC.dataConFieldLabels dataCon
     stricts    = GHC.dataConStrictMarks dataCon
     tys_w_strs = zip stricts arg_tys
+    pp_foralls | pefas     = GHC.pprForAll forall_tvs
+               | otherwise = empty
 
     pp_tau = foldr add (ppr res_ty) tys_w_strs
     add str_ty pp_ty = pprParendBangTy str_ty <+> arrow <+> pp_ty
@@ -196,8 +204,8 @@ pprDataConDecl _ gadt_style show_label dataCon
     pprBangTy bang ty = ppr bang <> ppr ty
 
     maybe_show_label (lbl,(strict,tp))
-       | show_label lbl = Just (ppr lbl <+> dcolon <+> pprBangTy strict tp)
-       | otherwise      = Nothing
+       | show_me lbl = Just (ppr lbl <+> dcolon <+> pprBangTy strict tp)
+       | otherwise   = Nothing
 
     ppr_fields [ty1, ty2]
        | GHC.dataConIsInfix dataCon && null labels
@@ -210,24 +218,17 @@ pprDataConDecl _ gadt_style show_label dataCon
                braces (sep (punctuate comma (ppr_trim maybe_show_label 
                                        (zip labels fields))))
 
-pprClass :: PrintExplicitForalls -> GHC.Class -> SDoc
-pprClass pefas cls
-  | null methods = 
-       pprClassHdr pefas cls
-  | otherwise = 
-       hang (pprClassHdr pefas cls <+> ptext (sLit "where"))
-           2 (vcat (map (pprClassMethod pefas) methods))
-  where
-       methods = GHC.classMethods cls
-
-pprClassOneMethod :: PrintExplicitForalls -> GHC.Class -> Id -> SDoc
-pprClassOneMethod pefas cls this_one
+pprClass :: PrintExplicitForalls -> ShowMe -> GHC.Class -> SDoc
+pprClass pefas show_me cls
+  | null methods
+  = pprClassHdr pefas cls
+  | otherwise 
   = hang (pprClassHdr pefas cls <+> ptext (sLit "where"))
-        2 (vcat (ppr_trim show_meth methods))
+       2 (vcat (ppr_trim show_meth methods))
   where
-       methods = GHC.classMethods cls
-       show_meth id | id == this_one = Just (pprClassMethod pefas id)
-                    | otherwise      = Nothing
+    methods = GHC.classMethods cls
+    show_meth id | show_me (idName id) = Just (pprClassMethod pefas id)
+                | otherwise           = Nothing
 
 pprClassMethod :: PrintExplicitForalls -> Id -> SDoc
 pprClassMethod pefas id

diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index e049831..22bff85 100644 (file)
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -32,7 +32,7 @@ import Packages
 -- import PackageConfig
 import UniqFM
 
-import HscTypes ( implicitTyThings, handleFlagWarnings )
+import HscTypes ( handleFlagWarnings )
 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
 import Outputable       hiding (printForUser, printForUserPartWay)
 import Module           -- for ModuleEnv
@@ -824,9 +824,12 @@ info s  = handleSourceError GHC.printExceptionAndWarnings $ do
   -- constructor in the same type
 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
 filterOutChildren get_thing xs 
-  = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
+  = filterOut has_parent xs
   where
-    implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
+    all_names = mkNameSet (map (getName . get_thing) xs)
+    has_parent x = case pprTyThingParent_maybe (get_thing x) of
+                     Just p  -> getName p `elemNameSet` all_names
+                     Nothing -> False
 
 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
 pprInfo pefas (thing, fixity, insts)