diff --git a/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DataDependencies.hs b/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DataDependencies.hs index 2119d668c5..5258705a75 100644 --- a/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DataDependencies.hs +++ b/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DataDependencies.hs @@ -388,7 +388,7 @@ generateSrcFromLf env = noLoc mod pure [ mkConDecl occName (RecCon (noLoc fields')) ] LF.DataVariant cons -> do sequence - [ mkConDecl (occNameFor conName) . details <$> convType env reexportedClasses ty + [ mkConDecl (occNameFor conName) <$> convConDetails ty | (conName, ty) <- cons ] LF.DataEnum cons -> do @@ -414,13 +414,22 @@ generateSrcFromLf env = noLoc mod , con_args = details } - -- In DAML we have sums of products, in DAML-LF a variant only has - -- a single field. Here we combine them back into a single type. - details :: HsType GhcPs -> HsConDeclDetails GhcPs - details = \case - HsRecTy _ext fs -> RecCon $ noLoc fs - ty -> PrefixCon [noLoc ty] + convConDetails :: LF.Type -> Gen (HsConDeclDetails GhcPs) + convConDetails = \case + -- | variant record constructor + LF.TConApp LF.Qualified{..} _ + | LF.TypeConName ns <- qualObject + , length ns == 2 -> + case MS.lookup ns (sumProdRecords $ envMod env) of + Nothing -> + error $ "Internal error: Could not find generated record type: " <> T.unpack (T.intercalate "." ns) + Just fs -> + RecCon . noLoc <$> mapM (uncurry (mkConDeclField env)) fs + + -- | normal payload + ty -> + PrefixCon . pure . noLoc <$> convType env reexportedClasses ty -- imports needed by the module declarations imports @@ -614,11 +623,6 @@ convType env reexported = ghcMod <- genModule env qualPackage qualModule pure . HsTyVar noExt NotPromoted . noLoc . mkOrig ghcMod . mkOccName varName $ T.unpack name - n@[_name0, _name1] -> case MS.lookup n (sumProdRecords $ envMod env) of - Nothing -> - error $ "Internal error: Could not find generated record type: " <> T.unpack (T.intercalate "." n) - Just fs -> - HsRecTy noExt <$> mapM (uncurry (mkConDeclField env)) fs cs -> errTooManyNameComponents cs LF.TApp ty1 ty2 -> do ty1' <- convType env reexported ty1 diff --git a/compiler/damlc/tests/src/DA/Test/Packaging.hs b/compiler/damlc/tests/src/DA/Test/Packaging.hs index 95eb86d925..f57d2808fa 100644 --- a/compiler/damlc/tests/src/DA/Test/Packaging.hs +++ b/compiler/damlc/tests/src/DA/Test/Packaging.hs @@ -1287,6 +1287,50 @@ dataDependencyTests damlc repl davlDar oldProjDar = testGroup "Data Dependencies , "f = pure () : Proxy ()" ] withCurrentDirectory (tmpDir "top") $ callProcessSilent damlc ["build", "-o", "top.dar"] + , testCaseSteps "Generic variants with record constructors" $ \step -> withTempDir $ \tmpDir -> do + -- This test checks that data definitions of the form + -- data A t = B t | C { x: t, y: t } + -- are handled correctly. This is a regression test for issue #4707. + step "building project with type definition" + createDirectoryIfMissing True (tmpDir "type") + writeFileUTF8 (tmpDir "type" "daml.yaml") $ unlines + [ "sdk-version: " <> sdkVersion + , "name: type" + , "source: ." + , "version: 0.1.0" + , "dependencies: [daml-prim, daml-stdlib]" + ] + writeFileUTF8 (tmpDir "type" "Foo.daml") $ unlines + [ "daml 1.2" + , "module Foo where" + , "data A t = B t | C { x: t, y: t }" + ] + withCurrentDirectory (tmpDir "type") $ + callProcessSilent damlc ["build", "-o", "type.dar"] + + step "building a project that uses it as a data-dependency" + createDirectoryIfMissing True (tmpDir "proj") + writeFileUTF8 (tmpDir "proj" "daml.yaml") $ unlines + [ "sdk-version: " <> sdkVersion + , "name: proj" + , "source: ." + , "version: 0.1.0" + , "dependencies: [daml-prim, daml-stdlib]" + , "data-dependencies: " + , " - " <> (tmpDir "type" "type.dar") + ] + writeFileUTF8 (tmpDir "proj" "Main.daml") $ unlines + [ "daml 1.2" + , "module Main where" + , "import Foo" + , "mkA : A Int" + , "mkA = C with" + , " x = 10" + , " y = 20" + ] + withCurrentDirectory (tmpDir "proj") $ + callProcessSilent damlc ["build"] + ] -- | Only displays stdout and stderr on errors