digital-asset/daml
1
1
Fork 0
mirror of https://github.com/digital-asset/daml.git synced 2024-09-20 01:07:18 +03:00
Code Issues Projects Releases Wiki Activity

Move all datatypes out of daml-prim (#3791)

Browse Source 
* Move all datatypes out of daml-prim

This moves the remaining two modules DA.Types and GHC.Tuple to
separate LF packages with stable identifiers.

The only data types remaining are the ones for typeclasses which will
disappear once we move this to type synonyms.

CHANGELOG_BEGIN

- [DAML Compiler] The modules DA.Types and GHC.Tuple from daml-prim
have been moved to separate packages.

CHANGELOG_END

* Fix codegen tests

* Fix DarReader test

* Fix kvutils tests

* Fix jdbcdao tests

* Fix hs ledger bindings tests
This commit is contained in:
Moritz Kiefer 2019-12-10 09:19:16 +01:00 committed by Martin Huschenbett
parent 37fa12c943
commit e769264ddf
10 changed files with 123 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs
View File

@ -339,7 +339,7 @@ generateSerializedDalfRule options =
, runRule = do
lfVersion <- getDamlLfVersion
-- build dependencies
files <- discardInternalModules . transitiveModuleDeps =<< use_ GetDependencies file
files <- discardInternalModules (optMbPackageName options) . transitiveModuleDeps =<< use_ GetDependencies file
dalfDeps <- uses_ ReadSerializedDalf files
-- type checking
pm <- use_ GetParsedModule file
@ -501,7 +501,7 @@ generateSerializedPackage :: String -> [NormalizedFilePath] -> MaybeT Action LF.
generateSerializedPackage pkgName rootFiles = do
fileDeps <- usesE GetDependencies rootFiles
let allFiles = nubSort $ rootFiles <> concatMap transitiveModuleDeps fileDeps
files <- lift $ discardInternalModules allFiles
files <- lift $ discardInternalModules (Just pkgName) allFiles
dalfs <- usesE ReadSerializedDalf files
lfVersion <- lift getDamlLfVersion
pure $ buildPackage (Just pkgName) lfVersion dalfs
@ -545,7 +545,7 @@ generateRawPackageRule options =
define $ \GenerateRawPackage file -> do
lfVersion <- getDamlLfVersion
fs <- transitiveModuleDeps <$> use_ GetDependencies file
files <- discardInternalModules (fs ++ [file])
files <- discardInternalModules (optMbPackageName options) (fs ++ [file])
dalfs <- uses_ GenerateRawDalf files
-- build package
let pkg = buildPackage (optMbPackageName options) lfVersion dalfs
@ -556,7 +556,7 @@ generatePackageDepsRule options =
define $ \GeneratePackageDeps file -> do
lfVersion <- getDamlLfVersion
fs <- transitiveModuleDeps <$> use_ GetDependencies file
files <- discardInternalModules fs
files <- discardInternalModules (optMbPackageName options) fs
dalfs <- uses_ GenerateDalf files
-- build package
@ -846,12 +846,12 @@ runScenario scenarioService file ctxId scenario = do
let vr = VRScenario file (LF.unExprValName scenarioName)
pure (vr, res)
encodeModuleRule :: Rules ()
encodeModuleRule =
encodeModuleRule :: Options -> Rules ()
encodeModuleRule options =
define $ \EncodeModule file -> do
lfVersion <- getDamlLfVersion
fs <- transitiveModuleDeps <$> use_ GetDependencies file
files <- discardInternalModules fs
files <- discardInternalModules (optMbPackageName options) fs
encodedDeps <- uses_ EncodeModule files
m <- dalfForScenario file
let (hash, bs) = SS.encodeModule lfVersion m
@ -932,9 +932,17 @@ getDamlLfVersion :: Action LF.Version
getDamlLfVersion = envDamlLfVersion <$> getDamlServiceEnv
-- | This operates on file paths rather than module names so that we avoid introducing a dependency on GetParsedModule.
discardInternalModules :: [NormalizedFilePath] -> Action [NormalizedFilePath]
discardInternalModules files =
pure $ filter (\f -> not $ any (\internalMod -> internalMod `isSuffixOf` fromNormalizedFilePath f) internalModules) files
discardInternalModules :: Maybe String -> [NormalizedFilePath] -> Action [NormalizedFilePath]
discardInternalModules mbPackageName files = do
stablePackages <- useNoFile_ GenerateStablePackages
pure $ filter (shouldKeep stablePackages) files
where shouldKeep stablePackages f =
not (any (`isSuffixOf` fromNormalizedFilePath f) internalModules) &&
not (any (\(unitId, modName) ->
mbPackageName == Just (GHC.unitIdString unitId) &&
moduleNameFile modName `isSuffixOf` fromNormalizedFilePath f)
$ Map.keys stablePackages)
moduleNameFile (LF.ModuleName segments) = joinPath (map T.unpack segments) <.> "daml"
internalModules :: [FilePath]
internalModules = map normalise
@ -972,7 +980,7 @@ damlRule opts = do
getScenarioRootRule
getDlintDiagnosticsRule
ofInterestRule opts
encodeModuleRule
encodeModuleRule opts
createScenarioContextRule
getOpenVirtualResourcesRule
getDlintSettingsRule (optDlintUsage opts)

2
compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
View File

@ -1427,7 +1427,7 @@ qualify env m x = do
qDA_Types :: Env -> a -> ConvertM (Qualified a)
qDA_Types env a = do
pkgRef <- packageNameToPkgRef env "daml-prim"
pure $ Qualified pkgRef (mkModName ["DA", "Types"]) a
pure $ rewriteStableQualified env $ Qualified pkgRef (mkModName ["DA", "Types"]) a
-- | Rewrite an a qualified name into a reference into one of the hardcoded
-- stable packages if there is one.

23
compiler/damlc/lib/DA/Cli/Damlc.hs
View File

@ -58,7 +58,7 @@ import qualified Data.NameMap as NM
import qualified Data.Set as Set
import qualified Data.Text.Extended as T
import Development.IDE.Core.API
import Development.IDE.Core.RuleTypes.Daml (GetParsedModule(..))
import Development.IDE.Core.RuleTypes.Daml (GetParsedModule(..), GenerateStablePackages(..), GeneratePackageMap(..))
import Development.IDE.Core.Rules
import Development.IDE.Core.Rules.Daml (getDalf, getDlintIdeas)
import Development.IDE.Core.Service (runAction)
@ -785,17 +785,16 @@ execGenerateSrc opts dalfFp mbOutDir = Command GenerateSrc effect
effect = do
bytes <- B.readFile dalfFp
(pkgId, pkg) <- decode bytes
opts' <- mkOptions opts
pkgMap0 <-
fmap MS.unions $
forM (optPackageDbs opts') $ \dbDir -> do
allFiles <- listFilesRecursive dbDir
let dalfsFp = filter (".dalf" `isExtensionOf`) allFiles
fmap MS.fromList $
forM dalfsFp $ \dalfFp -> do
dalfBS <- B.readFile dalfFp
(pkgId, _pkg) <- decode dalfBS
pure (pkgId, stringToUnitId $ takeFileName dalfFp)
opts <- mkOptions opts
logger <- getLogger opts "generate-src"
pkgMap0 <- withDamlIdeState opts { optScenarioService = EnableScenarioService False } logger diagnosticsLogger $ \ideState -> runAction ideState $ do
stablePkgs <-
MS.fromList . map (\((unitId, _modName), dalfPkg) -> (LF.dalfPackageId dalfPkg, unitId)) . MS.toList <$>
useNoFile_ GenerateStablePackages
pkgs <-
MS.fromList . map (\(unitId, dalfPkg) -> (LF.dalfPackageId dalfPkg, unitId)) . MS.toList <$>
useNoFile_ GeneratePackageMap
pure $ stablePkgs `MS.union` pkgs
let pkgMap = MS.insert pkgId unitId pkgMap0
let genSrcs = generateSrcPkgFromLf (getUnitId unitId pkgMap) (Just "Sdk") pkg
forM_ genSrcs $ \(path, src) -> do

6
compiler/damlc/stable-packages/BUILD.bazel
View File

@ -27,10 +27,14 @@ genrule(
outs = [
"daml-prim/GHC-Types.dalf",
"daml-prim/GHC-Prim.dalf",
"daml-prim/GHC-Tuple.dalf",
"daml-prim/DA-Types.dalf",
],
cmd = """
$(location :generate-stable-package) --module GHC.Types -o $(location daml-prim/GHC-Types.dalf)
$(location :generate-stable-package) --module GHC.Prim -o $(location daml-prim/GHC-Prim.dalf)
$(location :generate-stable-package) --module GHC.Tuple -o $(location daml-prim/GHC-Tuple.dalf)
$(location :generate-stable-package) --module DA.Types -o $(location daml-prim/DA-Types.dalf)
""",
tools = [":generate-stable-package"],
visibility = ["//visibility:public"],
@ -39,7 +43,9 @@ genrule(
filegroup(
name = "stable-packages",
srcs = [
"daml-prim/DA-Types.dalf",
"daml-prim/GHC-Prim.dalf",
"daml-prim/GHC-Tuple.dalf",
"daml-prim/GHC-Types.dalf",
],
visibility = ["//visibility:public"],

72
compiler/damlc/stable-packages/src/GenerateStablePackage.hs
View File

@ -53,6 +53,10 @@ main = do
writePackage ghcTypes optOutputPath
ModuleName ["GHC", "Prim"] ->
writePackage ghcPrim optOutputPath
ModuleName ["GHC", "Tuple"] ->
writePackage ghcTuple optOutputPath
ModuleName ["DA", "Types"] ->
writePackage daTypes optOutputPath
_ -> fail $ "Unknown module: " <> show optModule
lfVersion :: Version
@ -111,3 +115,71 @@ ghcPrim = Module
, dvalBody = EEnumCon (qual (dataTypeCon dataVoid)) conName
}
daTypes :: Module
daTypes = Module
{ moduleName = modName
, moduleSource = Nothing
, moduleFeatureFlags = daml12FeatureFlags
, moduleTemplates = NM.empty
, moduleDataTypes = types
, moduleValues = values
}
where
modName = mkModName ["DA", "Types"]
types = NM.fromList $
(DefDataType Nothing (mkTypeCon ["Either"]) (IsSerializable True) eitherTyVars $
DataVariant [(mkVariantCon "Left", TVar aTyVar), (mkVariantCon "Right", TVar bTyVar)]
) : map tupleN [2..20]
tupleN n = DefDataType
Nothing
(tupleTyName n)
(IsSerializable True)
[(tupleTyVar i, KStar) | i <- [1..n]]
(DataRecord [(mkIndexedField i, TVar (tupleTyVar i)) | i <- [1..n]])
aTyVar = mkTypeVar "a"
bTyVar = mkTypeVar "b"
eitherTyVars = [(aTyVar, KStar), (bTyVar, KStar)]
eitherTyConApp = TypeConApp (Qualified PRSelf modName (mkTypeCon ["Either"])) [TVar aTyVar, TVar bTyVar]
eitherTy = typeConAppToType eitherTyConApp
values = NM.fromList $ eitherWorkers ++ tupleWorkers
eitherWorkers =
[ DefValue Nothing (mkWorkerName "Left", mkTForalls eitherTyVars (TVar aTyVar :-> eitherTy)) (HasNoPartyLiterals True) (IsTest False) $
mkETyLams eitherTyVars (ETmLam (mkVar "a", TVar aTyVar) (EVariantCon eitherTyConApp (mkVariantCon "Left") (EVar $ mkVar "a")))
, DefValue Nothing (mkWorkerName "Right", mkTForalls eitherTyVars (TVar bTyVar :-> eitherTy)) (HasNoPartyLiterals True) (IsTest False) $
mkETyLams eitherTyVars (ETmLam (mkVar "b", TVar bTyVar) (EVariantCon eitherTyConApp (mkVariantCon "Right") (EVar $ mkVar "b")))
]
tupleTyVar i = mkTypeVar ("t" <> T.pack (show i))
tupleTyVars n = [(tupleTyVar i, KStar) | i <- [1..n]]
tupleTyName n = mkTypeCon ["Tuple" <> T.pack (show n)]
tupleTyConApp n = TypeConApp (Qualified PRSelf modName (tupleTyName n)) (map (TVar . tupleTyVar) [1..n])
tupleTy = typeConAppToType . tupleTyConApp
tupleTmVar i = mkVar $ "a" <> T.pack (show i)
tupleWorker n = DefValue Nothing (mkWorkerName $ "Tuple" <> T.pack (show n), mkTForalls (tupleTyVars n) (mkTFuns (map (TVar . tupleTyVar) [1..n]) $ tupleTy n)) (HasNoPartyLiterals True) (IsTest False) $
mkETyLams (tupleTyVars n) $ mkETmLams [(tupleTmVar i, TVar $ tupleTyVar i) | i <- [1..n]] $
ERecCon (tupleTyConApp n) [(mkIndexedField i, EVar $ tupleTmVar i) | i <- [1..n]]
tupleWorkers = map tupleWorker [2..20]
ghcTuple :: Module
ghcTuple = Module
{ moduleName = modName
, moduleSource = Nothing
, moduleFeatureFlags = daml12FeatureFlags
, moduleTemplates = NM.empty
, moduleDataTypes = types
, moduleValues = values
}
where
modName = mkModName ["GHC", "Tuple"]
tyVar = mkTypeVar "a"
tyVars = [(tyVar, KStar)]
unitTyCon = mkTypeCon ["Unit"]
unitTyConApp = TypeConApp (Qualified PRSelf modName unitTyCon) [TVar tyVar]
unitTy = typeConAppToType unitTyConApp
types = NM.fromList
[ DefDataType Nothing unitTyCon (IsSerializable True) tyVars $
DataRecord [(mkIndexedField 1, TVar tyVar)]
]
values = NM.fromList
[ DefValue Nothing (mkWorkerName "Unit", mkTForalls tyVars (TVar tyVar :-> unitTy)) (HasNoPartyLiterals True) (IsTest False) $
mkETyLams tyVars $ mkETmLams [(mkVar "a", TVar tyVar)] (ERecCon unitTyConApp [(mkIndexedField 1, EVar $ mkVar "a")])
]

8
daml-lf/archive/src/test/scala/com/digitalasset/daml/lf/archive/DarReaderTest.scala
View File

@ -37,17 +37,23 @@ class DarReaderTest extends WordSpec with Matchers with Inside with BazelRunfile
((packageId3, archive3), LanguageMajorVersion.V1) ::
((packageId4, archive4), LanguageMajorVersion.V1) ::
((packageId5, archive5), LanguageMajorVersion.V1) ::
((packageId6, archive6), LanguageMajorVersion.V1) ::
((packageId7, archive7), LanguageMajorVersion.V1) ::
Nil)) =>
packageId1 shouldNot be('empty)
packageId2 shouldNot be('empty)
packageId3 shouldNot be('empty)
packageId4 shouldNot be('empty)
packageId5 shouldNot be('empty)
packageId6 shouldNot be('empty)
packageId7 shouldNot be('empty)
archive1.getDamlLf1.getModulesCount should be > 0
archive2.getDamlLf1.getModulesCount should be > 0
archive3.getDamlLf1.getModulesCount should be > 0
archive4.getDamlLf1.getModulesCount should be > 0
archive5.getDamlLf1.getModulesCount should be > 0
archive6.getDamlLf1.getModulesCount should be > 0
archive7.getDamlLf1.getModulesCount should be > 0
val archive1Modules = archive1.getDamlLf1.getModulesList.asScala
val archive1InternedDotted = archive1.getDamlLf1.getInternedDottedNamesList.asScala
@ -82,10 +88,8 @@ class DarReaderTest extends WordSpec with Matchers with Inside with BazelRunfile
"GHC.Enum",
"GHC.Show",
"GHC.Num",
"DA.Types",
"GHC.Classes",
"Control.Exception.Base",
"GHC.Tuple",
"GHC.Err",
"GHC.Base",
"LibraryModules"

2
language-support/hs/bindings/test/DA/Ledger/Tests.hs
View File

@ -129,7 +129,7 @@ tListPackages withSandbox = testCase "listPackages" $ run withSandbox $ \pid _te
lid <- getLedgerIdentity
pids <- listPackages lid
liftIO $ do
assertEqual "#packages" 5 (length pids)
assertEqual "#packages" 7 (length pids)
assertBool "The pid is listed" (pid `elem` pids)
tGetPackage :: SandboxTest

6
language-support/java/codegen/src/test/scala/com/digitalasset/daml/lf/codegen/CodeGenRunnerTests.scala
View File

@ -35,7 +35,7 @@ class CodeGenRunnerTests extends FlatSpec with Matchers with BazelRunfiles {
val (interfaces, pkgPrefixes) = CodeGenRunner.collectDamlLfInterfaces(conf)
assert(interfaces.length == 5)
assert(interfaces.length == 7)
assert(pkgPrefixes == Map.empty)
}
@ -48,8 +48,8 @@ class CodeGenRunnerTests extends FlatSpec with Matchers with BazelRunfiles {
val (interfaces, pkgPrefixes) = CodeGenRunner.collectDamlLfInterfaces(conf)
assert(interfaces.map(_.packageId).length == 5)
assert(pkgPrefixes.size == 5)
assert(interfaces.map(_.packageId).length == 7)
assert(pkgPrefixes.size == 7)
assert(pkgPrefixes.values.forall(_ == "PREFIX"))
}
}

2
ledger/participant-state/kvutils/src/test/suite/scala/com/daml/ledger/participant/state/kvutils/KVUtilsPackageSpec.scala
View File

@ -52,7 +52,7 @@ class KVUtilsPackageSpec extends WordSpec with Matchers with BazelRunfiles {
logEntry <- submitArchives("test-stable-submission", testStablePackages.all: _*).map(_._2)
} yield {
logEntry.getPayloadCase shouldEqual DamlLogEntry.PayloadCase.PACKAGE_UPLOAD_ENTRY
logEntry.getPackageUploadEntry.getArchivesCount shouldEqual 5
logEntry.getPackageUploadEntry.getArchivesCount shouldEqual 7
}
}

4
ledger/sandbox/src/test/suite/scala/com/digitalasset/platform/sandbox/stores/ledger/sql/JdbcLedgerDaoSpec.scala
View File

@ -450,13 +450,15 @@ class JdbcLedgerDaoSpec
} yield {
firstUploadResult shouldBe Map(PersistenceResponse.Ok -> 1)
secondUploadResult shouldBe Map(
PersistenceResponse.Ok -> 4,
PersistenceResponse.Ok -> 6,
PersistenceResponse.Duplicate -> 1)
loadedPackages.values.flatMap(_.sourceDescription.toList) should contain theSameElementsAs Seq(
firstDescription,
secondDescription,
secondDescription,
secondDescription,
secondDescription,
secondDescription,
secondDescription)
}
}