diff options
-rw-r--r-- | compiler/GHC/Rename/Names.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Types/Name/Occurrence.hs | 9 | ||||
-rw-r--r-- | testsuite/tests/overloadedrecflds/should_compile/T23220.hs | 20 | ||||
-rw-r--r-- | testsuite/tests/overloadedrecflds/should_compile/T23220_aux.hs | 24 | ||||
-rw-r--r-- | testsuite/tests/overloadedrecflds/should_compile/all.T | 3 |
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']) |