Relax assertion in varToRecFieldOcc

When using Template Haskell, it is possible to re-parent a field OccName
belonging to one data constructor to another data constructor. The
lsp-types package did this in order to "extend" a data constructor
with additional fields.

This ran into an assertion in 'varToRecFieldOcc'. This assertion
can simply be relaxed, as the resulting splices are perfectly sound.

Fixes #23220

5 files changed, 54 insertions, 4 deletions

diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 570fb1485d..e46d803287 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -1011,7 +1011,7 @@ newRecordFieldLabel dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld)))
                              , flSelector = selName } }
   where
     fld_occ = rdrNameOcc fld
-    dc_fs = (occNameFS $ nameOccName dc)
+    dc_fs = occNameFS $ nameOccName dc
     field
       -- Use an Exact RdrName as-is, to preserve the bindings
       -- of an already renamer-resolved field and its use
diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs
index 8aecadf71e..964c313abd 100644
--- a/compiler/GHC/Types/Name/Occurrence.hs
+++ b/compiler/GHC/Types/Name/Occurrence.hs
@@ -465,9 +465,12 @@ varToRecFieldOcc dc (OccName ns s) =
   assert makes_sense $ mkRecFieldOccFS dc s
     where
       makes_sense = case ns of
-        VarName     -> True
-        FldName con -> con == dc
-        _           -> False
+        VarName    -> True
+        FldName {} -> True
+          -- NB: it's OK to change the parent data constructor,
+          -- see e.g. test T23220 in which we construct with TH
+          -- a datatype using the fields of a different datatype.
+        _          -> False
 
 recFieldToVarOcc :: HasDebugCallStack => OccName -> OccName
 recFieldToVarOcc (OccName _ns s) = mkVarOccFS s
diff --git a/testsuite/tests/overloadedrecflds/should_compile/T23220.hs b/testsuite/tests/overloadedrecflds/should_compile/T23220.hs
new file mode 100644
index 0000000000..1b472daf77
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_compile/T23220.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module T23220 where
+
+import Language.Haskell.TH
+
+import T23220_aux ( makeExtendingDatatype )
+
+type Uri = String
+
+data TextDocumentIdentifier =
+  TextDocumentIdentifier
+    { _uri :: Uri
+    }
+
+type TextDocumentVersion = Maybe Int
+
+makeExtendingDatatype "VersionedTextDocumentIdentifier" [''TextDocumentIdentifier]
+  [ ("_version", [t| TextDocumentVersion |])]
diff --git a/testsuite/tests/overloadedrecflds/should_compile/T23220_aux.hs b/testsuite/tests/overloadedrecflds/should_compile/T23220_aux.hs
new file mode 100644
index 0000000000..ed55d7d261
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_compile/T23220_aux.hs
@@ -0,0 +1,24 @@
+module T23220_aux ( makeExtendingDatatype ) where
+
+import Control.Monad ( forM )
+import Language.Haskell.TH
+
+-- | @makeExtendingDatatype name extends fields@ generates a record datatype
+-- that contains all the fields of @extends@, plus the additional fields in
+-- @fields@.
+-- e.g.
+-- data Foo = { a :: Int }
+-- makeExtendingDatatype "bar" [''Foo] [("b", [t| String |])]
+-- Will generate
+-- data Bar = { a :: Int, b :: String }
+makeExtendingDatatype :: String -> [Name] -> [(String, TypeQ)] -> DecsQ
+makeExtendingDatatype datatypeNameStr extends fields = do
+  extendFields <- fmap concat $ forM extends $ \e -> do
+    TyConI (DataD _ _ _ _ [RecC _ eFields] _) <- reify e
+    return eFields
+  let datatypeName = mkName datatypeNameStr
+      constructor = recC datatypeName combinedFields
+      userFields = flip map fields $ \(s, typ) -> do
+        varBangType (mkName s) (bangType (bang noSourceUnpackedness noSourceStrictness) typ)
+      combinedFields = (map pure extendFields) <> userFields
+  (\a -> [a]) <$> dataD (cxt []) datatypeName [] Nothing [constructor] []
diff --git a/testsuite/tests/overloadedrecflds/should_compile/all.T b/testsuite/tests/overloadedrecflds/should_compile/all.T
index 000fd696e4..485aa3f51c 100644
--- a/testsuite/tests/overloadedrecflds/should_compile/all.T
+++ b/testsuite/tests/overloadedrecflds/should_compile/all.T
@@ -47,3 +47,6 @@ test('BootFldReexport'
       # Should either pass or give an ambiguity error when compiling
       # the final module (BootFldReexport), but not fail earlier.
     , ['BootFldReexport', '-v0'])
+test('T23220'
+    , [req_th, extra_files(['T23220_aux.hs'])]
+    , multimod_compile, ['T23220_aux.hs T23220.hs', '-v0'])