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.

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",

compiler/daml-lf-ast/BUILD.bazel

@@ -8,6 +8,7 @@ da_haskell_library(
     srcs = glob(["src/**/*.hs"]),
     hackage_deps = [
         "base",
+        "bytestring",
         "containers",
         "deepseq",
         "Decimal",

compiler/daml-lf-ast/src/DA/Daml/LF/Ast/World.hs

@@ -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

compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs

@@ -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)]

compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Upgrade.hs

@@ -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)

compiler/damlc/daml-ide-core/src/Development/IDE/Core/RuleTypes/Daml.hs

@@ -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 LF.DalfPackage
-
-type instance RuleResult GeneratePackageMap = Map UnitId DalfPackage
 
 -- | Runs all scenarios in the given file (but not scenarios in imports).
 type instance RuleResult RunScenarios = [(VirtualResource, Either SS.Error SS.ScenarioResult)]

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

@@ -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

compiler/damlc/daml-ide/src/DA/Daml/LanguageServer/Visualize.hs

@@ -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

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

@@ -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
 

compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/Primitives.hs

@@ -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.

compiler/damlc/daml-prim-src/GHC/Types.daml

@@ -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

compiler/damlc/lib/DA/Cli/Damlc.hs

@@ -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

daml-assistant/integration-tests/src/DA/Daml/Assistant/IntegrationTests.hs

@@ -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 : Party -> Party -> Update (ContractId Module.Template)"
-            --, "createTemplate p1 p2 = create $ newTemplate p1 p2"
+            , "createTemplate p1 p2 = create $ newTemplate p1 p2"
-            --, "fetchTemplate : ContractId Module.Template -> Update Module.Template"
+            , "fetchTemplate : ContractId Module.Template -> Update Module.Template"
-            --, "fetchTemplate = fetch"
+            , "fetchTemplate = fetch"
-            --, "archiveTemplate : ContractId Module.Template -> Update ()"
+            , "archiveTemplate : ContractId Module.Template -> Update ()"
-            --, "archiveTemplate = archive"
+            , "archiveTemplate = archive"
-            --, "signatoriesTemplate : Module.Template -> [Party]"
+            , "signatoriesTemplate : Module.Template -> [Party]"
-            --, "signatoriesTemplate = signatory"
+            , "signatoriesTemplate = signatory"
-            --, "observersTemplate : Module.Template -> [Party]"
+            , "observersTemplate : Module.Template -> [Party]"
-            --, "observersTemplate = observer"
+            , "observersTemplate = observer"
-            --, "ensureTemplate : Module.Template -> Bool"
+            , "ensureTemplate : Module.Template -> Bool"
-            --, "ensureTemplate = ensure"
+            , "ensureTemplate = ensure"
-            --, "agreementTemplate : Module.Template -> Text"
+            , "agreementTemplate : Module.Template -> Text"
-            --, "agreementTemplate = agreement"
+            , "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 $ genSimpleDalf
-        withCurrentDirectory projDir $ callCommandQuiet "daml build"
+            <> (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"