[commit: ghc] master: Fix interaction of DuplicateRecordFields and GHC.Generics (2442038)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/2442038554440923179d532137199d5290875cff/ghc

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

commit 2442038554440923179d532137199d5290875cff
Author: Adam Gundry <adam at well-typed.com>
Date:   Thu Nov 19 12:53:46 2015 +0100

    Fix interaction of DuplicateRecordFields and GHC.Generics
    
    This prevents GHC.Generics from exposing mangled selector names
    when used on a datatype defined with DuplicateRecordFields enabled.
    
    Test Plan:
    New test overloadedrecflds_generics, which tests that both
    GHC.Generics and Data.Data use the correct field labels, not mangled
    names.
    
    Reviewers: kosmikus, simonpj, austin, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D1486


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

2442038554440923179d532137199d5290875cff
 compiler/typecheck/TcGenGenerics.hs                |  4 +-
 testsuite/tests/overloadedrecflds/should_run/all.T |  1 +
 .../should_run/overloadedrecflds_generics.hs       | 49 ++++++++++++++++++++++
 .../should_run/overloadedrecflds_generics.stdout   |  4 ++
 4 files changed, 56 insertions(+), 2 deletions(-)

diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs
index 9a1c506..acb39de 100644
--- a/compiler/typecheck/TcGenGenerics.hs
+++ b/compiler/typecheck/TcGenGenerics.hs
@@ -737,7 +737,7 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
         loc           = srcLocSpan (getSrcLoc tycon)
         mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
         datacons      = tyConDataCons tycon
-        datasels      = map (map flSelector . dataConFieldLabels) datacons
+        datasels      = map dataConFieldLabels datacons
 
         tyConName_user = case tyConFamInst_maybe tycon of
                            Just (ptycon, _) -> tyConName ptycon
@@ -756,7 +756,7 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
         conFixity_matches   c = [mkSimpleHsAlt nlWildPat (fixity c)]
         conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
 
-        selName_matches     s = mkStringLHS (occNameString (nameOccName s))
+        selName_matches    fl = mkStringLHS (unpackFS (flLabel fl))
 
 
 --------------------------------------------------------------------------------
diff --git a/testsuite/tests/overloadedrecflds/should_run/all.T b/testsuite/tests/overloadedrecflds/should_run/all.T
index 21391ac..019a1ef 100644
--- a/testsuite/tests/overloadedrecflds/should_run/all.T
+++ b/testsuite/tests/overloadedrecflds/should_run/all.T
@@ -8,6 +8,7 @@ test('overloadedrecfldsrun03', normal, compile_and_run, [''])
 test('overloadedrecfldsrun04', normal, compile_and_run, [''])
 test('overloadedrecfldsrun05', normal, compile_and_run, [''])
 test('overloadedrecfldsrun06', normal, compile_and_run, [''])
+test('overloadedrecflds_generics', normal, compile_and_run, [''])
 test('overloadedlabelsrun01', normal, compile_and_run, [''])
 test('overloadedlabelsrun02', normal, compile_and_run, [''])
 test('overloadedlabelsrun03', normal, compile_and_run, [''])
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.hs
new file mode 100644
index 0000000..987a24f
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.hs
@@ -0,0 +1,49 @@
+-- Test that DuplicateRecordFields doesn't affect the metadata
+-- generated by GHC.Generics or Data.Data
+
+-- Based on a Stack Overflow post by bennofs
+-- (http://stackoverflow.com/questions/24474581)
+-- licensed under cc by-sa 3.0
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+
+import GHC.Generics
+import Data.Data
+import Data.Proxy
+
+type family FirstSelector (f :: * -> *) :: *
+type instance FirstSelector (M1 D x f) = FirstSelector f
+type instance FirstSelector (M1 C x f) = FirstSelector f
+type instance FirstSelector (a :*: b)  = FirstSelector a
+type instance FirstSelector (M1 S s f) = s
+
+data SelectorProxy s (f :: * -> *) a = SelectorProxy
+type SelectorProxy' s = SelectorProxy s Proxy ()
+
+-- Extract the first selector name using GHC.Generics
+firstSelectorName :: forall a. Selector (FirstSelector (Rep a))
+                  => Proxy a -> String
+firstSelectorName _ =
+    selName (SelectorProxy :: SelectorProxy' (FirstSelector (Rep a)))
+
+-- Extract the list of selector names for a constructor using Data.Data
+selectorNames :: Data a => a -> [String]
+selectorNames = constrFields . toConstr
+
+data T = MkT { foo :: Int } deriving (Data, Generic)
+data U = MkU { foo :: Int, bar :: Bool } deriving (Data, Generic)
+
+main = do -- This should yield "foo", not "$sel:foo:MkT"
+          print (firstSelectorName (Proxy :: Proxy T))
+          -- Similarly this should yield "foo"
+          print (firstSelectorName (Proxy :: Proxy U))
+          -- This should yield ["foo"]
+          print (selectorNames (MkT 3))
+          -- And this should yield ["foo","bar"]
+          print (selectorNames (MkU 3 True))
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.stdout
new file mode 100644
index 0000000..7212e4f
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.stdout
@@ -0,0 +1,4 @@
+"foo"
+"foo"
+["foo"]
+["foo","bar"]