[commit: ghc] wip/orf-reboot: Make pprIfaceConDecl play nicely with overloaded record field labels (545fffe)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/orf-reboot
Link       : http://ghc.haskell.org/trac/ghc/changeset/545fffe407bae0b4f38408229d0aa48b9265e579/ghc

>---------------------------------------------------------------

commit 545fffe407bae0b4f38408229d0aa48b9265e579
Author: Adam Gundry <adam at well-typed.com>
Date:   Mon Feb 23 17:03:42 2015 +0000

    Make pprIfaceConDecl play nicely with overloaded record field labels


>---------------------------------------------------------------

545fffe407bae0b4f38408229d0aa48b9265e579
 compiler/iface/IfaceSyn.hs                         | 25 ++++++++++++++++++----
 .../ghci/overloadedrecfldsghci01.stdout            |  4 ++--
 2 files changed, 23 insertions(+), 6 deletions(-)

diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 0b36c02..db54a18 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -61,6 +61,7 @@ import InstEnv
 
 import Control.Monad
 import System.IO.Unsafe
+import Data.List (find)
 import Data.Maybe (isJust)
 
 infixl 3 &&&
@@ -327,6 +328,15 @@ visibleIfConDecls IfDataFamTyCon       = []
 visibleIfConDecls (IfDataTyCon cs _ _) = cs
 visibleIfConDecls (IfNewTyCon c   _ _) = [c]
 
+ifaceConDeclFields :: OccName -> IfaceConDecls -> [FieldLbl OccName]
+ifaceConDeclFields tc x = map (\ lbl -> mkFieldLabelOccs lbl tc is_overloaded) lbls
+  where
+    (is_overloaded, lbls) = case x of
+                              IfAbstractTyCon {}        -> (False, [])
+                              IfDataFamTyCon  {}        -> (False, [])
+                              IfDataTyCon _ is_o labels -> (is_o, labels)
+                              IfNewTyCon  _ is_o labels -> (is_o, labels)
+
 ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]
 --  *Excludes* the 'main' name, but *includes* the implicitly-bound names
 -- Deeply revolting, because it has to predict what gets bound,
@@ -617,8 +627,9 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
     ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc)
 
     show_con dc
-      | ok_con dc = Just $ pprIfaceConDecl ss gadt_style mk_user_con_res_ty dc
+      | ok_con dc = Just $ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls dc
       | otherwise = Nothing
+    fls = ifaceConDeclFields tycon condecls
 
     mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc)
     -- See Note [Result type of a data family GADT]
@@ -794,8 +805,9 @@ isVanillaIfaceConDecl (IfCon { ifConExTvs  = ex_tvs
 
 pprIfaceConDecl :: ShowSub -> Bool
                 -> (IfaceEqSpec -> ([IfaceTvBndr], SDoc))
+                -> [FieldLbl OccName]
                 -> IfaceConDecl -> SDoc
-pprIfaceConDecl ss gadt_style mk_user_con_res_ty
+pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls
         (IfCon { ifConOcc = name, ifConInfix = is_infix,
                  ifConExTvs = ex_tvs,
                  ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
@@ -825,9 +837,14 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty
     pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty
     pprBangTy       (bang, ty) = ppr_bang bang <> ppr ty
 
-    maybe_show_label (lbl,bty)
-      | showSub ss lbl = Just (pprPrefixIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty)
+    maybe_show_label (sel,bty)
+      | showSub ss sel = Just (pprPrefixIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty)
       | otherwise      = Nothing
+      where
+        -- IfaceConDecl contains the name of the selector function, so
+        -- we have to look up the field label (in case
+        -- OverloadedRecordFields was used for the definition)
+        lbl = maybe sel (mkVarOccFS . flLabel) $ find (\ fl -> flSelector fl == sel) fls
 
     ppr_fields [ty1, ty2]
       | is_infix && null labels
diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.stdout b/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.stdout
index 5f16394..c05aa5b 100644
--- a/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.stdout
+++ b/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.stdout
@@ -1,8 +1,8 @@
 True
-data T a = MkT {foo :: Bool, ...}
+data T a = MkT {Ghci2.foo :: Bool, ...}
   	-- Defined at <interactive>:4:18
 
-data S = MkS {foo :: Int} 	-- Defined at <interactive>:3:16
+data S = MkS {Ghci1.foo :: Int} 	-- Defined at <interactive>:3:16
 
 <interactive>:1:1:
     Ambiguous occurrence ‘foo’