From 1dff43cfde35a95e778ee449502be74ab5b6afba Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Mon, 15 May 2023 16:20:11 -0400
Subject: [PATCH] compiler: Rework ShowSome
Previously the field used to filter the sub-declarations to show
was rather ad-hoc and was only able to show at most one sub-declaration.
---
compiler/GHC/Iface/Syntax.hs | 17 +++++++-----
compiler/GHC/Iface/Type.hs | 21 +++++++--------
compiler/GHC/Types/TyThing/Ppr.hs | 30 +++++++++++++--------
testsuite/tests/ghci/scripts/ghci008.stdout | 4 +--
4 files changed, 41 insertions(+), 31 deletions(-)
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index ac4036c191ff..289997f3aaf9 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -834,10 +834,13 @@ When printing an interface file (--show-iface), we want to print
everything unqualified, so we can just print the OccName directly.
-}
+-- | Show a declaration but not its RHS.
showToHeader :: ShowSub
showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing
, ss_forall = ShowForAllWhen }
+-- | Show declaration and its RHS, including GHc-internal information (e.g.
+-- for @--show-iface@).
showToIface :: ShowSub
showToIface = ShowSub { ss_how_much = ShowIface
, ss_forall = ShowForAllWhen }
@@ -848,18 +851,20 @@ ppShowIface _ _ = Outputable.empty
-- show if all sub-components or the complete interface is shown
ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- See Note [Minimal complete definition]
-ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] _ }) doc = doc
-ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc
-ppShowAllSubs _ _ = Outputable.empty
+ppShowAllSubs (ShowSub { ss_how_much = ShowSome Nothing _ }) doc
+ = doc
+ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc
+ppShowAllSubs _ _ = Outputable.empty
ppShowRhs :: ShowSub -> SDoc -> SDoc
ppShowRhs (ShowSub { ss_how_much = ShowHeader _ }) _ = Outputable.empty
ppShowRhs _ doc = doc
showSub :: HasOccName n => ShowSub -> n -> Bool
-showSub (ShowSub { ss_how_much = ShowHeader _ }) _ = False
-showSub (ShowSub { ss_how_much = ShowSome (n:_) _ }) thing = n == occName thing
-showSub (ShowSub { ss_how_much = _ }) _ = True
+showSub (ShowSub { ss_how_much = ShowHeader _ }) _ = False
+showSub (ShowSub { ss_how_much = ShowSome (Just f) _ }) thing
+ = f (occName thing)
+showSub (ShowSub { ss_how_much = _ }) _ = True
ppr_trim :: [Maybe SDoc] -> [SDoc]
-- Collapse a group of Nothings to a single "..."
diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs
index 4c98a30f8455..6243e4047026 100644
--- a/compiler/GHC/Iface/Type.hs
+++ b/compiler/GHC/Iface/Type.hs
@@ -1361,21 +1361,18 @@ data ShowSub
newtype AltPpr = AltPpr (Maybe (OccName -> SDoc))
data ShowHowMuch
- = ShowHeader AltPpr -- ^Header information only, not rhs
- | ShowSome [OccName] AltPpr
- -- ^ Show only some sub-components. Specifically,
- --
- -- [@\[\]@] Print all sub-components.
- -- [@(n:ns)@] Print sub-component @n@ with @ShowSub = ns@;
- -- elide other sub-components to @...@
- -- May 14: the list is max 1 element long at the moment
+ = ShowHeader AltPpr -- ^ Header information only, not rhs
+ | ShowSome (Maybe (OccName -> Bool)) AltPpr
+ -- ^ Show the declaration and its RHS. The @Maybe@ predicate
+ -- allows filtering of the sub-components which should be printing;
+ -- any sub-components filtered out will be elided with @...@.
| ShowIface
- -- ^Everything including GHC-internal information (used in --show-iface)
+ -- ^ Everything including GHC-internal information (used in --show-iface)
instance Outputable ShowHowMuch where
- ppr (ShowHeader _) = text "ShowHeader"
- ppr ShowIface = text "ShowIface"
- ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs
+ ppr (ShowHeader _) = text "ShowHeader"
+ ppr ShowIface = text "ShowIface"
+ ppr (ShowSome _ _) = text "ShowSome"
pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc
pprIfaceSigmaType show_forall ty
diff --git a/compiler/GHC/Types/TyThing/Ppr.hs b/compiler/GHC/Types/TyThing/Ppr.hs
index 3f0505e49233..bbb591452726 100644
--- a/compiler/GHC/Types/TyThing/Ppr.hs
+++ b/compiler/GHC/Types/TyThing/Ppr.hs
@@ -145,16 +145,24 @@ pprTyThingHdr = pprTyThing showToHeader
-- parts omitted.
pprTyThingInContext :: ShowSub -> TyThing -> SDoc
pprTyThingInContext show_sub thing
- = go [] thing
+ = case parents thing of
+ -- If there are no parents print everything.
+ [] -> print_it Nothing thing
+ -- If `thing` has a parent, print the parent and only its child `thing`
+ thing':rest -> let subs = map getOccName (thing:rest)
+ filt = (`elem` subs)
+ in print_it (Just filt) thing'
where
- go ss thing
- = case tyThingParent_maybe thing of
- Just parent ->
- go (getOccName thing : ss) parent
- Nothing ->
- pprTyThing
- (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) })
- thing
+ parents = go
+ where
+ go thing =
+ case tyThingParent_maybe thing of
+ Just parent -> parent : go parent
+ Nothing -> []
+
+ print_it :: Maybe (OccName -> Bool) -> TyThing -> SDoc
+ print_it mb_filt thing =
+ pprTyThing (show_sub { ss_how_much = ShowSome mb_filt (AltPpr Nothing) }) thing
-- | Like 'pprTyThingInContext', but adds the defining location.
pprTyThingInContextLoc :: TyThing -> SDoc
@@ -171,8 +179,8 @@ pprTyThing ss ty_thing
pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing)
where
ss' = case ss_how_much ss of
- ShowHeader (AltPpr Nothing) -> ss { ss_how_much = ShowHeader ppr' }
- ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' }
+ ShowHeader (AltPpr Nothing) -> ss { ss_how_much = ShowHeader ppr' }
+ ShowSome filt (AltPpr Nothing) -> ss { ss_how_much = ShowSome filt ppr' }
_ -> ss
ppr' = AltPpr $ ppr_bndr $ getName ty_thing
diff --git a/testsuite/tests/ghci/scripts/ghci008.stdout b/testsuite/tests/ghci/scripts/ghci008.stdout
index 925ec3874f44..7105af5c4bfa 100644
--- a/testsuite/tests/ghci/scripts/ghci008.stdout
+++ b/testsuite/tests/ghci/scripts/ghci008.stdout
@@ -40,5 +40,5 @@ class (RealFrac a, Floating a) => RealFloat a where
-- Defined in ‘GHC.Float’
instance RealFloat Double -- Defined in ‘GHC.Float’
instance RealFloat Float -- Defined in ‘GHC.Float’
-base-4.16.0.0:Data.OldList.isPrefixOf :: Eq a => [a] -> [a] -> Bool
- -- Defined in ‘base-4.16.0.0:Data.OldList’
+base-4.18.0.0:Data.OldList.isPrefixOf :: Eq a => [a] -> [a] -> Bool
+ -- Defined in ‘base-4.18.0.0:Data.OldList’
--
GitLab