summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Iface/Syntax.hs25
-rw-r--r--compiler/GHC/Types/TyThing.hs4
-rw-r--r--compiler/GHC/Types/TyThing/Ppr.hs2
-rw-r--r--ghc/GHCi/UI.hs2
-rw-r--r--testsuite/tests/ghci/scripts/T19462.script9
-rw-r--r--testsuite/tests/ghci/scripts/T19462.stdout11
-rwxr-xr-xtestsuite/tests/ghci/scripts/all.T1
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',
View Lorry Controller Status