[Git][ghc/ghc][master] Relax assertion in varToRecFieldOcc

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
cd00e321 by sheaf at 2023-04-04T01:04:50-04:00
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 changed files:

- compiler/GHC/Rename/Names.hs
- compiler/GHC/Types/Name/Occurrence.hs
- + testsuite/tests/overloadedrecflds/should_compile/T23220.hs
- + testsuite/tests/overloadedrecflds/should_compile/T23220_aux.hs
- testsuite/tests/overloadedrecflds/should_compile/all.T


Changes:

=====================================
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


=====================================
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


=====================================
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 |])]


=====================================
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 at .
+-- 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] []


=====================================
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'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cd00e321d5d7aaee3999b283a2a2f0d77f7b3e8e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cd00e321d5d7aaee3999b283a2a2f0d77f7b3e8e
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230404/c5c3bb49/attachment-0001.html>