Reify DuplicateRecordFields by label, rather than by selector

See `Note [Reifying field labels]` in `TcSplice`. This makes
typical uses of TH work better with `DuplicateRecordFields`.
If `reify` is called on the `Name` of a field label produced by
the output of a previous `reify`, and there are multiple  fields
with that label defined in the same module, it may fail with
an ambiguity error.

Test Plan:
Added tests, and manually tested that this makes
Aeson's `deriveJSON` avoid the `$sel:` prefixes.

Reviewers: simonpj, goldfire, austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1586

GHC Trac Issues: #11103

6 files changed, 95 insertions, 3 deletions

diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 64f7d1d311..e5090a074e 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -100,6 +100,7 @@ import ErrUtils
 import Util
 import Unique
 import VarSet           ( isEmptyVarSet, filterVarSet )
+import Data.List        ( find )
 import Data.Maybe
 import BasicTypes hiding( SuccessFlag(..) )
 import Maybes( MaybeErr(..) )
@@ -1196,6 +1197,8 @@ reifyThing (AGlobal (AnId id))
         ; let v = reifyName id
         ; case idDetails id of
             ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls))
+            RecSelId{sel_tycon=RecSelData tc}
+                          -> return (TH.VarI (reifySelector id tc) ty Nothing)
             _             -> return (TH.VarI     v ty Nothing)
     }
 
@@ -1329,7 +1332,8 @@ reifyDataCon tys dc
        ; r_arg_tys <- reifyTypes arg_tys
 
        ; let main_con | not (null fields)
-                      = TH.RecC name (zip3 (map (reifyName . flSelector) fields) stricts r_arg_tys)
+                      = TH.RecC name
+                          (zip3 (map reifyFieldLabel fields) stricts r_arg_tys)
                       | dataConIsInfix dc
                       = ASSERT( length arg_tys == 2 )
                         TH.InfixC (s1,r_a1) name (s2,r_a2)
@@ -1676,6 +1680,25 @@ reifyName thing
             | OccName.isTcOcc   occ = TH.mkNameG_tc
             | otherwise             = pprPanic "reifyName" (ppr name)
 
+-- See Note [Reifying field labels]
+reifyFieldLabel :: FieldLabel -> TH.Name
+reifyFieldLabel fl
+  | flIsOverloaded fl
+              = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str))
+  | otherwise = TH.mkNameG_v pkg_str mod_str occ_str
+  where
+    name    = flSelector fl
+    mod     = ASSERT( isExternalName name ) nameModule name
+    pkg_str = unitIdString (moduleUnitId mod)
+    mod_str = moduleNameString (moduleName mod)
+    occ_str = unpackFS (flLabel fl)
+
+reifySelector :: Id -> TyCon -> TH.Name
+reifySelector id tc
+  = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of
+      Just fl -> reifyFieldLabel fl
+      Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc)
+
 ------------------------------
 reifyFixity :: Name -> TcM TH.Fixity
 reifyFixity name
@@ -1763,6 +1786,32 @@ will appear in TH syntax like this
 
   data T a = forall b. (a ~ [b]) => MkT1 b
            | (a ~ Int) => MkT2
+
+Note [Reifying field labels]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When reifying a datatype declared with DuplicateRecordFields enabled, we want
+the reified names of the fields to be labels rather than selector functions.
+That is, we want (reify ''T) and (reify 'foo) to produce
+
+    data T = MkT { foo :: Int }
+    foo :: T -> Int
+
+rather than
+
+    data T = MkT { $sel:foo:MkT :: Int }
+    $sel:foo:MkT :: T -> Int
+
+because otherwise TH code that uses the field names as strings will silently do
+the wrong thing.  Thus we use the field label (e.g. foo) as the OccName, rather
+than the selector (e.g. $sel:foo:MkT).  Since the Orig name M.foo isn't in the
+environment, NameG can't be used to represent such fields.  Instead,
+reifyFieldLabel uses NameQ.
+
+However, this means that extracting the field name from the output of reify, and
+trying to reify it again, may fail with an ambiguity error if there are multiple
+such fields defined in the module (see the test case
+overloadedrecflds/should_fail/T11103.hs).  The "proper" fix requires changes to
+the TH AST to make it able to represent duplicate record fields.
 -}
 
 #endif  /* GHCI */
