mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-20 01:07:18 +03:00
language: cross sdk dalf/dar imports (#3358)
* language: cross sdk dalf/dar imports The final piece for cross sdk imports. With this PR we can import the data types of packages and dalfs that were created with different sdks. This is done by generating interface files from dalfs and an 'instances' package that contains the template instance definitions of template data types. The instances itself are defined via the `external` keyword, which is inlined to proper daml-lf instance definitions given in the respective dalf package. We test that cross sdk imports work by importing the `simple-dalf` in the daml-assistant integation tests and running a scenario.
This commit is contained in:
Robin Krom
GitHub
parent
8a7c6cd94d
commit
6943165c84
1
BUILD
1
BUILD
@ -231,6 +231,7 @@ da_haskell_repl(
|
||||
visibility = ["//visibility:public"],
|
||||
deps = [
|
||||
":damlc",
|
||||
"//compiler/damlc/tests:generate-simple-dalf",
|
||||
"//daml-assistant:daml",
|
||||
"//daml-assistant/daml-helper",
|
||||
"//daml-assistant/integration-tests",
|
||||
|
||||
@ -8,6 +8,7 @@ da_haskell_library(
|
||||
srcs = glob(["src/**/*.hs"]),
|
||||
hackage_deps = [
|
||||
"base",
|
||||
"bytestring",
|
||||
"containers",
|
||||
"deepseq",
|
||||
"Decimal",
|
||||
|
||||
@ -5,6 +5,7 @@
|
||||
|
||||
module DA.Daml.LF.Ast.World(
|
||||
World,
|
||||
DalfPackage(..),
|
||||
getWorldSelf,
|
||||
initWorld,
|
||||
initWorldSelf,
|
||||
@ -23,6 +24,7 @@ import DA.Pretty
|
||||
|
||||
import Control.DeepSeq
|
||||
import Control.Lens
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import Data.List
|
||||
import qualified Data.NameMap as NM
|
||||
@ -53,6 +55,14 @@ data ExternalPackage = ExternalPackage PackageId Package
|
||||
|
||||
instance NFData ExternalPackage
|
||||
|
||||
data DalfPackage = DalfPackage
|
||||
{ dalfPackageId :: PackageId
|
||||
, dalfPackagePkg :: ExternalPackage
|
||||
, dalfPackageBytes :: BS.ByteString
|
||||
} deriving (Show, Eq, Generic)
|
||||
|
||||
instance NFData DalfPackage
|
||||
|
||||
-- | Rewrite all `PRSelf` references to `PRImport` references.
|
||||
rewriteSelfReferences :: PackageId -> Package -> ExternalPackage
|
||||
rewriteSelfReferences pkgId = ExternalPackage pkgId . rewrite
|
||||
|
||||
@ -125,7 +125,7 @@ buildDar service pkgConf@PackageConfigFields {..} ifDir dalfInput = do
|
||||
-- get all dalf dependencies.
|
||||
dalfDependencies0 <- getDalfDependencies files
|
||||
let dalfDependencies =
|
||||
[ (T.pack $ unitIdString unitId, dalfPackageBytes pkg)
|
||||
[ (T.pack $ unitIdString unitId, LF.dalfPackageBytes pkg)
|
||||
| (unitId, pkg) <- Map.toList dalfDependencies0
|
||||
]
|
||||
let dataFiles = [mkConfFile pkgConf pkgModuleNames (T.unpack pkgId)]
|
||||
|
||||
@ -7,6 +7,7 @@ module DA.Daml.Compiler.Upgrade
|
||||
, generateTemplateInstance
|
||||
, generateSrcFromLf
|
||||
, generateSrcPkgFromLf
|
||||
, generateTemplateInstancesPkgFromLf
|
||||
, generateGenInstancesPkgFromLf
|
||||
, Env(..)
|
||||
, DiffSdkVers(..)
|
||||
@ -85,6 +86,68 @@ upgradeTemplates n =
|
||||
, " convert B." <> n <> "{..} = A." <> n <> " {..}"
|
||||
]
|
||||
|
||||
-- | Generate the source for a package containing template instances for all templates defined in a
|
||||
-- package. It _only_ contains the instance stubs. The correct implementation happens in the
|
||||
-- conversion to daml-lf, where `extenal` calls are inlined to daml-lf contained in the dalf of the
|
||||
-- external package.
|
||||
generateTemplateInstancesPkgFromLf ::
|
||||
(LF.PackageRef -> UnitId)
|
||||
-> LF.PackageId
|
||||
-> LF.Package
|
||||
-> [(NormalizedFilePath, String)]
|
||||
generateTemplateInstancesPkgFromLf getUnitId pkgId pkg =
|
||||
catMaybes
|
||||
[ generateTemplateInstanceModule
|
||||
Env
|
||||
{ envGetUnitId = getUnitId
|
||||
, envQualify = False
|
||||
, envMod = mod
|
||||
}
|
||||
pkgId
|
||||
| mod <- NM.toList $ LF.packageModules pkg
|
||||
]
|
||||
|
||||
-- | Generate a module containing template/generic instances for all the contained templates.
|
||||
-- Return Nothing if there are no instances, so no unnecessary modules are created.
|
||||
generateTemplateInstanceModule ::
|
||||
Env -> LF.PackageId -> Maybe (NormalizedFilePath, String)
|
||||
generateTemplateInstanceModule env externPkgId
|
||||
| not $ null instances =
|
||||
Just
|
||||
( toNormalizedFilePath modFilePath
|
||||
, unlines $
|
||||
header ++
|
||||
nubSort imports ++
|
||||
map (showSDocForUser fakeDynFlags alwaysQualify . ppr) instances)
|
||||
| otherwise = Nothing
|
||||
where
|
||||
instances = templInstances
|
||||
templInstances = templateInstances env externPkgId
|
||||
|
||||
mod = envMod env
|
||||
modFilePath = (joinPath $ splitOn "." modName) ++ "Instances" ++ ".daml"
|
||||
modName = T.unpack $ LF.moduleNameString $ LF.moduleName mod
|
||||
header =
|
||||
[ "{-# LANGUAGE NoDamlSyntax #-}"
|
||||
, "{-# LANGUAGE EmptyCase #-}"
|
||||
, "module " <> modName <> "Instances" <> " where"
|
||||
]
|
||||
imports =
|
||||
[ "import qualified " <> modName
|
||||
, "import qualified DA.Internal.Template"
|
||||
, "import qualified GHC.Types"
|
||||
]
|
||||
|
||||
templateInstances :: Env -> LF.PackageId -> [HsDecl GhcPs]
|
||||
templateInstances env externPkgId =
|
||||
[ generateTemplateInstance env dataTypeCon dataParams externPkgId
|
||||
| dataTypeCon <- NM.names $ LF.moduleTemplates mod
|
||||
, Just LF.DefDataType {..} <-
|
||||
[NM.lookup dataTypeCon (LF.moduleDataTypes mod)]
|
||||
]
|
||||
where
|
||||
mod = envMod env
|
||||
|
||||
generateGenInstancesPkgFromLf ::
|
||||
(LF.PackageRef -> UnitId)
|
||||
-> LF.PackageId
|
||||
@ -128,6 +191,7 @@ generateGenInstanceModule env externPkgId qual
|
||||
genInstances = snd genImportsAndInstances
|
||||
|
||||
mod = envMod env
|
||||
|
||||
modFilePath = (joinPath $ splitOn "." modName) ++ qual ++ "GenInstances" ++ ".daml"
|
||||
modName = T.unpack $ LF.moduleNameString $ LF.moduleName mod
|
||||
modNameQual = modName <> qual
|
||||
@ -296,7 +360,6 @@ generateTemplateInstance env typeCon typeParams externPkgId =
|
||||
, fun_tick = []
|
||||
}
|
||||
|
||||
|
||||
-- | Generate the full source for a daml-lf package.
|
||||
generateSrcPkgFromLf ::
|
||||
(LF.PackageRef -> UnitId)
|
||||
|
||||
@ -53,15 +53,8 @@ type instance RuleResult GeneratePackage = WhnfPackage
|
||||
type instance RuleResult GenerateRawPackage = WhnfPackage
|
||||
type instance RuleResult GeneratePackageDeps = WhnfPackage
|
||||
|
||||
data DalfPackage = DalfPackage
|
||||
{ dalfPackageId :: LF.PackageId
|
||||
, dalfPackagePkg :: LF.ExternalPackage
|
||||
, dalfPackageBytes :: BS.ByteString
|
||||
} deriving (Show, Eq, Generic)
|
||||
|
||||
instance NFData DalfPackage
|
||||
|
||||
type instance RuleResult GeneratePackageMap = Map UnitId DalfPackage
|
||||
type instance RuleResult GeneratePackageMap = Map UnitId LF.DalfPackage
|
||||
|
||||
-- | Runs all scenarios in the given file (but not scenarios in imports).
|
||||
type instance RuleResult RunScenarios = [(VirtualResource, Either SS.Error SS.ScenarioResult)]
|
||||
|
||||
@ -150,7 +150,7 @@ ideErrorPretty :: Pretty.Pretty e => NormalizedFilePath -> e -> FileDiagnostic
|
||||
ideErrorPretty fp = ideErrorText fp . T.pack . HughesPJPretty.prettyShow
|
||||
|
||||
|
||||
getDalfDependencies :: [NormalizedFilePath] -> MaybeT Action (Map.Map UnitId DalfPackage)
|
||||
getDalfDependencies :: [NormalizedFilePath] -> MaybeT Action (Map.Map UnitId LF.DalfPackage)
|
||||
getDalfDependencies files = do
|
||||
unitIds <- concatMap transitivePkgDeps <$> usesE GetDependencies files
|
||||
pkgMap <- useNoFileE GeneratePackageMap
|
||||
@ -181,9 +181,8 @@ generateRawDalfRule =
|
||||
setPriority priorityGenerateDalf
|
||||
-- Generate the map from package names to package hashes
|
||||
pkgMap <- useNoFile_ GeneratePackageMap
|
||||
let pkgMap0 = Map.map (LF.unPackageId . dalfPackageId) pkgMap
|
||||
-- GHC Core to DAML LF
|
||||
case convertModule lfVersion pkgMap0 file core of
|
||||
case convertModule lfVersion pkgMap file core of
|
||||
Left e -> return ([e], Nothing)
|
||||
Right v -> return ([], Just $ LF.simplifyModule v)
|
||||
|
||||
@ -194,7 +193,7 @@ generateDalfRule =
|
||||
lfVersion <- getDamlLfVersion
|
||||
WhnfPackage pkg <- use_ GeneratePackageDeps file
|
||||
pkgMap <- useNoFile_ GeneratePackageMap
|
||||
let pkgs = map dalfPackagePkg $ Map.elems pkgMap
|
||||
let pkgs = map LF.dalfPackagePkg $ Map.elems pkgMap
|
||||
let world = LF.initWorldSelf pkgs pkg
|
||||
rawDalf <- use_ GenerateRawDalf file
|
||||
setPriority priorityGenerateDalf
|
||||
@ -216,7 +215,7 @@ generateDocTestModuleRule =
|
||||
-- filename to match the package name.
|
||||
-- TODO (drsk): We might want to change this to load only needed packages in the future.
|
||||
generatePackageMap ::
|
||||
[FilePath] -> IO ([FileDiagnostic], Map.Map UnitId DalfPackage)
|
||||
[FilePath] -> IO ([FileDiagnostic], Map.Map UnitId LF.DalfPackage)
|
||||
generatePackageMap fps = do
|
||||
(diags, pkgs) <-
|
||||
fmap (partitionEithers . concat) $
|
||||
@ -230,7 +229,7 @@ generatePackageMap fps = do
|
||||
mapLeft (ideErrorPretty $ toNormalizedFilePath dalf) $
|
||||
Archive.decodeArchive dalfBS
|
||||
let unitId = stringToUnitId $ dropExtension $ takeFileName dalf
|
||||
Right (unitId, DalfPackage pkgId (LF.rewriteSelfReferences pkgId package) dalfBS)
|
||||
Right (unitId, LF.DalfPackage pkgId (LF.rewriteSelfReferences pkgId package) dalfBS)
|
||||
return (diags, Map.fromList pkgs)
|
||||
|
||||
generatePackageMapRule :: Options -> Rules ()
|
||||
@ -287,7 +286,7 @@ contextForFile file = do
|
||||
DamlEnv{..} <- getDamlServiceEnv
|
||||
pure SS.Context
|
||||
{ ctxModules = Map.fromList encodedModules
|
||||
, ctxPackages = [(dalfPackageId pkg, dalfPackageBytes pkg) | pkg <- Map.elems pkgMap]
|
||||
, ctxPackages = [(LF.dalfPackageId pkg, LF.dalfPackageBytes pkg) | pkg <- Map.elems pkgMap]
|
||||
, ctxDamlLfVersion = lfVersion
|
||||
, ctxSkipValidation = SS.SkipValidation (getSkipScenarioValidation envSkipScenarioValidation)
|
||||
}
|
||||
@ -296,7 +295,7 @@ worldForFile :: NormalizedFilePath -> Action LF.World
|
||||
worldForFile file = do
|
||||
WhnfPackage pkg <- use_ GeneratePackage file
|
||||
pkgMap <- useNoFile_ GeneratePackageMap
|
||||
let pkgs = map dalfPackagePkg $ Map.elems pkgMap
|
||||
let pkgs = map LF.dalfPackagePkg $ Map.elems pkgMap
|
||||
pure $ LF.initWorldSelf pkgs pkg
|
||||
|
||||
data ScenarioBackendException = ScenarioBackendException
|
||||
|
||||
@ -39,7 +39,7 @@ onCommand ide execParsms = case execParsms of
|
||||
WhnfPackage package <- runAction ide (use_ GeneratePackage mod)
|
||||
pkgMap <- runAction ide (useNoFile_ GeneratePackageMap)
|
||||
let modules = NM.toList $ LF.packageModules package
|
||||
let extpkgs = map dalfPackagePkg $ Map.elems pkgMap
|
||||
let extpkgs = map LF.dalfPackagePkg $ Map.elems pkgMap
|
||||
let wrld = LF.initWorldSelf extpkgs package
|
||||
let dots = T.pack $ Visual.dotFileGen modules wrld
|
||||
return $ Aeson.String dots
|
||||
|
||||
@ -139,7 +139,7 @@ unsupported typ x = conversionError errMsg
|
||||
typ ++ ".\n" ++
|
||||
prettyPrint x
|
||||
|
||||
unknown :: HasCallStack => GHC.UnitId -> MS.Map GHC.UnitId T.Text -> ConvertM e
|
||||
unknown :: HasCallStack => GHC.UnitId -> MS.Map GHC.UnitId DalfPackage -> ConvertM e
|
||||
unknown unitId pkgMap = conversionError errMsg
|
||||
where errMsg =
|
||||
"Unknown package: " ++ GHC.unitIdString unitId
|
||||
@ -156,7 +156,7 @@ data Env = Env
|
||||
,envGHCModuleName :: GHC.ModuleName
|
||||
,envModuleUnitId :: GHC.UnitId
|
||||
,envAliases :: MS.Map Var LF.Expr
|
||||
,envPkgMap :: MS.Map GHC.UnitId T.Text
|
||||
,envPkgMap :: MS.Map GHC.UnitId LF.DalfPackage
|
||||
,envLfVersion :: LF.Version
|
||||
,envTypeSynonyms :: [(GHC.Type, TyCon)]
|
||||
,envInstances :: [(TyCon, [GHC.Type])]
|
||||
@ -266,7 +266,12 @@ convertRationalNumericMono env scale num denom
|
||||
double = (fromInteger num / fromInteger denom) :: Double
|
||||
maxPower = fromIntegral numericMaxPrecision - scale
|
||||
|
||||
convertModule :: LF.Version -> MS.Map UnitId T.Text -> NormalizedFilePath -> CoreModule -> Either FileDiagnostic LF.Module
|
||||
convertModule
|
||||
:: LF.Version
|
||||
-> MS.Map UnitId DalfPackage
|
||||
-> NormalizedFilePath
|
||||
-> CoreModule
|
||||
-> Either FileDiagnostic LF.Module
|
||||
convertModule lfVersion pkgMap file x = runConvertM (ConversionEnv file Nothing) $ do
|
||||
definitions <- concatMapM (convertBind env) binds
|
||||
types <- concatMapM (convertTypeDef env) (eltsUFM (cm_types x))
|
||||
@ -439,7 +444,7 @@ convertGenericTemplate env x
|
||||
agreement <- convertExpr env (Var agreement)
|
||||
let create = ETmLam (this, polyType) $ EUpdate $ UBind (Binding (self, TContractId monoType) $ EUpdate $ UCreate monoTyCon $ wrapTpl $ EVar this) $ EUpdate $ UPure (TContractId polyType) $ unwrapCid $ EVar self
|
||||
let fetch = ETmLam (self, TContractId polyType) $ EUpdate $ UBind (Binding (this, monoType) $ EUpdate $ UFetch monoTyCon $ wrapCid $ EVar self) $ EUpdate $ UPure polyType $ unwrapTpl $ EVar this
|
||||
let anyTemplateTy = TypeConApp (Qualified stdlibRef (mkModName ["DA", "Internal", "LF"]) (mkTypeCon ["AnyTemplate"])) []
|
||||
let anyTemplateTy = anyTemplateTyFromStdlib stdlibRef
|
||||
let anyTemplateField = mkField "getAnyTemplate"
|
||||
let toAnyTemplate =
|
||||
if envLfVersion env `supports` featureAnyType
|
||||
@ -493,7 +498,6 @@ convertGenericTemplate env x
|
||||
arg = mkVar "arg"
|
||||
res = mkVar "res"
|
||||
rec = mkVar "rec"
|
||||
anyTpl = mkVar "anyTpl"
|
||||
convertGenericTemplate env x = unhandled "generic template" x
|
||||
|
||||
data Consuming = PreConsuming
|
||||
@ -751,6 +755,14 @@ convertExpr env0 e = do
|
||||
mkFieldProj i (name, _typ) = (mkField ("_" <> T.pack (show i)), ETupleProj name (EVar varV1))
|
||||
go env (VarIs "primitive") (LType (isStrLitTy -> Just y) : LType t : args)
|
||||
= fmap (, args) $ convertPrim (envLfVersion env) (unpackFS y) <$> convertType env t
|
||||
go env var@(Var f) (LType (isStrLitTy -> Just y) : LType t : args)
|
||||
| VarIs "external" <- var
|
||||
, Just m <- nameModule_maybe (getName f)
|
||||
, GHC.moduleNameString (GHC.moduleName m) == "GHC.Types"
|
||||
, GHC.moduleUnitId m == primUnitId
|
||||
= do
|
||||
stdlibRef <- packageNameToPkgRef env damlStdlib
|
||||
fmap (, args) $ convertExternal env stdlibRef (unpackFS y) <$> convertType env t
|
||||
go env (VarIs "getFieldPrim") (LType (isStrLitTy -> Just name) : LType record : LType _field : args) = do
|
||||
record' <- convertType env record
|
||||
withTmArg env (varV1, record') args $ \x args ->
|
||||
@ -1169,12 +1181,12 @@ convertLet env binder bound mkBody = do
|
||||
pure $ ELet (Binding binder bound) body
|
||||
|
||||
-- | Convert ghc package unit id's to LF package references.
|
||||
convertUnitId :: GHC.UnitId -> MS.Map GHC.UnitId T.Text -> UnitId -> ConvertM LF.PackageRef
|
||||
convertUnitId :: GHC.UnitId -> MS.Map GHC.UnitId DalfPackage -> UnitId -> ConvertM LF.PackageRef
|
||||
convertUnitId thisUnitId _pkgMap unitId | unitId == thisUnitId = pure LF.PRSelf
|
||||
convertUnitId _thisUnitId pkgMap unitId = case unitId of
|
||||
IndefiniteUnitId x -> unsupported "Indefinite unit id's" x
|
||||
DefiniteUnitId _ -> case MS.lookup unitId pkgMap of
|
||||
Just hash -> pure $ LF.PRImport $ PackageId hash
|
||||
Just DalfPackage{..} -> pure $ LF.PRImport dalfPackageId
|
||||
Nothing -> unknown unitId pkgMap
|
||||
|
||||
convertAlt :: Env -> LF.Type -> Alt Var -> ConvertM CaseAlternative
|
||||
@ -1528,6 +1540,176 @@ toCtor env con =
|
||||
| otherwise = ty
|
||||
in Ctor (getName con) (ctorLabels con) <$> mapM (fmap sanitize . convertType env) (thetas ++ tys)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- EXTERNAL PACKAGES
|
||||
|
||||
-- External instance methods
|
||||
convertExternal :: Env -> LF.PackageRef -> String -> LF.Type -> LF.Expr
|
||||
convertExternal env stdlibRef primId lfType
|
||||
| [pkgId, modStr, templName, method] <- splitOn ":" primId
|
||||
, Just LF.Template {..} <- lookup pkgId modStr templName =
|
||||
let pkgRef = PRImport $ PackageId $ T.pack pkgId
|
||||
mod = ModuleName $ map T.pack $ splitOn "." modStr
|
||||
qualify tconName =
|
||||
Qualified
|
||||
{ qualPackage = pkgRef
|
||||
, qualModule = mod
|
||||
, qualObject = tconName
|
||||
}
|
||||
templateDataType = TCon . qualify
|
||||
in case method of
|
||||
"signatory" ->
|
||||
ETmLam
|
||||
(tplParam, templateDataType tplTypeCon)
|
||||
tplSignatories
|
||||
"observer" ->
|
||||
ETmLam (tplParam, templateDataType tplTypeCon) tplObservers
|
||||
"agreement" ->
|
||||
ETmLam (tplParam, templateDataType tplTypeCon) tplAgreement
|
||||
"ensure" ->
|
||||
ETmLam
|
||||
(tplParam, templateDataType tplTypeCon)
|
||||
tplPrecondition
|
||||
"create" ->
|
||||
ETmLam
|
||||
(tplParam, templateDataType tplTypeCon)
|
||||
(EUpdate $ UCreate (qualify tplTypeCon) (EVar tplParam))
|
||||
"fetch" ->
|
||||
let coid = mkVar "$coid"
|
||||
in ETmLam
|
||||
( coid
|
||||
, TApp
|
||||
(TBuiltin BTContractId)
|
||||
(templateDataType tplTypeCon))
|
||||
(EUpdate $ UFetch (qualify tplTypeCon) (EVar coid))
|
||||
"archive" ->
|
||||
let archiveChoice = ChoiceName "Archive"
|
||||
in case NM.lookup archiveChoice tplChoices of
|
||||
Nothing ->
|
||||
EBuiltin BEError `ETyApp` lfType `ETmApp`
|
||||
EBuiltin
|
||||
(BEText $
|
||||
"convertExternal: archive is not implemented in external package")
|
||||
Just TemplateChoice {..} ->
|
||||
case chcArgBinder of
|
||||
(_, LF.TCon tcon) ->
|
||||
let coid = mkVar "$coid"
|
||||
archiveChoiceArg =
|
||||
LF.ERecCon
|
||||
{ LF.recTypeCon =
|
||||
LF.TypeConApp tcon []
|
||||
, LF.recFields = []
|
||||
}
|
||||
in ETmLam
|
||||
( coid
|
||||
, TApp
|
||||
(TBuiltin BTContractId)
|
||||
(templateDataType
|
||||
tplTypeCon))
|
||||
(EUpdate $
|
||||
UExercise
|
||||
(qualify tplTypeCon)
|
||||
archiveChoice
|
||||
(EVar coid)
|
||||
Nothing
|
||||
archiveChoiceArg)
|
||||
otherwise ->
|
||||
error
|
||||
"convertExternal: Archive choice exists but has the wrong type."
|
||||
"toAnyTemplate"
|
||||
| envLfVersion env `supports` featureAnyType ->
|
||||
ETmLam (tplParam, templateDataType tplTypeCon) $
|
||||
ERecCon
|
||||
anyTemplateTy
|
||||
[ ( anyTemplateField
|
||||
, EToAny
|
||||
(templateDataType tplTypeCon)
|
||||
(EVar tplParam))
|
||||
]
|
||||
"toAnyTemplate"
|
||||
| otherwise ->
|
||||
EBuiltin BEError `ETyApp` lfType `ETmApp`
|
||||
EBuiltin
|
||||
(BEText
|
||||
"toAnyTemplate is not supported in this DAML-LF version")
|
||||
"fromAnyTemplate"
|
||||
| envLfVersion env `supports` featureAnyType ->
|
||||
ETmLam (anyTpl, typeConAppToType anyTemplateTy) $
|
||||
ECase
|
||||
(EFromAny
|
||||
(templateDataType tplTypeCon)
|
||||
(ERecProj
|
||||
anyTemplateTy
|
||||
anyTemplateField
|
||||
(EVar anyTpl)))
|
||||
[ CaseAlternative CPNone $
|
||||
ENone $ templateDataType tplTypeCon
|
||||
, CaseAlternative (CPSome tplParam) $
|
||||
ESome (templateDataType tplTypeCon) $
|
||||
EVar tplParam
|
||||
]
|
||||
| otherwise ->
|
||||
EBuiltin BEError `ETyApp` lfType `ETmApp`
|
||||
EBuiltin
|
||||
(BEText
|
||||
"fromAnyTemplate is not supported in this DAML-LF version")
|
||||
"_templateTypeRep"
|
||||
| envLfVersion env `supports` featureTypeRep ->
|
||||
let resType =
|
||||
TypeConApp
|
||||
(Qualified
|
||||
stdlibRef
|
||||
(mkModName ["DA", "Internal", "LF"])
|
||||
(mkTypeCon ["TemplateTypeRep"]))
|
||||
[]
|
||||
resField = mkField "getTemplateTypeRep"
|
||||
in ERecCon
|
||||
resType
|
||||
[ ( resField
|
||||
, ETypeRep $ templateDataType tplTypeCon)
|
||||
]
|
||||
| otherwise ->
|
||||
EBuiltin BEError `ETyApp` lfType `ETmApp`
|
||||
EBuiltin
|
||||
(BEText
|
||||
"templateTypeRep is not supported in this DAML-LF version")
|
||||
other -> error "convertExternal: Unknown external method"
|
||||
| [pkgId, modStr, templName, method] <- splitOn ":" primId
|
||||
, Nothing <- lookup pkgId modStr templName =
|
||||
error $ "convertExternal: external template not found " <> primId
|
||||
| otherwise =
|
||||
error $ "convertExternal: malformed external template string" <> primId
|
||||
where
|
||||
anyTemplateTy = anyTemplateTyFromStdlib stdlibRef
|
||||
lookup pId modName temName = do
|
||||
mods <- MS.lookup pId pkgIdToModules
|
||||
mod <- NM.lookup (LF.ModuleName $ map T.pack $ splitOn "." modName) mods
|
||||
NM.lookup (LF.TypeConName [T.pack temName]) $ LF.moduleTemplates mod
|
||||
pkgIdToModules =
|
||||
MS.fromList
|
||||
[ (T.unpack $ LF.unPackageId dalfPackageId, LF.packageModules pkg)
|
||||
| (_uId, DalfPackage {..}) <- MS.toList $ envPkgMap env
|
||||
, let ExternalPackage _pid pkg = dalfPackagePkg
|
||||
]
|
||||
|
||||
-----------------------------
|
||||
-- AnyTemplate constant names
|
||||
|
||||
anyTemplateTyFromStdlib :: PackageRef -> TypeConApp
|
||||
anyTemplateTyFromStdlib stdlibRef =
|
||||
TypeConApp
|
||||
(Qualified
|
||||
stdlibRef
|
||||
(mkModName ["DA", "Internal", "LF"])
|
||||
(mkTypeCon ["AnyTemplate"]))
|
||||
[]
|
||||
|
||||
anyTemplateField :: FieldName
|
||||
anyTemplateField = mkField "getAnyTemplate"
|
||||
|
||||
anyTpl :: ExprVarName
|
||||
anyTpl = mkVar "anyTpl"
|
||||
|
||||
---------------------------------------------------------------------
|
||||
-- SIMPLE WRAPPERS
|
||||
|
||||
@ -1547,7 +1729,6 @@ convVar = mkVar . varPrettyPrint
|
||||
|
||||
convVarWithType :: Env -> Var -> ConvertM (ExprVarName, LF.Type)
|
||||
convVarWithType env v = (convVar v,) <$> convertType env (varType v)
|
||||
|
||||
convVal :: Var -> ExprValName
|
||||
convVal = mkVal . varPrettyPrint
|
||||
|
||||
|
||||
@ -221,8 +221,6 @@ convertPrim _ "BEToTextNumeric" (TNumeric n :-> TText) =
|
||||
ETyApp (EBuiltin BEToTextNumeric) n
|
||||
convertPrim _ "BENumericFromText" (TText :-> TOptional (TNumeric n)) =
|
||||
ETyApp (EBuiltin BENumericFromText) n
|
||||
|
||||
|
||||
convertPrim _ x ty = error $ "Unknown primitive " ++ show x ++ " at type " ++ renderPretty ty
|
||||
|
||||
-- | Some builtins are only supported in specific versions of DAML-LF.
|
||||
|
||||
@ -22,7 +22,7 @@ module GHC.Types (
|
||||
Text, Decimal,
|
||||
Opaque,
|
||||
ifThenElse,
|
||||
primitive, magic,
|
||||
primitive, magic, external,
|
||||
DamlEnum,
|
||||
|
||||
#ifdef DAML_NUMERIC
|
||||
@ -137,6 +137,10 @@ data TyCon = TyCon Word# Word# -- Fingerprint
|
||||
KindRep -- A representation of the type's kind
|
||||
|
||||
|
||||
-- | HIDE A DAML-LF call to an external package
|
||||
external : forall (f : Symbol) b. b
|
||||
external = external --deleted by the compiler
|
||||
|
||||
-- | HIDE A DAML-LF primitive
|
||||
primitive : forall (f : Symbol) b. b
|
||||
primitive = primitive -- deleted by the compiler
|
||||
|
||||
@ -563,18 +563,24 @@ createProjectPackageDb opts fps = do
|
||||
]
|
||||
let getUid = getUnitId unitId pkgMap
|
||||
let src = generateSrcPkgFromLf getUid pkgId dalf
|
||||
let templInstSrc =
|
||||
generateTemplateInstancesPkgFromLf
|
||||
getUid
|
||||
pkgId
|
||||
dalf
|
||||
pure
|
||||
( (src, unitId, dalf, bs)
|
||||
( (src, templInstSrc, unitId, dalf, bs)
|
||||
, pkgId
|
||||
, pkgRefs)
|
||||
let pkgIdsTopoSorted = reverse $ topSort depGraph
|
||||
dbPathAbs <- makeAbsolute dbPath
|
||||
projectPackageDatabaseAbs <- makeAbsolute projectPackageDatabase
|
||||
forM_ pkgIdsTopoSorted $ \vertex -> do
|
||||
let ((src, uid, dalf, bs), pkgId, _) =
|
||||
let ((src, templInstSrc, uid, dalf, bs), pkgId, _) =
|
||||
vertexToNode vertex
|
||||
when (uid /= primUnitId) $ do
|
||||
let unitIdStr = unitIdString uid
|
||||
let instancesUnitIdStr = "instances-" <> unitIdStr
|
||||
let pkgIdStr = T.unpack $ LF.unPackageId pkgId
|
||||
let (pkgName, mbPkgVersion) =
|
||||
fromMaybe (unitIdStr, Nothing) $ do
|
||||
@ -583,7 +589,7 @@ createProjectPackageDb opts fps = do
|
||||
Just (uId, Just ver)
|
||||
let deps =
|
||||
[ unitIdString uId <.> "dalf"
|
||||
| ((_src, uId, _dalf, _bs), pId, _) <-
|
||||
| ((_src, _templSrc, uId, _dalf, _bs), pId, _) <-
|
||||
map vertexToNode $ reachable depGraph vertex
|
||||
, pkgId /= pId
|
||||
]
|
||||
@ -606,6 +612,18 @@ createProjectPackageDb opts fps = do
|
||||
mbPkgVersion
|
||||
deps
|
||||
|
||||
unless (null templInstSrc) $
|
||||
generateAndInstallInstancesPkg
|
||||
templInstSrc
|
||||
opts
|
||||
dbPathAbs
|
||||
projectPackageDatabaseAbs
|
||||
unitIdStr
|
||||
instancesUnitIdStr
|
||||
pkgName
|
||||
mbPkgVersion
|
||||
deps
|
||||
|
||||
| length uniqSdkVersions <= 1 -> forM_ dars $
|
||||
\ExtractedDar{..} -> installDar dbPath edConfFiles edDalfs edSrcs
|
||||
| otherwise ->
|
||||
@ -672,6 +690,62 @@ createProjectPackageDb opts fps = do
|
||||
, "--expand-pkgroot"
|
||||
]
|
||||
|
||||
-- generate a package containing template instances and install it in the package database
|
||||
generateAndInstallInstancesPkg ::
|
||||
[(NormalizedFilePath, String)]
|
||||
-> Options
|
||||
-> FilePath
|
||||
-> FilePath
|
||||
-> String
|
||||
-> String
|
||||
-> String
|
||||
-> Maybe String
|
||||
-> [String]
|
||||
-> IO ()
|
||||
generateAndInstallInstancesPkg templInstSrc opts dbPathAbs projectPackageDatabaseAbs unitIdStr instancesUnitIdStr pkgName mbPkgVersion deps =
|
||||
withTempDir $ \tempDir ->
|
||||
withCurrentDirectory tempDir $ do
|
||||
loggerH <- getLogger opts "generate instances package"
|
||||
mapM_ writeSrc templInstSrc
|
||||
sdkVersion <- getSdkVersion
|
||||
let pkgConfig =
|
||||
PackageConfigFields
|
||||
{ pName = "instances-" <> pkgName
|
||||
, pSrc = "."
|
||||
, pExposedModules = Nothing
|
||||
, pVersion = mbPkgVersion
|
||||
, pDependencies = (unitIdStr <.> "dalf") : deps
|
||||
, pSdkVersion = sdkVersion
|
||||
, cliOpts = Nothing
|
||||
}
|
||||
opts' <-
|
||||
mkOptions $
|
||||
opts
|
||||
{ optWriteInterface = True
|
||||
, optPackageDbs = projectPackageDatabaseAbs : optPackageDbs opts
|
||||
, optIfaceDir = Just "./"
|
||||
, optIsGenerated = True
|
||||
, optDflagCheck = False
|
||||
, optMbPackageName = Just instancesUnitIdStr
|
||||
, optHideAllPkgs = False
|
||||
, optPackageImports = [(unitIdStr, []) | pkgName /= "daml-stdlib"]
|
||||
}
|
||||
mbDar <-
|
||||
withDamlIdeState opts' loggerH diagnosticsLogger $ \ide ->
|
||||
buildDar
|
||||
ide
|
||||
pkgConfig
|
||||
(toNormalizedFilePath $
|
||||
fromMaybe ifaceDir $ optIfaceDir opts')
|
||||
(FromDalf False)
|
||||
dar <- mbErr "ERROR: Creation of instances DAR file failed." mbDar
|
||||
-- TODO (drsk) switch to different zip library so we don't have to write
|
||||
-- the dar.
|
||||
let darFp = instancesUnitIdStr <.> "dar"
|
||||
Zip.createArchive darFp dar
|
||||
ExtractedDar{..} <- extractDar darFp
|
||||
installDar dbPathAbs edConfFiles edDalfs edSrcs
|
||||
|
||||
-- | Write generated source files
|
||||
writeSrc :: (NormalizedFilePath, String) -> IO ()
|
||||
writeSrc (fp, content) = do
|
||||
|
||||
@ -140,7 +140,7 @@ noassistantTests damlDir = testGroup "no assistant"
|
||||
|
||||
packagingTests :: TestTree
|
||||
packagingTests = testGroup "packaging"
|
||||
[ testCaseSteps "Build package with dependency" $ \step -> withTempDir $ \tmpDir -> do
|
||||
([ testCaseSteps "Build package with dependency" $ \step -> withTempDir $ \tmpDir -> do
|
||||
let projectA = tmpDir </> "a"
|
||||
let projectB = tmpDir </> "b"
|
||||
let aDar = projectA </> ".daml" </> "dist" </> "a-1.0.dar"
|
||||
@ -399,7 +399,10 @@ packagingTests = testGroup "packaging"
|
||||
, "dependencies: [daml-prim, daml-stdlib]"
|
||||
]
|
||||
withCurrentDirectory projDir $ callCommandQuiet "daml build"
|
||||
, testCase "Dalf imports" $ withTempDir $ \projDir -> do
|
||||
|
||||
] <> do
|
||||
withArchiveChoice <- [False,True] -- run two variations of the test
|
||||
return $ testCase ("Dalf imports (withArchiveChoice=" <> show withArchiveChoice <> ")") $ withTempDir $ \projDir -> do
|
||||
let genSimpleDalfExe
|
||||
| isWindows = "generate-simple-dalf.exe"
|
||||
| otherwise = "generate-simple-dalf"
|
||||
@ -412,36 +415,63 @@ packagingTests = testGroup "packaging"
|
||||
, "version: 0.1.0"
|
||||
, "source: ."
|
||||
, "dependencies: [daml-prim, daml-stdlib, simple-dalf-0.0.0.dalf]"
|
||||
, "build-options:"
|
||||
, "- --generated-src"
|
||||
]
|
||||
writeFileUTF8 (projDir </> "A.daml") $ unlines
|
||||
[ "daml 1.2"
|
||||
, "module A where"
|
||||
, "import qualified \"simple-dalf\" Module"
|
||||
, "import qualified Module"
|
||||
, "import qualified ModuleInstances"
|
||||
, "import DA.Internal.Template (toAnyTemplate, fromAnyTemplate)"
|
||||
, "newTemplate : Party -> Party -> Module.Template"
|
||||
, "newTemplate p1 p2 = Module.Template with Module.this = p1, Module.arg = p2"
|
||||
, "newChoice : Module.Choice"
|
||||
, "newChoice = Module.Choice ()"
|
||||
--, "createTemplate : Party -> Party -> Update (ContractId Module.Template)"
|
||||
--, "createTemplate p1 p2 = create $ newTemplate p1 p2"
|
||||
--, "fetchTemplate : ContractId Module.Template -> Update Module.Template"
|
||||
--, "fetchTemplate = fetch"
|
||||
--, "archiveTemplate : ContractId Module.Template -> Update ()"
|
||||
--, "archiveTemplate = archive"
|
||||
--, "signatoriesTemplate : Module.Template -> [Party]"
|
||||
--, "signatoriesTemplate = signatory"
|
||||
--, "observersTemplate : Module.Template -> [Party]"
|
||||
--, "observersTemplate = observer"
|
||||
--, "ensureTemplate : Module.Template -> Bool"
|
||||
--, "ensureTemplate = ensure"
|
||||
--, "agreementTemplate : Module.Template -> Text"
|
||||
--, "agreementTemplate = agreement"
|
||||
, "createTemplate : Party -> Party -> Update (ContractId Module.Template)"
|
||||
, "createTemplate p1 p2 = create $ newTemplate p1 p2"
|
||||
, "fetchTemplate : ContractId Module.Template -> Update Module.Template"
|
||||
, "fetchTemplate = fetch"
|
||||
, "archiveTemplate : ContractId Module.Template -> Update ()"
|
||||
, "archiveTemplate = archive"
|
||||
, "signatoriesTemplate : Module.Template -> [Party]"
|
||||
, "signatoriesTemplate = signatory"
|
||||
, "observersTemplate : Module.Template -> [Party]"
|
||||
, "observersTemplate = observer"
|
||||
, "ensureTemplate : Module.Template -> Bool"
|
||||
, "ensureTemplate = ensure"
|
||||
, "agreementTemplate : Module.Template -> Text"
|
||||
, "agreementTemplate = agreement"
|
||||
, "toAnyTemplateTemplate : Module.Template -> AnyTemplate"
|
||||
, "toAnyTemplateTemplate = toAnyTemplate"
|
||||
, "fromAnyTemplateTemplate : AnyTemplate -> Optional Module.Template"
|
||||
, "fromAnyTemplateTemplate = fromAnyTemplate"
|
||||
, "test_methods = scenario do"
|
||||
, " alice <- getParty \"Alice\""
|
||||
, " bob <- getParty \"Bob\""
|
||||
, " let t = newTemplate alice bob"
|
||||
, " assert $ signatory t == [alice, bob]"
|
||||
, " assert $ observer t == []"
|
||||
, " assert $ ensure t"
|
||||
, " assert $ agreement t == \"\""
|
||||
, " coid <- submit alice $ createTemplate alice alice"
|
||||
, " " <> (if withArchiveChoice then "submit" else "submitMustFail") <> " alice $ archive coid"
|
||||
, " coid1 <- submit bob $ createTemplate bob bob"
|
||||
, " t1 <- submit bob $ fetch coid1"
|
||||
, " assert $ signatory t1 == [bob, bob]"
|
||||
, " let anyTemplate = toAnyTemplate t1"
|
||||
, " let (Some t2 : Optional Module.Template) = fromAnyTemplate anyTemplate"
|
||||
, " pure ()"
|
||||
]
|
||||
withCurrentDirectory projDir $ callCommandQuiet $ genSimpleDalf <> " simple-dalf-0.0.0.dalf"
|
||||
withCurrentDirectory projDir $ callCommandQuiet "daml build"
|
||||
withCurrentDirectory projDir $ callCommandQuiet $ genSimpleDalf
|
||||
<> (if withArchiveChoice then " --with-archive-choice" else "")
|
||||
<> " simple-dalf-0.0.0.dalf"
|
||||
withCurrentDirectory projDir $ callCommandQuiet "daml build --target 1.dev"
|
||||
let dar = projDir </> ".daml/dist/proj-0.1.0.dar"
|
||||
assertBool "proj-0.1.0.dar was not created." =<< doesFileExist dar
|
||||
withCurrentDirectory projDir $ callCommandQuiet "daml test --target 1.dev"
|
||||
|
||||
, testCaseSteps "Build migration package" $ \step -> withTempDir $ \tmpDir -> do
|
||||
<> [ testCaseSteps "Build migration package" $ \step -> withTempDir $ \tmpDir -> do
|
||||
-- it's important that we have fresh empty directories here!
|
||||
let projectA = tmpDir </> "a-1.0"
|
||||
let projectB = tmpDir </> "a-2.0"
|
||||
@ -724,7 +754,7 @@ packagingTests = testGroup "packaging"
|
||||
, bWithUpgradesDar
|
||||
]
|
||||
assertBool "a-0.2-with-upgrades.dar was not created." =<< doesFileExist bWithUpgradesDar
|
||||
]
|
||||
])
|
||||
|
||||
quickstartTests :: FilePath -> FilePath -> TestTree
|
||||
quickstartTests quickstartDir mvnDir = testGroup "quickstart"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user