diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Iface/Syntax.hs | 25 | ||||
| -rw-r--r-- | compiler/GHC/Types/TyThing.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Types/TyThing/Ppr.hs | 2 |
3 files changed, 19 insertions, 12 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) |