From 2442038554440923179d532137199d5290875cff Mon Sep 17 00:00:00 2001
From: Adam Gundry <adam@well-typed.com>
Date: Thu, 19 Nov 2015 12:53:46 +0100
Subject: 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
---
 testsuite/tests/overloadedrecflds/should_run/all.T |  1 +
 .../should_run/overloadedrecflds_generics.hs       | 49 ++++++++++++++++++++++
 .../should_run/overloadedrecflds_generics.stdout   |  4 ++
 3 files changed, 54 insertions(+)
 create mode 100644 testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.hs
 create mode 100644 testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.stdout

(limited to 'testsuite/tests/overloadedrecflds')

diff --git a/testsuite/tests/overloadedrecflds/should_run/all.T b/testsuite/tests/overloadedrecflds/should_run/all.T
index 21391ac646..019a1efd99 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 0000000000..987a24f9bc
--- /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 0000000000..7212e4fb8c
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.stdout
@@ -0,0 +1,4 @@
+"foo"
+"foo"
+["foo"]
+["foo","bar"]
-- 
cgit v1.2.1