Implement :info for record pattern synonyms (#19462)

7 files changed, 41 insertions, 13 deletions

diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index 198b5eb5f4..da54049413 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -804,7 +804,7 @@ constraintIfaceKind =
 
 pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc
 -- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi
---     See Note [Pretty-printing TyThings] in GHC.Types.TyThing.Ppr
+--     See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr
 pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
                              ifCtxt = context, ifResKind = kind,
                              ifRoles = roles, ifCons = condecls,
@@ -1023,19 +1023,26 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon
 pprIfaceDecl _ (IfacePatSyn { ifName = name,
                               ifPatUnivBndrs = univ_bndrs, ifPatExBndrs = ex_bndrs,
                               ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
-                              ifPatArgs = arg_tys,
+                              ifPatArgs = arg_tys, ifFieldLabels = pat_fldlbls,
                               ifPatTy = pat_ty} )
   = sdocWithContext mk_msg
   where
+    pat_keywrd = text "pattern"
     mk_msg sdocCtx
-      = hang (text "pattern" <+> pprPrefixOcc name)
-           2 (dcolon <+> sep [univ_msg
-                             , pprIfaceContextArr req_ctxt
-                             , ppWhen insert_empty_ctxt $ parens empty <+> darrow
-                             , ex_msg
-                             , pprIfaceContextArr prov_ctxt
-                             , pprIfaceType $ foldr (IfaceFunTy VisArg many_ty) pat_ty arg_tys ])
+      = vcat [ ppr_pat_ty
+             -- only print this for record pattern synonyms
+             , if null pat_fldlbls then Outputable.empty
+               else pat_keywrd <+> pprPrefixOcc name <+> pat_body]
       where
+        ppr_pat_ty =
+          hang (pat_keywrd <+> pprPrefixOcc name)
+            2 (dcolon <+> sep [univ_msg
+                              , pprIfaceContextArr req_ctxt
+                              , ppWhen insert_empty_ctxt $ parens empty <+> darrow
+                              , ex_msg
+                              , pprIfaceContextArr prov_ctxt
+                              , pprIfaceType $ foldr (IfaceFunTy VisArg many_ty) pat_ty arg_tys ])
+        pat_body = braces $ sep $ punctuate comma $ map ppr pat_fldlbls
         univ_msg = pprUserIfaceForAll $ tyVarSpecToBinders univ_bndrs
         ex_msg   = pprUserIfaceForAll $ tyVarSpecToBinders ex_bndrs
 
diff --git a/compiler/GHC/Types/TyThing.hs b/compiler/GHC/Types/TyThing.hs
index fb89c42ee3..ad57abf773 100644
--- a/compiler/GHC/Types/TyThing.hs
+++ b/compiler/GHC/Types/TyThing.hs
@@ -229,6 +229,8 @@ tyThingParent_maybe (ATyCon tc)   = case tyConAssoc_maybe tc of
 tyThingParent_maybe (AnId id)     = case idDetails id of
                                       RecSelId { sel_tycon = RecSelData tc } ->
                                           Just (ATyCon tc)
+                                      RecSelId { sel_tycon = RecSelPatSyn ps } ->
+                                          Just (AConLike (PatSynCon ps))
                                       ClassOpId cls               ->
                                           Just (ATyCon (classTyCon cls))
                                       _other                      -> Nothing
@@ -311,5 +313,3 @@ class Monad m => MonadThings m where
 -- Instance used in GHC.HsToCore.Quote
 instance MonadThings m => MonadThings (ReaderT s m) where
   lookupThing = lift . lookupThing
-
-
diff --git a/compiler/GHC/Types/TyThing/Ppr.hs b/compiler/GHC/Types/TyThing/Ppr.hs
index 90b42d537c..2e8476c851 100644
--- a/compiler/GHC/Types/TyThing/Ppr.hs
+++ b/compiler/GHC/Types/TyThing/Ppr.hs
@@ -165,7 +165,7 @@ pprTyThingInContextLoc tyThing
 -- | Pretty-prints a 'TyThing'.
 pprTyThing :: ShowSub -> TyThing -> SDoc
 -- We pretty-print 'TyThing' via 'IfaceDecl'
--- See Note [Pretty-printing TyThings]
+-- See Note [Pretty printing via Iface syntax]
 pprTyThing ss ty_thing
   = sdocOption sdocLinearTypes $ \show_linear_types ->
       pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing)
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 7817cd974f..4e90e930c2 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -1538,7 +1538,7 @@ infoThing allInfo str = do
                                      (catMaybes mb_stuffs)
     return $ vcat (intersperse (text "") $ map pprInfo filtered)
 
-  -- Filter out names whose parent is also there Good
+  -- Filter out names whose parent is also there. Good
   -- example is '[]', which is both a type and data
   -- constructor in the same type
 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
diff --git a/testsuite/tests/ghci/scripts/T19462.script b/testsuite/tests/ghci/scripts/T19462.script
new file mode 100644
index 0000000000..19ae18b0d3
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T19462.script
@@ -0,0 +1,9 @@
+:set -XPatternSynonyms -XNoFieldSelectors
+pattern P{x,y} = (x,y)
+:info P
+:info x
+:info y
+pattern V = ()
+:info V
+pattern a `C` b = (a,b)
+:info C
diff --git a/testsuite/tests/ghci/scripts/T19462.stdout b/testsuite/tests/ghci/scripts/T19462.stdout
new file mode 100644
index 0000000000..2344968c67
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T19462.stdout
@@ -0,0 +1,11 @@
+pattern P :: a -> b -> (a, b)
+pattern P {x, y}
+  	-- Defined at <interactive>:2:1
+pattern P :: a -> b -> (a, b)
+pattern P {x, y}
+  	-- Defined at <interactive>:2:11
+pattern P :: a -> b -> (a, b)
+pattern P {x, y}
+  	-- Defined at <interactive>:2:13
+pattern V :: () 	-- Defined at <interactive>:6:1
+pattern C :: a -> b -> (a, b) 	-- Defined at <interactive>:8:1
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index fca3939f84..10c224b46b 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -328,6 +328,7 @@ test('T19197', normal, ghci_script, ['T19197.script'])
 test('T19158', normal, ghci_script, ['T19158.script'])
 test('T19279', normal, ghci_script, ['T19279.script'])
 test('T19310', normal, ghci_script, ['T19310.script'])
+test('T19462', normal, ghci_script, ['T19462.script'])
 test('T19667Ghci', extra_files(['T19667Ghci.hs']), ghci_script, ['T19667Ghci.script'])
 test('T19688', normal, ghci_script, ['T19688.script'])
 test('T19650',