Fix interaction of DuplicateRecordFields and GHC.Generics
authorAdam Gundry <adam@well-typed.com>
Thu, 19 Nov 2015 11:53:46 +0000 (12:53 +0100)
committerBen Gamari <ben@smart-cactus.org>
Thu, 19 Nov 2015 12:24:32 +0000 (13:24 +0100)
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

compiler/typecheck/TcGenGenerics.hs
testsuite/tests/overloadedrecflds/should_run/all.T
testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.hs [new file with mode: 0644]
testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.stdout [new file with mode: 0644]

index 9a1c506..acb39de 100644 (file)
@@ -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))
 
 
 --------------------------------------------------------------------------------
index 21391ac..019a1ef 100644 (file)
@@ -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 (file)
index 0000000..987a24f
--- /dev/null
@@ -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 (file)
index 0000000..7212e4f
--- /dev/null
@@ -0,0 +1,4 @@
+"foo"
+"foo"
+["foo"]
+["foo","bar"]