diff options
| author | Adam Gundry <adam@well-typed.com> | 2014-04-22 02:12:03 -0500 |
|---|---|---|
| committer | Austin Seipp <austin@well-typed.com> | 2014-04-22 06:16:50 -0500 |
| commit | fe77cbf15dd44bb72943357d65bd8adf9f4deee5 (patch) | |
| tree | 04724d7fcf4b2696d2342c5b31c1f59ebaa92cb1 /compiler/main/PprTyThing.hs | |
| parent | 33e585d6eacae19e83862a05b650373b536095fa (diff) | |
| download | haskell-wip/orf.tar.gz | |
ghc: implement OverloadedRecordFieldswip/orf
This fully implements the new ORF extension, developed during the Google
Summer of Code 2013, and as described on the wiki:
https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields
This also updates the Haddock submodule.
Reviewed-by: Simon Peyton Jones <simonpj@microsoft.com>
Signed-off-by: Austin Seipp <austin@well-typed.com>
Diffstat (limited to 'compiler/main/PprTyThing.hs')
| -rw-r--r-- | compiler/main/PprTyThing.hs | 12 |
1 files changed, 8 insertions, 4 deletions
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 1fd5d0cbcf..2fa4783063 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -228,7 +228,7 @@ pprAlgTyCon ss tyCon datacons = tyConDataCons tyCon gadt = any (not . isVanillaDataCon) datacons - ok_con dc = showSub ss dc || any (showSub ss) (dataConFieldLabels dc) + ok_con dc = showSub ss dc || any (showSub ss . flSelector) (dataConFieldLabels dc) show_con dc | ok_con dc = Just (pprDataConDecl ss gadt dc) | otherwise = Nothing @@ -262,9 +262,10 @@ pprDataConDecl ss gadt_style dataCon user_ify (HsUnpack {}) = HsUserBang (Just True) True user_ify bang = bang - maybe_show_label (lbl,bty) - | showSub ss lbl = Just (ppr_bndr lbl <+> dcolon <+> pprBangTy bty) - | otherwise = Nothing + maybe_show_label (fl, bty) + | showSub ss (flSelector fl) + = Just (ppr_bndr_occ (mkVarOccFS (flLabel fl)) <+> dcolon <+> pprBangTy bty) + | otherwise = Nothing ppr_fields [ty1, ty2] | dataConIsInfix dataCon && null labels @@ -331,6 +332,9 @@ add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs) ppr_bndr :: NamedThing a => a -> SDoc ppr_bndr a = parenSymOcc (getOccName a) (ppr (getName a)) +ppr_bndr_occ :: OccName -> SDoc +ppr_bndr_occ a = parenSymOcc a (ppr a) + showWithLoc :: SDoc -> SDoc -> SDoc showWithLoc loc doc = hang doc 2 (char '\t' <> comment <+> loc) |