diff --git a/testsuite/tests/overloadedrecflds/should_fail/T11103.hs b/testsuite/tests/overloadedrecflds/should_fail/T11103.hs
new file mode 100644
index 0000000000..2ba8e41a22
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/T11103.hs
@@ -0,0 +1,20 @@
+-- When using DuplicateRecordFields with TemplateHaskell, it is not possible to
+-- reify ambiguous names that are output by reifying field labels.
+-- See also overloadedrecflds/should_run/overloadedrecfldsrun04.hs
+
+{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-}
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+data R = MkR { foo :: Int, bar :: Int }
+data S = MkS { foo :: Int }
+
+$(do info <- reify ''R
+     case info of
+       TyConI (DataD _ _ _ [RecC _ [(foo_n, _, _), (bar_n, _, _)]] _)
+         -> do { reify bar_n -- This is unambiguous
+               ; reify foo_n -- This is ambiguous
+               ; return []
+               }
+       _ -> error "unexpected result of reify")
diff --git a/testsuite/tests/overloadedrecflds/should_fail/T11103.stderr b/testsuite/tests/overloadedrecflds/should_fail/T11103.stderr
new file mode 100644
index 0000000000..b4f29fbfb7
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/T11103.stderr
@@ -0,0 +1,6 @@
+
+T11103.hs:13:3: error:
+    Ambiguous occurrence ‘Main.foo’
+    It could refer to either the field ‘foo’,
+                             defined at T11103.hs:11:16
+                          or the field ‘foo’, defined at T11103.hs:10:16
diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T
index a1b8ccb4ad..362640539e 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/all.T
+++ b/testsuite/tests/overloadedrecflds/should_fail/all.T
@@ -25,6 +25,7 @@ test('overloadedrecfldsfail12',
 test('overloadedrecfldsfail13', normal, compile_fail, [''])
 test('overloadedrecfldsfail14', normal, compile_fail, [''])
 test('overloadedlabelsfail01', normal, compile_fail, [''])
+test('T11103', normal, compile_fail, [''])
 test('T11167_ambiguous_fixity',
      extra_clean([ 'T11167_ambiguous_fixity_A.hi', 'T11167_ambiguous_fixity_A.o'
                  , 'T11167_ambiguous_fixity_B.hi', 'T11167_ambiguous_fixity_B.o' ]),
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs
index ed26e0f984..e70c5db7b1 100644
--- a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs
@@ -13,5 +13,18 @@ $(return [])
 
 -- ... and check that we can inspect it
 main = do  putStrLn $(do { info <- reify ''R
-                         ; lift (pprint info) })
+                         ; case info of
+                             TyConI (DataD _ _ _ [RecC _ [(n, _, _)]] _) ->
+                                 do { info' <- reify n
+                                    ; lift (pprint info ++ "\n" ++ pprint info')
+                                    }
+                             _ -> error "unexpected result of reify"
+                         })
+           putStrLn $(do { info <- reify 'foo
+                         ; case info of
+                             VarI n _ _ ->
+                                 do { info' <- reify n
+                                    ; lift (pprint info ++ "\n" ++ pprint info')
+                                    }
+                         })
            print (foo (MkR { foo = 42 }))
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.stdout
index 1dbffc722b..a04c9b9ede 100644
--- a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.stdout
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.stdout
@@ -1,2 +1,5 @@
-data Main.R = Main.MkR {Main.$sel:foo:MkR :: GHC.Types.Int}
+data Main.R = Main.MkR {Main.foo :: GHC.Types.Int}
+Main.foo :: Main.R -> GHC.Types.Int
+Main.foo :: Main.R -> GHC.Types.Int
+Main.foo :: Main.R -> GHC.Types.Int
 42