diff --git a/compiler/damlc/stable-packages/BUILD.bazel b/compiler/damlc/stable-packages/BUILD.bazel index b3f615ab1643..5bf4e217e2d8 100644 --- a/compiler/damlc/stable-packages/BUILD.bazel +++ b/compiler/damlc/stable-packages/BUILD.bazel @@ -1,7 +1,25 @@ # Copyright (c) 2021 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. # SPDX-License-Identifier: Apache-2.0 -load("//bazel_tools:haskell.bzl", "da_haskell_binary") +load("//bazel_tools:haskell.bzl", "da_haskell_binary", "da_haskell_library") + +da_haskell_library( + name = "stable-packages-lib", + srcs = glob(["lib/**/*.hs"]), + hackage_deps = [ + "base", + "bytestring", + "containers", + "text", + ], + visibility = ["//visibility:public"], + deps = [ + "//compiler/daml-lf-ast", + "//compiler/daml-lf-proto", + "//compiler/damlc/daml-lf-conversion", + "//libs-haskell/da-hs-base", + ], +) da_haskell_binary( name = "generate-stable-package", @@ -9,15 +27,16 @@ da_haskell_binary( hackage_deps = [ "base", "bytestring", + "containers", "optparse-applicative", "text", ], main_function = "GenerateStablePackage.main", visibility = ["//visibility:public"], deps = [ + ":stable-packages-lib", "//compiler/daml-lf-ast", "//compiler/daml-lf-proto", - "//compiler/damlc/daml-lf-conversion", "//libs-haskell/da-hs-base", ], ) diff --git a/compiler/damlc/stable-packages/lib/DA/Daml/StablePackages.hs b/compiler/damlc/stable-packages/lib/DA/Daml/StablePackages.hs new file mode 100644 index 000000000000..29414dfc925c --- /dev/null +++ b/compiler/damlc/stable-packages/lib/DA/Daml/StablePackages.hs @@ -0,0 +1,615 @@ +-- Copyright (c) 2021 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module DA.Daml.StablePackages + ( allStablePackages + , allStablePackagesForVersion + , numStablePackagesForVersion + , stablePackageByModuleName + ) where + +import Data.Bifunctor +import qualified Data.Map.Strict as MS +import qualified Data.NameMap as NM +import qualified Data.Text as T + +import DA.Daml.LF.Ast +import DA.Daml.LF.Proto3.Archive +import DA.Daml.LFConversion.UtilLF + +allStablePackages :: [Package] +allStablePackages = + [ ghcTypes + , ghcPrim + , ghcTuple + , daTypes + , daInternalTemplate + , daInternalAny + , daTimeTypes + , daNonEmptyTypes + , daDateTypes + , daSemigroupTypes + , daMonoidTypes + , daLogicTypes + , daValidationTypes (encodePackageHash daNonEmptyTypes) + , daInternalDown + , daInternalErased + , daInternalPromotedText + , daSetTypes + , daExceptionGeneralError + , daExceptionArithmeticError + , daExceptionContractError + ] + +allStablePackagesForVersion :: Version -> [Package] +allStablePackagesForVersion v = + filter (\p -> packageLfVersion p <= v) allStablePackages + +numStablePackagesForVersion :: Version -> Int +numStablePackagesForVersion v = length (allStablePackagesForVersion v) + +stablePackageByModuleName :: MS.Map ModuleName Package +stablePackageByModuleName = MS.fromListWithKey + (\k -> error $ "Duplicate module among stable packages: " <> show k) + [ (moduleName m, p) + | p <- allStablePackages + , m <- NM.toList (packageModules p) ] + +ghcTypes :: Package +ghcTypes = package version1_6 $ NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleSynonyms = NM.empty + , moduleDataTypes = NM.fromList [dataOrdering] + , moduleValues = NM.empty + , moduleTemplates = NM.empty + , moduleExceptions = NM.empty + } + where + modName = mkModName ["GHC", "Types"] + cons = ["LT", "EQ", "GT"] + dataOrdering = DefDataType + { dataLocation= Nothing + , dataTypeCon = mkTypeCon ["Ordering"] + , dataSerializable = IsSerializable True + , dataParams = [] + , dataCons = DataEnum $ map mkVariantCon cons + } + +ghcPrim :: Package +ghcPrim = package version1_6 $ NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleSynonyms = NM.empty + , moduleDataTypes = NM.fromList [dataVoid] + , moduleValues = NM.fromList [valVoid] + , moduleTemplates = NM.empty + , moduleExceptions = NM.empty + } + where + modName = mkModName ["GHC", "Prim"] + qual = Qualified PRSelf modName + conName = mkVariantCon "Void#" + dataVoid = DefDataType + { dataLocation= Nothing + , dataTypeCon = mkTypeCon ["Void#"] + , dataSerializable = IsSerializable False + , dataParams = [] + , dataCons = DataEnum [conName] + } + valVoid = DefValue + { dvalLocation = Nothing + , dvalBinder = (mkVal "void#", TCon (qual (dataTypeCon dataVoid))) + , dvalNoPartyLiterals= HasNoPartyLiterals True + , dvalIsTest = IsTest False + , dvalBody = EEnumCon (qual (dataTypeCon dataVoid)) conName + } + +package :: Version -> NM.NameMap Module -> Package +package ver mods + | ver > version1_7 = error "Packages with LF version >= 1.7 need to have package metadata" + | otherwise = Package ver mods Nothing + +daTypes :: Package +daTypes = package version1_6 $ NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleTemplates = NM.empty + , moduleSynonyms = NM.empty + , moduleDataTypes = types + , moduleValues = values + , moduleExceptions = NM.empty + } + 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 :: Package +ghcTuple = package version1_6 $ NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleTemplates = NM.empty + , moduleSynonyms = NM.empty + , moduleDataTypes = types + , moduleValues = values + , moduleExceptions = NM.empty + } + where + modName = mkModName ["GHC", "Tuple"] + tyVar = mkTypeVar "a" + tyVars = [(tyVar, KStar)] + unitTyCon = mkTypeCon ["Unit"] + types = NM.fromList + [ DefDataType Nothing unitTyCon (IsSerializable True) tyVars $ + DataRecord [(mkIndexedField 1, TVar tyVar)] + ] + values = NM.fromList + [ mkWorkerDef modName unitTyCon tyVars [(mkIndexedField 1, TVar tyVar)] + ] + +daInternalTemplate :: Package +daInternalTemplate = package version1_6 $ NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleSynonyms = NM.empty + , moduleDataTypes = types + , moduleValues = NM.fromList [] + , moduleTemplates = NM.empty + , moduleExceptions = NM.empty + } + where + modName = mkModName ["DA", "Internal", "Template"] + types = NM.fromList + [ DefDataType Nothing (mkTypeCon ["Archive"]) (IsSerializable True) [] $ + DataRecord [] + ] + +daInternalAny :: Package +daInternalAny = package version1_7 $ NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleSynonyms = NM.empty + , moduleDataTypes = types + , moduleValues = NM.empty + , moduleTemplates = NM.empty + , moduleExceptions = NM.empty + } + where + modName = mkModName ["DA", "Internal", "Any"] + types = NM.fromList + [ DefDataType Nothing (mkTypeCon ["AnyTemplate"]) (IsSerializable False) [] $ + DataRecord [(mkField "getAnyTemplate", TAny)] + , DefDataType Nothing (mkTypeCon ["TemplateTypeRep"]) (IsSerializable False) [] $ + DataRecord [(mkField "getTemplateTypeRep", TTypeRep)] + , DefDataType Nothing (mkTypeCon ["AnyChoice"]) (IsSerializable False) [] $ + DataRecord [(mkField "getAnyChoice", TAny), (mkField "getAnyChoiceTemplateTypeRep", TCon (Qualified PRSelf modName (mkTypeCon ["TemplateTypeRep"])))] + , DefDataType Nothing (mkTypeCon ["AnyContractKey"]) (IsSerializable False) [] $ + DataRecord [(mkField "getAnyContractKey", TAny), (mkField "getAnyContractKeyTemplateTypeRep", TCon (Qualified PRSelf modName (mkTypeCon ["TemplateTypeRep"])))] + ] + +daTimeTypes :: Package +daTimeTypes = package version1_6 $ NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleSynonyms = NM.empty + , moduleDataTypes = types + , moduleValues = values + , moduleTemplates = NM.empty + , moduleExceptions = NM.empty + } + where + modName = mkModName ["DA", "Time", "Types"] + relTimeTyCon = mkTypeCon ["RelTime"] + types = NM.fromList + [ DefDataType Nothing relTimeTyCon (IsSerializable True) [] $ + DataRecord [(usField, TInt64)] + ] + values = NM.fromList + [ mkSelectorDef modName relTimeTyCon [] usField TInt64 + , mkWorkerDef modName relTimeTyCon [] [(usField, TInt64)] + ] + usField = mkField "microseconds" + +daNonEmptyTypes :: Package +daNonEmptyTypes = package version1_6 $ NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleSynonyms = NM.empty + , moduleDataTypes = types + , moduleValues = values + , moduleTemplates = NM.empty + , moduleExceptions = NM.empty + } + where + modName = mkModName ["DA", "NonEmpty", "Types"] + hdField = mkField "hd" + tlField = mkField "tl" + tyVar = mkTypeVar "a" + tyVars = [(tyVar, KStar)] + nonEmptyTyCon = mkTypeCon ["NonEmpty"] + types = NM.fromList + [ DefDataType Nothing nonEmptyTyCon (IsSerializable True) tyVars $ + DataRecord [(hdField, TVar tyVar), (tlField, TList (TVar tyVar))] + ] + values = NM.fromList + [ mkWorkerDef modName nonEmptyTyCon tyVars [(hdField, TVar tyVar), (tlField, TList (TVar tyVar))] + , mkSelectorDef modName nonEmptyTyCon tyVars hdField (TVar tyVar) + , mkSelectorDef modName nonEmptyTyCon tyVars tlField (TList (TVar tyVar)) + ] + +daDateTypes :: Package +daDateTypes = package version1_6 $ NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleSynonyms = NM.empty + , moduleDataTypes = types + , moduleValues = NM.empty + , moduleTemplates = NM.empty + , moduleExceptions = NM.empty + } + where + modName = mkModName ["DA", "Date", "Types"] + types = NM.fromList + [ DefDataType Nothing (mkTypeCon ["DayOfWeek"]) (IsSerializable True) [] $ + DataEnum $ map mkVariantCon + [ "Monday" + , "Tuesday" + , "Wednesday" + , "Thursday" + , "Friday" + , "Saturday" + , "Sunday" + ] + , DefDataType Nothing (mkTypeCon ["Month"]) (IsSerializable True) [] $ + DataEnum $ map mkVariantCon + [ "Jan" + , "Feb" + , "Mar" + , "Apr" + , "May" + , "Jun" + , "Jul" + , "Aug" + , "Sep" + , "Oct" + , "Nov" + , "Dec" + ] + ] + +daSemigroupTypes :: Package +daSemigroupTypes = package version1_6 $ NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleSynonyms = NM.empty + , moduleDataTypes = types + , moduleValues = values + , moduleTemplates = NM.empty + , moduleExceptions = NM.empty + } + where + modName = mkModName ["DA", "Semigroup", "Types"] + unpackField = mkField "unpack" + minTyCon = mkTypeCon ["Min"] + maxTyCon = mkTypeCon ["Max"] + tyVar = mkTypeVar "a" + tyVars = [(tyVar, KStar)] + types = NM.fromList + [ DefDataType Nothing minTyCon (IsSerializable True) tyVars $ DataRecord [(unpackField, TVar tyVar)] + , DefDataType Nothing maxTyCon (IsSerializable True) tyVars $ DataRecord [(unpackField, TVar tyVar)] + ] + values = NM.fromList + [ mkWorkerDef modName minTyCon tyVars [(unpackField, TVar tyVar)] + , mkWorkerDef modName maxTyCon tyVars [(unpackField, TVar tyVar)] + ] + +daMonoidTypes :: Package +daMonoidTypes = package version1_6 $ NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleSynonyms = NM.empty + , moduleDataTypes = types + , moduleValues = values + , moduleTemplates = NM.empty + , moduleExceptions = NM.empty + } + where + modName = mkModName ["DA", "Monoid", "Types"] + unpackField = mkField "unpack" + allTyCon = mkTypeCon ["All"] + anyTyCon = mkTypeCon ["Any"] + endoTyCon = mkTypeCon ["Endo"] + sumTyCon = mkTypeCon ["Sum"] + productTyCon = mkTypeCon ["Product"] + tyVar = mkTypeVar "a" + tyVars = [(tyVar, KStar)] + getAllField = mkField "getAll" + getAnyField = mkField "getAny" + appEndoField = mkField "appEndo" + types = NM.fromList + [ DefDataType Nothing allTyCon (IsSerializable True) [] $ DataRecord [(getAllField, TBool)] + , DefDataType Nothing anyTyCon (IsSerializable True) [] $ DataRecord [(getAnyField, TBool)] + , DefDataType Nothing endoTyCon (IsSerializable False) tyVars $ DataRecord [(appEndoField, TVar tyVar :-> TVar tyVar)] + , DefDataType Nothing sumTyCon (IsSerializable True) tyVars $ DataRecord [(unpackField, TVar tyVar)] + , DefDataType Nothing productTyCon (IsSerializable True) tyVars $ DataRecord [(unpackField, TVar tyVar)] + ] + values = NM.fromList + [ mkSelectorDef modName allTyCon [] getAllField TBool + , mkSelectorDef modName anyTyCon [] getAnyField TBool + , mkSelectorDef modName endoTyCon tyVars appEndoField (TVar tyVar :-> TVar tyVar) + , mkWorkerDef modName allTyCon [] [(getAllField, TBool)] + , mkWorkerDef modName anyTyCon [] [(getAnyField, TBool)] + , mkWorkerDef modName endoTyCon tyVars [(appEndoField, TVar tyVar :-> TVar tyVar)] + , mkWorkerDef modName sumTyCon tyVars [(unpackField, TVar tyVar)] + , mkWorkerDef modName productTyCon tyVars [(unpackField, TVar tyVar)] + ] + +daValidationTypes :: PackageId -> Package +daValidationTypes nonEmptyPkgId = package version1_6 $ NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleSynonyms = NM.empty + , moduleDataTypes = types + , moduleValues = values + , moduleTemplates = NM.empty + , moduleExceptions = NM.empty + } + where + nonEmptyModName = mkModName ["DA", "NonEmpty", "Types"] + nonEmptyTCon = Qualified (PRImport nonEmptyPkgId) nonEmptyModName (mkTypeCon ["NonEmpty"]) + modName = mkModName ["DA", "Validation", "Types"] + validationTyCon = mkTypeCon ["Validation"] + errors = mkVariantCon "Errors" + success = mkVariantCon "Success" + errsTyVar = mkTypeVar "errs" + tyVar = mkTypeVar "a" + tyVars = [(errsTyVar, KStar), (tyVar, KStar)] + types = NM.fromList + [ DefDataType Nothing validationTyCon (IsSerializable True) tyVars $ DataVariant + [ (errors, TApp (TCon nonEmptyTCon) (TVar errsTyVar)) + , (success, TVar tyVar) + ] + ] + values = NM.fromList + [ mkVariantWorkerDef modName validationTyCon errors tyVars (TApp (TCon nonEmptyTCon) (TVar errsTyVar)) + , mkVariantWorkerDef modName validationTyCon success tyVars (TVar tyVar) + ] + +daLogicTypes :: Package +daLogicTypes = package version1_6 $ NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleSynonyms = NM.empty + , moduleDataTypes = types + , moduleValues = values + , moduleTemplates = NM.empty + , moduleExceptions = NM.empty + } + where + modName = mkModName ["DA", "Logic", "Types"] + formulaTyCon = mkTypeCon ["Formula"] + proposition = mkVariantCon "Proposition" + negation = mkVariantCon "Negation" + conjunction = mkVariantCon "Conjunction" + disjunction = mkVariantCon "Disjunction" + tyVar = mkTypeVar "a" + tyVars = [(tyVar, KStar)] + formulaTy = TApp (TCon $ Qualified PRSelf modName formulaTyCon) (TVar tyVar) + types = NM.fromList + [ DefDataType Nothing formulaTyCon (IsSerializable True) tyVars $ DataVariant + [ (proposition, TVar tyVar) + , (negation, formulaTy) + , (conjunction, TList formulaTy) + , (disjunction, TList formulaTy) + ] + ] + values = NM.fromList + [ mkVariantWorkerDef modName formulaTyCon proposition tyVars (TVar tyVar) + , mkVariantWorkerDef modName formulaTyCon negation tyVars formulaTy + , mkVariantWorkerDef modName formulaTyCon conjunction tyVars (TList formulaTy) + , mkVariantWorkerDef modName formulaTyCon disjunction tyVars (TList formulaTy) + ] + +daInternalDown :: Package +daInternalDown = package version1_6 $ NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleSynonyms = NM.empty + , moduleDataTypes = types + , moduleValues = values + , moduleTemplates = NM.empty + , moduleExceptions = NM.empty + } + where + modName = mkModName ["DA", "Internal", "Down"] + downTyCon = mkTypeCon ["Down"] + tyVar = mkTypeVar "a" + tyVars = [(tyVar, KStar)] + unpackField = mkField "unpack" + types = NM.fromList + [ DefDataType Nothing downTyCon (IsSerializable True) tyVars $ DataRecord [(unpackField, TVar tyVar)] + ] + values = NM.fromList + [ mkWorkerDef modName downTyCon tyVars [(unpackField, TVar tyVar)] + ] + +daSetTypes :: Package +daSetTypes = Package + { packageLfVersion = version1_11 + , packageModules = NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleSynonyms = NM.empty + , moduleDataTypes = types + , moduleValues = values + , moduleTemplates = NM.empty + , moduleExceptions = NM.empty + } + , packageMetadata = Just PackageMetadata + { packageName = PackageName "daml-stdlib-DA-Set-Types" + , packageVersion = PackageVersion "1.0.0" + } + } + where + modName = mkModName ["DA", "Set", "Types"] + tyCon = mkTypeCon ["Set"] + tyVar = mkTypeVar "k" + tyVars = [(tyVar, KStar)] + mapField = mkField "map" + mapType = TGenMap (TVar tyVar) TUnit + types = NM.fromList + [ DefDataType Nothing tyCon (IsSerializable True) tyVars $ DataRecord [(mapField, mapType)] + ] + values = NM.fromList + [ mkWorkerDef modName tyCon tyVars [(mapField, mapType)] + ] + +daInternalErased :: Package +daInternalErased = package version1_6 $ NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleSynonyms = NM.empty + , moduleDataTypes = types + , moduleValues = NM.empty + , moduleTemplates = NM.empty + , moduleExceptions = NM.empty + } + where + modName = mkModName ["DA", "Internal", "Erased"] + erasedTyCon = mkTypeCon ["Erased"] + types = NM.fromList + [ DefDataType Nothing erasedTyCon (IsSerializable False) [] $ DataVariant [] + ] + +daInternalPromotedText :: Package +daInternalPromotedText = package version1_6 $ NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleSynonyms = NM.empty + , moduleDataTypes = types + , moduleValues = NM.empty + , moduleTemplates = NM.empty + , moduleExceptions = NM.empty + } + where + modName = mkModName ["DA", "Internal", "PromotedText"] + ptextTyCon = mkTypeCon ["PromotedText"] + types = NM.fromList + [ DefDataType Nothing ptextTyCon (IsSerializable False) [(mkTypeVar "t", KStar)] $ DataVariant [] + ] + +daExceptionGeneralError :: Package +daExceptionGeneralError = builtinExceptionPackage "GeneralError" + +daExceptionArithmeticError :: Package +daExceptionArithmeticError = builtinExceptionPackage "ArithmeticError" + +daExceptionContractError :: Package +daExceptionContractError = builtinExceptionPackage "ContractError" + +builtinExceptionPackage :: T.Text -> Package +builtinExceptionPackage name = Package + { packageLfVersion = featureMinVersion featureExceptions + , packageModules = NM.singleton Module + { moduleName = modName + , moduleSource = Nothing + , moduleFeatureFlags = daml12FeatureFlags + , moduleSynonyms = NM.empty + , moduleDataTypes = types + , moduleValues = values + , moduleTemplates = NM.empty + , moduleExceptions = exceptions + } + , packageMetadata = Just PackageMetadata + { packageName = PackageName ("daml-prim-DA-Exception-" <> name) + , packageVersion = PackageVersion "1.0.0" + } + } + where + modName = mkModName ["DA", "Exception", name] + tyCon = mkTypeCon [name] + tyVars = [] + fieldName = mkField "message" + fieldType = TText + fields = [(fieldName, fieldType)] + types = NM.singleton (DefDataType Nothing tyCon (IsSerializable True) tyVars (DataRecord fields)) + values = NM.singleton (mkWorkerDef modName tyCon tyVars fields) + var = mkVar "x" + qualify = Qualified PRSelf modName + exceptions = NM.singleton DefException + { exnLocation = Nothing + , exnName = tyCon + , exnMessage = + ETmLam (var, TCon (qualify tyCon)) + (ERecProj (TypeConApp (qualify tyCon) []) fieldName (EVar var)) + } + + +mkSelectorDef :: ModuleName -> TypeConName -> [(TypeVarName, Kind)] -> FieldName -> Type -> DefValue +mkSelectorDef modName tyCon tyVars fieldName fieldTy = + DefValue Nothing (mkSelectorName (T.intercalate "." $ unTypeConName tyCon) (unFieldName fieldName), mkTForalls tyVars (ty :-> fieldTy)) (HasNoPartyLiterals True) (IsTest False) $ + mkETyLams tyVars $ mkETmLams [(mkVar "x", ty)] $ ERecProj tyConApp fieldName (EVar $ mkVar "x") + where tyConApp = TypeConApp (Qualified PRSelf modName tyCon) (map (TVar . fst) tyVars) + ty = typeConAppToType tyConApp + +mkWorkerDef :: ModuleName -> TypeConName -> [(TypeVarName, Kind)] -> [(FieldName, Type)] -> DefValue +mkWorkerDef modName tyCon tyVars fields = + DefValue Nothing (mkWorkerName (T.intercalate "." $ unTypeConName tyCon), mkTForalls tyVars $ mkTFuns (map snd fields) ty) (HasNoPartyLiterals True) (IsTest False) $ + mkETyLams tyVars $ mkETmLams (map (first (mkVar . unFieldName)) fields) $ ERecCon tyConApp (map (\(field, _) -> (field, EVar $ mkVar $ unFieldName field)) fields) + where tyConApp = TypeConApp (Qualified PRSelf modName tyCon) (map (TVar . fst) tyVars) + ty = typeConAppToType tyConApp + +mkVariantWorkerDef :: ModuleName -> TypeConName -> VariantConName -> [(TypeVarName, Kind)] -> Type -> DefValue +mkVariantWorkerDef modName tyCon constr tyVars argTy = + DefValue Nothing (mkWorkerName (unVariantConName constr), mkTForalls tyVars $ argTy :-> ty) (HasNoPartyLiterals True) (IsTest False) $ + mkETyLams tyVars $ mkETmLams [(mkVar "x", argTy)] $ EVariantCon tyConApp constr (EVar $ mkVar "x") + where tyConApp = TypeConApp (Qualified PRSelf modName tyCon) (map (TVar . fst) tyVars) + ty = typeConAppToType tyConApp diff --git a/compiler/damlc/stable-packages/src/GenerateStablePackage.hs b/compiler/damlc/stable-packages/src/GenerateStablePackage.hs index 3fdc8d834aed..0ad279bba13e 100644 --- a/compiler/damlc/stable-packages/src/GenerateStablePackage.hs +++ b/compiler/damlc/stable-packages/src/GenerateStablePackage.hs @@ -1,17 +1,18 @@ -- Copyright (c) 2021 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -module GenerateStablePackage (main) where +module GenerateStablePackage + ( main + ) where -import Data.Bifunctor import qualified Data.ByteString as BS -import qualified Data.NameMap as NM +import qualified Data.Map.Strict as MS import Options.Applicative import qualified Data.Text as T import DA.Daml.LF.Ast import DA.Daml.LF.Proto3.Archive -import DA.Daml.LFConversion.UtilLF +import DA.Daml.StablePackages data Opts = Opts { optModule :: ModuleName @@ -48,609 +49,13 @@ optParser = main :: IO () main = do - Opts{..} <- execParser (info optParser idm) - case optModule of - ModuleName ["GHC", "Types"] -> - writePackage ghcTypes optOutputPath - ModuleName ["GHC", "Prim"] -> - writePackage ghcPrim optOutputPath - ModuleName ["GHC", "Tuple"] -> - writePackage ghcTuple optOutputPath - ModuleName ["DA", "Types"] -> - writePackage daTypes optOutputPath - ModuleName ["DA", "Internal", "Template"] -> - writePackage daInternalTemplate optOutputPath - ModuleName ["DA", "Internal", "Any"] -> - writePackage daInternalAny optOutputPath - ModuleName ["DA", "Time", "Types"] -> - writePackage daTimeTypes optOutputPath - ModuleName ["DA", "NonEmpty", "Types"] -> - writePackage daNonEmptyTypes optOutputPath - ModuleName ["DA", "Date", "Types"] -> - writePackage daDateTypes optOutputPath - ModuleName ["DA", "Semigroup", "Types"] -> - writePackage daSemigroupTypes optOutputPath - ModuleName ["DA", "Monoid", "Types"] -> - writePackage daMonoidTypes optOutputPath - ModuleName ["DA", "Logic", "Types"] -> - writePackage daLogicTypes optOutputPath - ModuleName ["DA", "Validation", "Types"] -> - writePackage (daValidationTypes (encodePackageHash daNonEmptyTypes)) optOutputPath - ModuleName ["DA", "Internal", "Down"] -> - writePackage daInternalDown optOutputPath - ModuleName ["DA", "Internal", "Erased"] -> - writePackage daInternalErased optOutputPath - ModuleName ["DA", "Internal", "PromotedText"] -> - writePackage daInternalPromotedText optOutputPath - ModuleName ["DA", "Exception", "GeneralError"] -> - writePackage daExceptionGeneralError optOutputPath - ModuleName ["DA", "Exception", "ArithmeticError"] -> - writePackage daExceptionArithmeticError optOutputPath - ModuleName ["DA", "Exception", "ContractError"] -> - writePackage daExceptionContractError optOutputPath - ModuleName ["DA", "Set", "Types"] -> - writePackage daSetTypes optOutputPath - _ -> fail $ "Unknown module: " <> show optModule + Opts{..} <- execParser (info optParser idm) + case MS.lookup optModule stablePackageByModuleName of + Nothing -> + fail $ "Unknown module: " <> show optModule + Just pkg -> + writePackage pkg optOutputPath writePackage :: Package -> FilePath -> IO () writePackage pkg path = do BS.writeFile path $ encodeArchive pkg - -ghcTypes :: Package -ghcTypes = package version1_6 $ NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleSynonyms = NM.empty - , moduleDataTypes = NM.fromList [dataOrdering] - , moduleValues = NM.empty - , moduleTemplates = NM.empty - , moduleExceptions = NM.empty - } - where - modName = mkModName ["GHC", "Types"] - cons = ["LT", "EQ", "GT"] - dataOrdering = DefDataType - { dataLocation= Nothing - , dataTypeCon = mkTypeCon ["Ordering"] - , dataSerializable = IsSerializable True - , dataParams = [] - , dataCons = DataEnum $ map mkVariantCon cons - } - -ghcPrim :: Package -ghcPrim = package version1_6 $ NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleSynonyms = NM.empty - , moduleDataTypes = NM.fromList [dataVoid] - , moduleValues = NM.fromList [valVoid] - , moduleTemplates = NM.empty - , moduleExceptions = NM.empty - } - where - modName = mkModName ["GHC", "Prim"] - qual = Qualified PRSelf modName - conName = mkVariantCon "Void#" - dataVoid = DefDataType - { dataLocation= Nothing - , dataTypeCon = mkTypeCon ["Void#"] - , dataSerializable = IsSerializable False - , dataParams = [] - , dataCons = DataEnum [conName] - } - valVoid = DefValue - { dvalLocation = Nothing - , dvalBinder = (mkVal "void#", TCon (qual (dataTypeCon dataVoid))) - , dvalNoPartyLiterals= HasNoPartyLiterals True - , dvalIsTest = IsTest False - , dvalBody = EEnumCon (qual (dataTypeCon dataVoid)) conName - } - -package :: Version -> NM.NameMap Module -> Package -package ver mods - | ver > version1_7 = error "Packages with LF version >= 1.7 need to have package metadata" - | otherwise = Package ver mods Nothing - -daTypes :: Package -daTypes = package version1_6 $ NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleTemplates = NM.empty - , moduleSynonyms = NM.empty - , moduleDataTypes = types - , moduleValues = values - , moduleExceptions = NM.empty - } - 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 :: Package -ghcTuple = package version1_6 $ NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleTemplates = NM.empty - , moduleSynonyms = NM.empty - , moduleDataTypes = types - , moduleValues = values - , moduleExceptions = NM.empty - } - where - modName = mkModName ["GHC", "Tuple"] - tyVar = mkTypeVar "a" - tyVars = [(tyVar, KStar)] - unitTyCon = mkTypeCon ["Unit"] - types = NM.fromList - [ DefDataType Nothing unitTyCon (IsSerializable True) tyVars $ - DataRecord [(mkIndexedField 1, TVar tyVar)] - ] - values = NM.fromList - [ mkWorkerDef modName unitTyCon tyVars [(mkIndexedField 1, TVar tyVar)] - ] - -daInternalTemplate :: Package -daInternalTemplate = package version1_6 $ NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleSynonyms = NM.empty - , moduleDataTypes = types - , moduleValues = NM.fromList [] - , moduleTemplates = NM.empty - , moduleExceptions = NM.empty - } - where - modName = mkModName ["DA", "Internal", "Template"] - types = NM.fromList - [ DefDataType Nothing (mkTypeCon ["Archive"]) (IsSerializable True) [] $ - DataRecord [] - ] - -daInternalAny :: Package -daInternalAny = package version1_7 $ NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleSynonyms = NM.empty - , moduleDataTypes = types - , moduleValues = NM.empty - , moduleTemplates = NM.empty - , moduleExceptions = NM.empty - } - where - modName = mkModName ["DA", "Internal", "Any"] - types = NM.fromList - [ DefDataType Nothing (mkTypeCon ["AnyTemplate"]) (IsSerializable False) [] $ - DataRecord [(mkField "getAnyTemplate", TAny)] - , DefDataType Nothing (mkTypeCon ["TemplateTypeRep"]) (IsSerializable False) [] $ - DataRecord [(mkField "getTemplateTypeRep", TTypeRep)] - , DefDataType Nothing (mkTypeCon ["AnyChoice"]) (IsSerializable False) [] $ - DataRecord [(mkField "getAnyChoice", TAny), (mkField "getAnyChoiceTemplateTypeRep", TCon (Qualified PRSelf modName (mkTypeCon ["TemplateTypeRep"])))] - , DefDataType Nothing (mkTypeCon ["AnyContractKey"]) (IsSerializable False) [] $ - DataRecord [(mkField "getAnyContractKey", TAny), (mkField "getAnyContractKeyTemplateTypeRep", TCon (Qualified PRSelf modName (mkTypeCon ["TemplateTypeRep"])))] - ] - -daTimeTypes :: Package -daTimeTypes = package version1_6 $ NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleSynonyms = NM.empty - , moduleDataTypes = types - , moduleValues = values - , moduleTemplates = NM.empty - , moduleExceptions = NM.empty - } - where - modName = mkModName ["DA", "Time", "Types"] - relTimeTyCon = mkTypeCon ["RelTime"] - types = NM.fromList - [ DefDataType Nothing relTimeTyCon (IsSerializable True) [] $ - DataRecord [(usField, TInt64)] - ] - values = NM.fromList - [ mkSelectorDef modName relTimeTyCon [] usField TInt64 - , mkWorkerDef modName relTimeTyCon [] [(usField, TInt64)] - ] - usField = mkField "microseconds" - -daNonEmptyTypes :: Package -daNonEmptyTypes = package version1_6 $ NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleSynonyms = NM.empty - , moduleDataTypes = types - , moduleValues = values - , moduleTemplates = NM.empty - , moduleExceptions = NM.empty - } - where - modName = mkModName ["DA", "NonEmpty", "Types"] - hdField = mkField "hd" - tlField = mkField "tl" - tyVar = mkTypeVar "a" - tyVars = [(tyVar, KStar)] - nonEmptyTyCon = mkTypeCon ["NonEmpty"] - types = NM.fromList - [ DefDataType Nothing nonEmptyTyCon (IsSerializable True) tyVars $ - DataRecord [(hdField, TVar tyVar), (tlField, TList (TVar tyVar))] - ] - values = NM.fromList - [ mkWorkerDef modName nonEmptyTyCon tyVars [(hdField, TVar tyVar), (tlField, TList (TVar tyVar))] - , mkSelectorDef modName nonEmptyTyCon tyVars hdField (TVar tyVar) - , mkSelectorDef modName nonEmptyTyCon tyVars tlField (TList (TVar tyVar)) - ] - -daDateTypes :: Package -daDateTypes = package version1_6 $ NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleSynonyms = NM.empty - , moduleDataTypes = types - , moduleValues = NM.empty - , moduleTemplates = NM.empty - , moduleExceptions = NM.empty - } - where - modName = mkModName ["DA", "Date", "Types"] - types = NM.fromList - [ DefDataType Nothing (mkTypeCon ["DayOfWeek"]) (IsSerializable True) [] $ - DataEnum $ map mkVariantCon - [ "Monday" - , "Tuesday" - , "Wednesday" - , "Thursday" - , "Friday" - , "Saturday" - , "Sunday" - ] - , DefDataType Nothing (mkTypeCon ["Month"]) (IsSerializable True) [] $ - DataEnum $ map mkVariantCon - [ "Jan" - , "Feb" - , "Mar" - , "Apr" - , "May" - , "Jun" - , "Jul" - , "Aug" - , "Sep" - , "Oct" - , "Nov" - , "Dec" - ] - ] - -daSemigroupTypes :: Package -daSemigroupTypes = package version1_6 $ NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleSynonyms = NM.empty - , moduleDataTypes = types - , moduleValues = values - , moduleTemplates = NM.empty - , moduleExceptions = NM.empty - } - where - modName = mkModName ["DA", "Semigroup", "Types"] - unpackField = mkField "unpack" - minTyCon = mkTypeCon ["Min"] - maxTyCon = mkTypeCon ["Max"] - tyVar = mkTypeVar "a" - tyVars = [(tyVar, KStar)] - types = NM.fromList - [ DefDataType Nothing minTyCon (IsSerializable True) tyVars $ DataRecord [(unpackField, TVar tyVar)] - , DefDataType Nothing maxTyCon (IsSerializable True) tyVars $ DataRecord [(unpackField, TVar tyVar)] - ] - values = NM.fromList - [ mkWorkerDef modName minTyCon tyVars [(unpackField, TVar tyVar)] - , mkWorkerDef modName maxTyCon tyVars [(unpackField, TVar tyVar)] - ] - -daMonoidTypes :: Package -daMonoidTypes = package version1_6 $ NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleSynonyms = NM.empty - , moduleDataTypes = types - , moduleValues = values - , moduleTemplates = NM.empty - , moduleExceptions = NM.empty - } - where - modName = mkModName ["DA", "Monoid", "Types"] - unpackField = mkField "unpack" - allTyCon = mkTypeCon ["All"] - anyTyCon = mkTypeCon ["Any"] - endoTyCon = mkTypeCon ["Endo"] - sumTyCon = mkTypeCon ["Sum"] - productTyCon = mkTypeCon ["Product"] - tyVar = mkTypeVar "a" - tyVars = [(tyVar, KStar)] - getAllField = mkField "getAll" - getAnyField = mkField "getAny" - appEndoField = mkField "appEndo" - types = NM.fromList - [ DefDataType Nothing allTyCon (IsSerializable True) [] $ DataRecord [(getAllField, TBool)] - , DefDataType Nothing anyTyCon (IsSerializable True) [] $ DataRecord [(getAnyField, TBool)] - , DefDataType Nothing endoTyCon (IsSerializable False) tyVars $ DataRecord [(appEndoField, TVar tyVar :-> TVar tyVar)] - , DefDataType Nothing sumTyCon (IsSerializable True) tyVars $ DataRecord [(unpackField, TVar tyVar)] - , DefDataType Nothing productTyCon (IsSerializable True) tyVars $ DataRecord [(unpackField, TVar tyVar)] - ] - values = NM.fromList - [ mkSelectorDef modName allTyCon [] getAllField TBool - , mkSelectorDef modName anyTyCon [] getAnyField TBool - , mkSelectorDef modName endoTyCon tyVars appEndoField (TVar tyVar :-> TVar tyVar) - , mkWorkerDef modName allTyCon [] [(getAllField, TBool)] - , mkWorkerDef modName anyTyCon [] [(getAnyField, TBool)] - , mkWorkerDef modName endoTyCon tyVars [(appEndoField, TVar tyVar :-> TVar tyVar)] - , mkWorkerDef modName sumTyCon tyVars [(unpackField, TVar tyVar)] - , mkWorkerDef modName productTyCon tyVars [(unpackField, TVar tyVar)] - ] - -daValidationTypes :: PackageId -> Package -daValidationTypes nonEmptyPkgId = package version1_6 $ NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleSynonyms = NM.empty - , moduleDataTypes = types - , moduleValues = values - , moduleTemplates = NM.empty - , moduleExceptions = NM.empty - } - where - nonEmptyModName = mkModName ["DA", "NonEmpty", "Types"] - nonEmptyTCon = Qualified (PRImport nonEmptyPkgId) nonEmptyModName (mkTypeCon ["NonEmpty"]) - modName = mkModName ["DA", "Validation", "Types"] - validationTyCon = mkTypeCon ["Validation"] - errors = mkVariantCon "Errors" - success = mkVariantCon "Success" - errsTyVar = mkTypeVar "errs" - tyVar = mkTypeVar "a" - tyVars = [(errsTyVar, KStar), (tyVar, KStar)] - types = NM.fromList - [ DefDataType Nothing validationTyCon (IsSerializable True) tyVars $ DataVariant - [ (errors, TApp (TCon nonEmptyTCon) (TVar errsTyVar)) - , (success, TVar tyVar) - ] - ] - values = NM.fromList - [ mkVariantWorkerDef modName validationTyCon errors tyVars (TApp (TCon nonEmptyTCon) (TVar errsTyVar)) - , mkVariantWorkerDef modName validationTyCon success tyVars (TVar tyVar) - ] - -daLogicTypes :: Package -daLogicTypes = package version1_6 $ NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleSynonyms = NM.empty - , moduleDataTypes = types - , moduleValues = values - , moduleTemplates = NM.empty - , moduleExceptions = NM.empty - } - where - modName = mkModName ["DA", "Logic", "Types"] - formulaTyCon = mkTypeCon ["Formula"] - proposition = mkVariantCon "Proposition" - negation = mkVariantCon "Negation" - conjunction = mkVariantCon "Conjunction" - disjunction = mkVariantCon "Disjunction" - tyVar = mkTypeVar "a" - tyVars = [(tyVar, KStar)] - formulaTy = TApp (TCon $ Qualified PRSelf modName formulaTyCon) (TVar tyVar) - types = NM.fromList - [ DefDataType Nothing formulaTyCon (IsSerializable True) tyVars $ DataVariant - [ (proposition, TVar tyVar) - , (negation, formulaTy) - , (conjunction, TList formulaTy) - , (disjunction, TList formulaTy) - ] - ] - values = NM.fromList - [ mkVariantWorkerDef modName formulaTyCon proposition tyVars (TVar tyVar) - , mkVariantWorkerDef modName formulaTyCon negation tyVars formulaTy - , mkVariantWorkerDef modName formulaTyCon conjunction tyVars (TList formulaTy) - , mkVariantWorkerDef modName formulaTyCon disjunction tyVars (TList formulaTy) - ] - -daInternalDown :: Package -daInternalDown = package version1_6 $ NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleSynonyms = NM.empty - , moduleDataTypes = types - , moduleValues = values - , moduleTemplates = NM.empty - , moduleExceptions = NM.empty - } - where - modName = mkModName ["DA", "Internal", "Down"] - downTyCon = mkTypeCon ["Down"] - tyVar = mkTypeVar "a" - tyVars = [(tyVar, KStar)] - unpackField = mkField "unpack" - types = NM.fromList - [ DefDataType Nothing downTyCon (IsSerializable True) tyVars $ DataRecord [(unpackField, TVar tyVar)] - ] - values = NM.fromList - [ mkWorkerDef modName downTyCon tyVars [(unpackField, TVar tyVar)] - ] - -daSetTypes :: Package -daSetTypes = Package - { packageLfVersion = version1_11 - , packageModules = NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleSynonyms = NM.empty - , moduleDataTypes = types - , moduleValues = values - , moduleTemplates = NM.empty - , moduleExceptions = NM.empty - } - , packageMetadata = Just PackageMetadata - { packageName = PackageName "daml-stdlib-DA-Set-Types" - , packageVersion = PackageVersion "1.0.0" - } - } - where - modName = mkModName ["DA", "Set", "Types"] - tyCon = mkTypeCon ["Set"] - tyVar = mkTypeVar "k" - tyVars = [(tyVar, KStar)] - mapField = mkField "map" - mapType = TGenMap (TVar tyVar) TUnit - types = NM.fromList - [ DefDataType Nothing tyCon (IsSerializable True) tyVars $ DataRecord [(mapField, mapType)] - ] - values = NM.fromList - [ mkWorkerDef modName tyCon tyVars [(mapField, mapType)] - ] - -daInternalErased :: Package -daInternalErased = package version1_6 $ NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleSynonyms = NM.empty - , moduleDataTypes = types - , moduleValues = NM.empty - , moduleTemplates = NM.empty - , moduleExceptions = NM.empty - } - where - modName = mkModName ["DA", "Internal", "Erased"] - erasedTyCon = mkTypeCon ["Erased"] - types = NM.fromList - [ DefDataType Nothing erasedTyCon (IsSerializable False) [] $ DataVariant [] - ] - -daInternalPromotedText :: Package -daInternalPromotedText = package version1_6 $ NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleSynonyms = NM.empty - , moduleDataTypes = types - , moduleValues = NM.empty - , moduleTemplates = NM.empty - , moduleExceptions = NM.empty - } - where - modName = mkModName ["DA", "Internal", "PromotedText"] - ptextTyCon = mkTypeCon ["PromotedText"] - types = NM.fromList - [ DefDataType Nothing ptextTyCon (IsSerializable False) [(mkTypeVar "t", KStar)] $ DataVariant [] - ] - -daExceptionGeneralError :: Package -daExceptionGeneralError = builtinExceptionPackage "GeneralError" - -daExceptionArithmeticError :: Package -daExceptionArithmeticError = builtinExceptionPackage "ArithmeticError" - -daExceptionContractError :: Package -daExceptionContractError = builtinExceptionPackage "ContractError" - -builtinExceptionPackage :: T.Text -> Package -builtinExceptionPackage name = Package - { packageLfVersion = featureMinVersion featureExceptions - , packageModules = NM.singleton Module - { moduleName = modName - , moduleSource = Nothing - , moduleFeatureFlags = daml12FeatureFlags - , moduleSynonyms = NM.empty - , moduleDataTypes = types - , moduleValues = values - , moduleTemplates = NM.empty - , moduleExceptions = exceptions - } - , packageMetadata = Just PackageMetadata - { packageName = PackageName ("daml-prim-DA-Exception-" <> name) - , packageVersion = PackageVersion "1.0.0" - } - } - where - modName = mkModName ["DA", "Exception", name] - tyCon = mkTypeCon [name] - tyVars = [] - fieldName = mkField "message" - fieldType = TText - fields = [(fieldName, fieldType)] - types = NM.singleton (DefDataType Nothing tyCon (IsSerializable True) tyVars (DataRecord fields)) - values = NM.singleton (mkWorkerDef modName tyCon tyVars fields) - var = mkVar "x" - qualify = Qualified PRSelf modName - exceptions = NM.singleton DefException - { exnLocation = Nothing - , exnName = tyCon - , exnMessage = - ETmLam (var, TCon (qualify tyCon)) - (ERecProj (TypeConApp (qualify tyCon) []) fieldName (EVar var)) - } - - -mkSelectorDef :: ModuleName -> TypeConName -> [(TypeVarName, Kind)] -> FieldName -> Type -> DefValue -mkSelectorDef modName tyCon tyVars fieldName fieldTy = - DefValue Nothing (mkSelectorName (T.intercalate "." $ unTypeConName tyCon) (unFieldName fieldName), mkTForalls tyVars (ty :-> fieldTy)) (HasNoPartyLiterals True) (IsTest False) $ - mkETyLams tyVars $ mkETmLams [(mkVar "x", ty)] $ ERecProj tyConApp fieldName (EVar $ mkVar "x") - where tyConApp = TypeConApp (Qualified PRSelf modName tyCon) (map (TVar . fst) tyVars) - ty = typeConAppToType tyConApp - -mkWorkerDef :: ModuleName -> TypeConName -> [(TypeVarName, Kind)] -> [(FieldName, Type)] -> DefValue -mkWorkerDef modName tyCon tyVars fields = - DefValue Nothing (mkWorkerName (T.intercalate "." $ unTypeConName tyCon), mkTForalls tyVars $ mkTFuns (map snd fields) ty) (HasNoPartyLiterals True) (IsTest False) $ - mkETyLams tyVars $ mkETmLams (map (first (mkVar . unFieldName)) fields) $ ERecCon tyConApp (map (\(field, _) -> (field, EVar $ mkVar $ unFieldName field)) fields) - where tyConApp = TypeConApp (Qualified PRSelf modName tyCon) (map (TVar . fst) tyVars) - ty = typeConAppToType tyConApp - -mkVariantWorkerDef :: ModuleName -> TypeConName -> VariantConName -> [(TypeVarName, Kind)] -> Type -> DefValue -mkVariantWorkerDef modName tyCon constr tyVars argTy = - DefValue Nothing (mkWorkerName (unVariantConName constr), mkTForalls tyVars $ argTy :-> ty) (HasNoPartyLiterals True) (IsTest False) $ - mkETyLams tyVars $ mkETmLams [(mkVar "x", argTy)] $ EVariantCon tyConApp constr (EVar $ mkVar "x") - where tyConApp = TypeConApp (Qualified PRSelf modName tyCon) (map (TVar . fst) tyVars) - ty = typeConAppToType tyConApp diff --git a/compiler/damlc/tests/BUILD.bazel b/compiler/damlc/tests/BUILD.bazel index fa0abf368ffe..124f89d8fca8 100644 --- a/compiler/damlc/tests/BUILD.bazel +++ b/compiler/damlc/tests/BUILD.bazel @@ -469,6 +469,7 @@ da_haskell_test( "//compiler/daml-lf-ast", "//compiler/daml-lf-proto", "//compiler/daml-lf-reader", + "//compiler/damlc/stable-packages:stable-packages-lib", "//libs-haskell/bazel-runfiles", "//libs-haskell/da-hs-base", "//libs-haskell/test-utils", diff --git a/compiler/damlc/tests/src/DA/Test/DataDependencies.hs b/compiler/damlc/tests/src/DA/Test/DataDependencies.hs index fdcb8e399f00..dced4d05c0f7 100644 --- a/compiler/damlc/tests/src/DA/Test/DataDependencies.hs +++ b/compiler/damlc/tests/src/DA/Test/DataDependencies.hs @@ -8,6 +8,7 @@ import DA.Bazel.Runfiles import qualified DA.Daml.LF.Ast as LF import DA.Daml.LF.Reader (readDalfs, Dalfs(..)) import qualified DA.Daml.LF.Proto3.Archive as LFArchive +import DA.Daml.StablePackages (numStablePackagesForVersion) import DA.Test.Process import DA.Test.Util import qualified Data.ByteString.Lazy as BSL @@ -50,19 +51,6 @@ darPackageIds fp = do Right dalfPkgIds <- pure $ mapM (LFArchive.decodeArchivePackageId . BSL.toStrict) $ mainDalf : dalfDeps pure dalfPkgIds --- TODO https://github.com/digital-asset/daml/issues/8020 --- Update stable package count when shipping exceptions. -numStablePackages :: LF.Version -> Int -numStablePackages ver - | ver == LF.version1_6 = 15 - | ver == LF.version1_7 = 16 - | ver == LF.version1_8 = 16 - | ver == LF.version1_11 = 17 - | ver == LF.version1_12 = 17 - | ver == LF.version1_13 = 17 - | ver == LF.versionDev = 20 - | otherwise = error $ "numStablePackages: Unknown LF version: " <> show ver - -- | Sequential LF version pairs, with an additional (1.dev, 1.dev) pair at the end. sequentialVersionPairs :: [(LF.Version, LF.Version)] sequentialVersionPairs = @@ -111,7 +99,7 @@ tests Tools{damlc,repl,validate,davlDar,oldProjDar} = testGroup "Data Dependenci ] projaPkgIds <- darPackageIds (proja "proja.dar") -- daml-stdlib, daml-prim and proja - length projaPkgIds @?= numStablePackages depLfVer + 2 + 1 + length projaPkgIds @?= numStablePackagesForVersion depLfVer + 2 + 1 step "Build projb" createDirectoryIfMissing True (projb "src") @@ -148,10 +136,11 @@ tests Tools{damlc,repl,validate,davlDar,oldProjDar} = testGroup "Data Dependenci validate $ projb "projb.dar" projbPkgIds <- darPackageIds (projb "projb.dar") -- daml-prim, daml-stdlib for targetLfVer, daml-prim, daml-stdlib for depLfVer if targetLfVer /= depLfVer, proja and projb - length projbPkgIds @?= numStablePackages - targetLfVer + 2 + (if targetLfVer /= depLfVer then 2 else 0) + 1 + 1 + length projbPkgIds @?= numStablePackagesForVersion targetLfVer + + 2 + (if targetLfVer /= depLfVer then 2 else 0) + 1 + 1 length (filter (`notElem` projaPkgIds) projbPkgIds) @?= - (numStablePackages targetLfVer - numStablePackages depLfVer) + -- new stable packages + ( numStablePackagesForVersion targetLfVer + - numStablePackagesForVersion depLfVer ) + -- new stable packages 1 + -- projb (if targetLfVer /= depLfVer then 2 else 0) -- different daml-stdlib/daml-prim | (depLfVer, targetLfVer) <- sequentialVersionPairs