From 75c9b1bf9114cef5699fd3ce79d8de1f35af4938 Mon Sep 17 00:00:00 2001 From: Moritz Kiefer Date: Fri, 29 Nov 2019 16:13:15 +0100 Subject: [PATCH] Simplify template desugaring (#3670) * Introduce a simpler template desugaring without support for generic templates This adapts the LF conversion to the new template desugaring introduced in our GHC fork. The guiding principle is that we use the typeclasses directly to avoid generating, typechecking and converting redundant code caused by indirections. I updated the template desugaring documentation so that is probably a good starting point for reviewing this. * Address review comments * Fix daml doc tests * Fix data dependency tests * Switch to new ghc-lib release --- .../damlc/daml-doc/src/DA/Daml/Doc/Extract.hs | 38 +- .../damlc/daml-doc/src/DA/Daml/Doc/Types.hs | 1 + .../src/Development/IDE/Core/Rules/Daml.hs | 6 +- .../src/Development/IDE/Core/Service/Daml.hs | 2 + .../src/DA/Daml/LFConversion.hs | 495 ++++++++++-------- .../daml-stdlib-src/DA/Internal/Template.daml | 8 +- .../damlc/daml-visual/src/DA/Daml/Visual.hs | 6 +- compiler/damlc/lib/DA/Cli/Damlc.hs | 3 +- .../ExerciseWithoutActors.daml | 2 +- .../daml-test-files/GenericTemplateError.daml | 3 +- .../damlc/tests/src/DA/Test/ShakeIdeClient.hs | 13 +- ghc-lib/template-desugaring.md | 357 +++---------- stack-snapshot.yaml | 10 +- 13 files changed, 403 insertions(+), 541 deletions(-) diff --git a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract.hs b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract.hs index c856c02f4c..41044767a7 100644 --- a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract.hs +++ b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract.hs @@ -123,9 +123,14 @@ extractDocs extractOpts diagsLogger ideOpts fp = do (adts, md_templateInstances) = partitionEithers . flip map filteredTyCons $ \adt -> - case getTemplateInstanceDoc adt of + case find (\td -> td_name td == ad_name adt) md_templates of Nothing -> Left adt - Just ti -> Right ti + Just td -> Right TemplateInstanceDoc + { ti_anchor = td_anchor td + , ti_name = ad_name adt + , ti_descr = Nothing + , ti_rhs = TypeApp Nothing (ad_name adt) [] + } md_adts = mapMaybe (filterTypeByExports ctx) adts @@ -274,6 +279,7 @@ getFctDocs ctx@DocCtx{..} (DeclData decl docs) = do fct_descr = docs guard (exportsFunction dc_exports fct_name) + guard (not $ "_choice_" `T.isPrefixOf` packRdrName name) Just FunctionDoc {..} getClsDocs :: DocCtx -> DeclData -> Maybe ClassDoc @@ -523,34 +529,6 @@ getTemplateDocs DocCtx{..} typeMap templateInstanceMap = [] -> [] -- catching the dummy case here, see above _other -> error "getFields: found multiple constructors" --- | A template instance is desugared to a type synonym with a doc marker. --- --- For example, --- --- @template instance ProposalIou = Proposal Iou@ --- --- leads to the `type` declaration --- --- @--| TEMPLATE_INSTANCE@ --- @type ProposalIou = Proposal Iou@ --- --- This function looks for the "TEMPLATE_INSTANCE" doc marker around a type --- synonym and, if it finds it, creates the relevant doc structure. -getTemplateInstanceDoc :: ADTDoc -> Maybe TemplateInstanceDoc -getTemplateInstanceDoc tyConDoc - | TypeSynDoc{..} <- tyConDoc - , Just (DocText doc) <- ad_descr - , Just realDoc <- T.stripSuffix "TEMPLATE_INSTANCE" doc - = Just TemplateInstanceDoc - { ti_name = ad_name - , ti_anchor = ad_anchor - , ti_descr = Just (DocText realDoc) - , ti_rhs = ad_rhs - } - - | otherwise - = Nothing - -- recognising Template and Choice instances diff --git a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Types.hs b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Types.hs index 7e329b3ff4..7c03758938 100644 --- a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Types.hs +++ b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Types.hs @@ -77,6 +77,7 @@ data ModuleDoc = ModuleDoc , md_descr :: Maybe DocText , md_templates :: [TemplateDoc] , md_templateInstances :: [TemplateInstanceDoc] + -- TODO This doesn’t make sense anymore now that we killed generic templates. , md_adts :: [ADTDoc] , md_functions :: [FunctionDoc] , md_classes :: [ClassDoc] diff --git a/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs b/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs index aee37fa1e1..9bcd2a8433 100644 --- a/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs +++ b/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs @@ -204,8 +204,9 @@ generateRawDalfRule = setPriority priorityGenerateDalf -- Generate the map from package names to package hashes pkgMap <- useNoFile_ GeneratePackageMap + DamlEnv{envIsGenerated} <- getDamlServiceEnv -- GHC Core to DAML LF - case convertModule lfVersion pkgMap file core of + case convertModule lfVersion pkgMap envIsGenerated file core of Left e -> return ([e], Nothing) Right v -> return ([], Just $ LF.simplifyModule v) @@ -340,7 +341,8 @@ generateSerializedDalfRule options = Just core -> fmap (first (diags ++)) $ do -- lf conversion pkgMap <- useNoFile_ GeneratePackageMap - case convertModule lfVersion pkgMap file core of + DamlEnv{envIsGenerated} <- getDamlServiceEnv + case convertModule lfVersion pkgMap envIsGenerated file core of Left e -> pure ([e], Nothing) Right rawDalf -> do -- LF postprocessing diff --git a/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Service/Daml.hs b/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Service/Daml.hs index c7a13c56ac..103234f344 100644 --- a/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Service/Daml.hs +++ b/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Service/Daml.hs @@ -68,6 +68,7 @@ data DamlEnv = DamlEnv -- This is used to avoid unnecessary GC calls. , envDamlLfVersion :: LF.Version , envSkipScenarioValidation :: SkipScenarioValidation + , envIsGenerated :: Bool } instance IsIdeGlobal DamlEnv @@ -84,6 +85,7 @@ mkDamlEnv opts scenarioService = do , envPreviousScenarioContexts = previousScenarioContextsVar , envDamlLfVersion = optDamlLfVersion opts , envSkipScenarioValidation = optSkipScenarioValidation opts + , envIsGenerated = optIsGenerated opts } getDamlServiceEnv :: Action DamlEnv diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs index 84e73f11f6..e6f6962939 100644 --- a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs +++ b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs @@ -100,11 +100,12 @@ import Data.Data hiding (TyCon) import qualified Data.Decimal as Decimal import Data.Foldable (foldlM) import Data.Int -import Data.List.Extra +import Data.List.Extra hiding (for) import qualified Data.Map.Strict as MS import Data.Maybe import qualified Data.NameMap as NM import qualified Data.Text as T +import Data.Traversable (for) import Data.Tuple.Extra import Data.Ratio import "ghc-lib" GHC @@ -161,8 +162,21 @@ data Env = Env ,envLfVersion :: LF.Version ,envTypeSynonyms :: [(GHC.Type, TyCon)] ,envInstances :: [(TyCon, [GHC.Type])] + ,envChoiceData :: MS.Map TypeConName [ChoiceData] + ,envTemplateKeyData :: MS.Map TypeConName TemplateKeyData + ,envIsGenerated :: Bool } +data ChoiceData = ChoiceData + { _choiceDatTy :: GHC.Type + , _choiceDatExpr :: GHC.Expr GHC.CoreBndr + } + +data TemplateKeyData = TemplateKeyData + { _templateKeyType :: GHC.Type + , _templateKeyDict :: GHC.Var + } + -- v is an alias for x envInsertAlias :: Var -> LF.Expr -> Env -> Env envInsertAlias v x env = env{envAliases = MS.insert v x (envAliases env)} @@ -263,10 +277,11 @@ convertRationalNumericMono env scale num denom convertModule :: LF.Version -> MS.Map UnitId DalfPackage + -> Bool -> NormalizedFilePath -> CoreModule -> Either FileDiagnostic LF.Module -convertModule lfVersion pkgMap file x = runConvertM (ConversionEnv file Nothing) $ do +convertModule lfVersion pkgMap isGenerated file x = runConvertM (ConversionEnv file Nothing) $ do definitions <- concatMapM (convertBind env) binds types <- concatMapM (convertTypeDef env) (eltsUFM (cm_types x)) pure (LF.moduleFromDefinitions lfModName (Just $ fromNormalizedFilePath file) flags (types ++ definitions)) @@ -296,6 +311,18 @@ convertModule lfVersion pkgMap file x = runConvertM (ConversionEnv file Nothing) , DFunId _ <- [idDetails name] , TypeCon c ts <- [varType name] ] + choiceData = MS.fromListWith (++) + [ (mkTypeCon [getOccText tplTy], [ChoiceData ty v]) + | (name, v) <- binds + , "_choice_" `T.isPrefixOf` getOccText name + , ty@(TypeCon _ [_, _, TypeCon _ [TypeCon tplTy _]]) <- [varType name] + ] + templateKeyData = MS.fromList + [ (mkTypeCon [getOccText tplTy], TemplateKeyData keyTy name) + | (name, _) <- binds + , "$fTemplateKey" `T.isPrefixOf` getOccText name + , ty@(TypeCon _ [TypeCon tplTy _, keyTy]) <- [varType name] + ] env = Env { envLFModuleName = lfModName , envGHCModuleName = ghcModName @@ -305,213 +332,11 @@ convertModule lfVersion pkgMap file x = runConvertM (ConversionEnv file Nothing) , envLfVersion = lfVersion , envTypeSynonyms = typeSynonyms , envInstances = instances + , envChoiceData = choiceData + , envTemplateKeyData = templateKeyData + , envIsGenerated = isGenerated } --- TODO(MH): We should run this on an `LF.Expr` instead of a `GHC.Expr`. --- This will avoid a fair bit of repetition. -convertGenericTemplate :: Env -> GHC.Expr Var -> ConvertM (Template, LF.Expr) -convertGenericTemplate env x - | (Var dictCon, args) <- collectArgs x - , Just m <- nameModule_maybe $ varName dictCon - , Just dictCon <- isDataConId_maybe dictCon - , (tyArgs, args) <- span isTypeArg args - , Just tyArgs <- mapM isType_maybe tyArgs - , (superClassDicts, args) <- span isSuperClassDict args - , Just (signatories : observers : ensure : agreement : create : _fetch : archive : _toAnyTemplate : _fromAnyTemplate : _templateTypeRep : keyAndChoices) <- mapM isVar_maybe args - , Just (polyType@(TypeCon polyTyCon _), _) <- splitFunTy_maybe (varType create) - , Just monoTyCon <- findMonoTyp polyType - = do - let tplLocation = convNameLoc monoTyCon - fields = ctorLabels (tyConSingleDataCon polyTyCon) - polyType@(TConApp polyTyCon polyTyArgs) <- convertType env polyType - let polyTCA = TypeConApp polyTyCon polyTyArgs - monoType@(TCon monoTyCon) <- convertTyCon env monoTyCon - let monoTCA = TypeConApp monoTyCon [] - let coerceRec fromType toType fromExpr = - ELet (Binding (rec, typeConAppToType fromType) fromExpr) $ - ERecCon toType $ map (\field -> (field, ERecProj fromType field (EVar rec))) fields - let (unwrapTpl, wrapTpl, unwrapCid, wrapCid) - | null polyTyArgs = (id, id, id, id) - | otherwise = - ( coerceRec monoTCA polyTCA - , coerceRec polyTCA monoTCA - , ETmApp $ mkETyApps (EBuiltin BECoerceContractId) [monoType, polyType] - , ETmApp $ mkETyApps (EBuiltin BECoerceContractId) [polyType, monoType] - ) - stdlibRef <- packageNameToPkgRef env damlStdlib - let tplTypeCon = qualObject monoTyCon - let tplParam = this - let applyThis e = ETmApp e $ unwrapTpl $ EVar this - tplSignatories <- applyThis <$> convertExpr env (Var signatories) - tplObservers <- applyThis <$> convertExpr env (Var observers) - tplPrecondition <- applyThis <$> convertExpr env (Var ensure) - tplAgreement <- applyThis <$> convertExpr env (Var agreement) - archive <- convertExpr env (Var archive) - (tplKey, key, choices) <- case keyAndChoices of - hasKey : key : maintainers : _fetchByKey : _lookupByKey : _toAnyContractKey : _fromAnyContractKey : choices - | TypeCon (Is "HasKey") _ <- varType hasKey -> do - _ :-> keyType <- convertType env (varType key) - hasKey <- convertExpr env (Var hasKey) - key <- convertExpr env (Var key) - maintainers <- convertExpr env (Var maintainers) - let selfField = FieldName "contractId" - let thisField = FieldName "contract" - tupleTyCon <- qDA_Types env $ mkTypeCon ["Tuple2"] - let tupleType = TypeConApp tupleTyCon [TContractId polyType, polyType] - let fetchByKey = - ETmLam (mkVar "key", keyType) $ - EUpdate $ UBind (Binding (res, TStruct [(selfField, TContractId monoType), (thisField, monoType)]) $ EUpdate $ UFetchByKey $ RetrieveByKey monoTyCon $ EVar $ mkVar "key") $ - EUpdate $ UPure (typeConAppToType tupleType) $ ERecCon tupleType - [ (FieldName "_1", unwrapCid $ EStructProj selfField $ EVar res) - , (FieldName "_2", unwrapTpl $ EStructProj thisField $ EVar res) - ] - let lookupByKey = - ETmLam (mkVar "key", keyType) $ - EUpdate $ UBind (Binding (res, TOptional (TContractId monoType)) $ EUpdate $ ULookupByKey $ RetrieveByKey monoTyCon $ EVar $ mkVar "key") $ - EUpdate $ UPure (TOptional (TContractId polyType)) $ ECase (EVar res) - [ CaseAlternative CPNone $ ENone (TContractId polyType) - , CaseAlternative (CPSome self) $ ESome (TContractId polyType) $ unwrapCid $ EVar self - ] - let toAnyContractKey = - if envLfVersion env `supports` featureAnyType - then ETyLam - (mkTypeVar "proxy", KArrow KStar KStar) - (ETmLam - (mkVar "_", TApp (TVar $ mkTypeVar "proxy") polyType) - (ETmLam (mkVar "key", keyType) $ EToAny keyType $ EVar $ mkVar "key")) - else EBuiltin BEError `ETyApp` - TForall (mkTypeVar "proxy", KArrow KStar KStar) (TApp (TVar $ mkTypeVar "proxy") polyType :-> keyType :-> TUnit) `ETmApp` - EBuiltin (BEText "toAnyContractKey is not supported in this DAML-LF version") - let fromAnyContractKey = - if envLfVersion env `supports` featureAnyType - then ETyLam - (mkTypeVar "proxy", KArrow KStar KStar) - (ETmLam - (mkVar "_", TApp (TVar $ mkTypeVar "proxy") polyType) - (ETmLam (mkVar "any", TAny) $ EFromAny keyType $ EVar $ mkVar "any")) - else EBuiltin BEError `ETyApp` - TForall (mkTypeVar "proxy", KArrow KStar KStar) (TApp (TVar $ mkTypeVar "proxy") polyType :-> TUnit :-> TOptional keyType) `ETmApp` - EBuiltin (BEText "fromAnyContractKey is not supported in this DAML-LF version") - pure (Just $ TemplateKey keyType (applyThis key) (ETmApp maintainers hasKey), [hasKey, key, maintainers, fetchByKey, lookupByKey, toAnyContractKey, fromAnyContractKey], choices) - choices -> pure (Nothing, [], choices) - let convertGenericChoice :: [Var] -> ConvertM (TemplateChoice, [LF.Expr]) - convertGenericChoice [consumption, controllers, action, _exercise, _toAnyChoice, _fromAnyChoice] = do - (argType, argTCon, resType) <- convertType env (varType action) >>= \case - TContractId _ :-> _ :-> argType@(TConApp argTCon _) :-> TUpdate resType -> pure (argType, argTCon, resType) - t -> unhandled "Choice action type" (varType action) - let chcLocation = Nothing - let chcName = ChoiceName $ T.intercalate "." $ unTypeConName $ qualObject argTCon - consumptionType <- case varType consumption of - TypeCon (Is "NonConsuming") _ -> pure NonConsuming - TypeCon (Is "PreConsuming") _ -> pure PreConsuming - TypeCon (Is "PostConsuming") _ -> pure PostConsuming - t -> unhandled "choice consumption type" t - let chcConsuming = consumptionType == PreConsuming - let chcSelfBinder = self - let applySelf e = ETmApp e $ unwrapCid $ EVar self - let chcArgBinder = (arg, argType) - let applyArg e = e `ETmApp` EVar (fst chcArgBinder) - let chcReturnType = resType - consumption <- convertExpr env (Var consumption) - chcControllers <- applyArg . applyThis <$> convertExpr env (Var controllers) - update <- applyArg . applyThis . applySelf <$> convertExpr env (Var action) - let chcUpdate - | consumptionType /= PostConsuming = update - | otherwise = - EUpdate $ UBind (Binding (res, resType) update) $ - EUpdate $ UBind (Binding (mkVar "_", TUnit) $ ETmApp archive $ EVar self) $ - EUpdate $ UPure resType $ EVar res - controllers <- convertExpr env (Var controllers) - action <- convertExpr env (Var action) - let exercise = - mkETmLams [(self, TContractId polyType), (arg, argType)] $ - EUpdate $ UExercise monoTyCon chcName (wrapCid $ EVar self) Nothing (EVar arg) - let toAnyChoice = - if envLfVersion env `supports` featureAnyType - then ETyLam - (mkTypeVar "proxy", KArrow KStar KStar) - (ETmLam - (mkVar "_", TApp (TVar $ mkTypeVar "proxy") polyType) - (ETmLam chcArgBinder $ EToAny argType $ EVar arg)) - else EBuiltin BEError `ETyApp` - TForall (mkTypeVar "proxy", KArrow KStar KStar) (TApp (TVar $ mkTypeVar "proxy") polyType :-> argType :-> TUnit) `ETmApp` - EBuiltin (BEText "toAnyChoice is not supported in this DAML-LF version") - let fromAnyChoice = - if envLfVersion env `supports` featureAnyType - then ETyLam - (mkTypeVar "proxy", KArrow KStar KStar) - (ETmLam - (mkVar "_", TApp (TVar $ mkTypeVar "proxy") polyType) - (ETmLam (mkVar "any", TAny) $ EFromAny argType $ EVar $ mkVar "any")) - else EBuiltin BEError `ETyApp` - TForall (mkTypeVar "proxy", KArrow KStar KStar) (TApp (TVar $ mkTypeVar "proxy") polyType :-> TUnit :-> TOptional argType) `ETmApp` - EBuiltin (BEText "fromAnyChoice is not supported in this DAML-LF version") - pure (TemplateChoice{..}, [consumption, controllers, action, exercise, toAnyChoice, fromAnyChoice]) - convertGenericChoice es = unhandled "generic choice" es - (tplChoices, choices) <- first NM.fromList . unzip <$> mapM convertGenericChoice (chunksOf 6 choices) - superClassDicts <- mapM (convertExpr env) superClassDicts - signatories <- convertExpr env (Var signatories) - observers <- convertExpr env (Var observers) - ensure <- convertExpr env (Var ensure) - 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 = anyTemplateTyFromStdlib stdlibRef - let anyTemplateField = mkField "getAnyTemplate" - let toAnyTemplate = - if envLfVersion env `supports` featureAnyType - then ETmLam (this, polyType) $ ERecCon anyTemplateTy [(anyTemplateField, EToAny (TCon monoTyCon) (wrapTpl $ EVar this))] - else EBuiltin BEError `ETyApp` (polyType :-> typeConAppToType anyTemplateTy) `ETmApp` EBuiltin (BEText "toAnyTemplate is not supported in this DAML-LF version") - let fromAnyTemplate = - if envLfVersion env `supports` featureAnyType - then ETmLam (anyTpl, typeConAppToType anyTemplateTy) $ - ECase (EFromAny (TCon monoTyCon) (ERecProj anyTemplateTy anyTemplateField (EVar anyTpl))) - [ CaseAlternative CPNone $ ENone polyType - , CaseAlternative (CPSome self) $ ESome polyType $ unwrapTpl $ EVar self - ] - else EBuiltin BEError `ETyApp` (typeConAppToType anyTemplateTy :-> TOptional polyType) `ETmApp` EBuiltin (BEText "fromAnyTemplate is not supported in this DAML-LF version") - let templateTypeRep = - let proxyName = mkTypeVar "proxy" - argType = TVar proxyName `TApp` polyType - resType = TypeConApp (Qualified stdlibRef (mkModName ["DA", "Internal", "LF"]) (mkTypeCon ["TemplateTypeRep"])) [] - resField = mkField "getTemplateTypeRep" - in - ETyLam (proxyName, KStar `KArrow` KStar) $! - if envLfVersion env `supports` featureTypeRep - then ETmLam (arg, argType) $ ERecCon resType [(resField, ETypeRep (TCon monoTyCon))] - else EBuiltin BEError `ETyApp` (argType :-> typeConAppToType resType) `ETmApp` EBuiltin (BEText "templateTypeRep is not supported in this DAML-LF version") - tyArgs <- mapM (convertType env) tyArgs - -- NOTE(MH): The additional lambda is DICTIONARY SANITIZATION step (3). - let tmArgs = map (ETmLam (mkVar "_", TUnit)) $ superClassDicts ++ [signatories, observers, ensure, agreement, create, fetch, archive, toAnyTemplate, fromAnyTemplate, templateTypeRep] ++ key ++ concat choices - qTCon <- qualify env m $ mkTypeCon [getOccText $ dataConTyCon dictCon] - let tcon = TypeConApp qTCon tyArgs - let fldNames = ctorLabels dictCon - let dict = ERecCon tcon (zip fldNames tmArgs) - pure (Template{..}, dict) - where - isVar_maybe :: GHC.Expr Var -> Maybe Var - isVar_maybe = \case - Var v -> Just v - _ -> Nothing - isSuperClassDict :: GHC.Expr Var -> Bool - -- NOTE(MH): We need the `$f` and `$d` cases since GHC inlines super class - -- dictionaries without running the simplifier under some circumstances. - isSuperClassDict (Var v) = any (`T.isPrefixOf` getOccText v) ["$cp", "$f", "$d"] - -- For things like Numeric 10 we can end up with superclass dictionaries - -- of the form `dict @10`. - isSuperClassDict (App t _) = isSuperClassDict t - isSuperClassDict _ = False - findMonoTyp :: GHC.Type -> Maybe TyCon - findMonoTyp t = case t of - TypeCon tcon [] -> Just tcon - t -> snd <$> find (eqType t . fst) (envTypeSynonyms env) - this = mkVar "this" - self = mkVar "self" - arg = mkVar "arg" - res = mkVar "res" - rec = mkVar "rec" -convertGenericTemplate env x = unhandled "generic template" x - data Consuming = PreConsuming | NonConsuming | PostConsuming @@ -636,6 +461,16 @@ convertVariantConDef env tycon tyVars con = tconName = mkTypeCon [getOccText tycon] ctorName = mkVariantCon (getOccText con) +this, self, arg, res :: ExprVarName +this = mkVar "this" +self = mkVar "self" +arg = mkVar "arg" +res = mkVar "res" +proxyVar :: TypeVarName +proxyVar = mkTypeVar "proxy" +mkProxy :: LF.Type -> LF.Type +mkProxy = TApp (TVar proxyVar) + -- | Instantiate and inline the generic template record definition -- for a template instance. convertTemplateInstanceDef :: Env -> Name -> TyCon -> [GHC.Type] -> ConvertM [Definition] @@ -654,13 +489,233 @@ convertTemplateInstanceDef env tname templateTyCon args = do convertBind :: Env -> (Var, GHC.Expr Var) -> ConvertM [Definition] convertBind env (name, x) - | DFunId _ <- idDetails name - , TypeCon (Is tplInst) _ <- varType name - , "Instance" `T.isSuffixOf` fsToText tplInst - = withRange (convNameLoc name) $ do - (tmpl, dict) <- convertGenericTemplate env x - name' <- convValWithType env name - pure [DTemplate tmpl, defValue name name' dict] + | "$fTemplateKey" `T.isPrefixOf` getOccText name + , not (envIsGenerated env) + , TypeCon classTyCon [tplTy, keyTy] <- varType name = withRange (convNameLoc name) $ do + TCon classTyConLf <- convertTyCon env classTyCon + tplTyLf@(TCon tplTyConLf) <- convertType env tplTy + keyTyLf <- convertType env keyTy + ERecCon _ + ( (_, tplSuperDict) + : (_, key) + : _lookupByKey + : _fetchByKey + : (_, maintainer) + : _toAnyContractKey + : _fromAnyContractKey + : [] + ) <- convertExpr env x + tupleTyCon <- qDA_Types env $ mkTypeCon ["Tuple2"] + let tupleType = TypeConApp tupleTyCon [TContractId tplTyLf, tplTyLf] + let selfField = FieldName "contractId" + let thisField = FieldName "contract" + let retrieveByKey = RetrieveByKey tplTyConLf (EVar $ mkVar "key") + let lookupByKey = + ETmLam (mkVar "key", keyTyLf) $ + EUpdate $ ULookupByKey retrieveByKey + let fetchByKey = + ETmLam (mkVar "key", keyTyLf) $ + EUpdate $ UBind (Binding (res, TStruct [(selfField, TContractId tplTyLf), (thisField, tplTyLf)]) $ EUpdate $ UFetchByKey retrieveByKey) $ + EUpdate $ UPure (typeConAppToType tupleType) $ ERecCon tupleType + [ (mkIndexedField 1, EStructProj selfField $ EVar res) + , (mkIndexedField 2, EStructProj thisField $ EVar res) + ] + let toAnyContractKey = + if envLfVersion env `supports` featureAnyType + then + ETyLam (proxyVar, KArrow KStar KStar) $ + ETmLam + (mkVar "_", mkProxy tplTyLf) $ + ETmLam (mkVar "arg", keyTyLf) $ + EToAny keyTyLf (EVar $ mkVar "arg") + else + EBuiltin BEError `ETyApp` + TForall (proxyVar, KArrow KStar KStar) (mkProxy tplTyLf :-> keyTyLf :-> TUnit) `ETmApp` + EBuiltin (BEText "toAnyContractKey is not supported in this DAML-LF version") + let fromAnyContractKey = + if envLfVersion env `supports` featureAnyType + then + ETyLam (proxyVar, KArrow KStar KStar) $ + ETmLam + (mkVar "_", mkProxy tplTyLf) $ + ETmLam (mkVar "any", TAny) $ + EFromAny keyTyLf (EVar $ mkVar "any") + else EBuiltin BEError `ETyApp` + TForall (proxyVar, KArrow KStar KStar) (mkProxy tplTyLf :-> TUnit :-> TOptional keyTyLf) `ETmApp` + EBuiltin (BEText "fromAnyContractKey is not supported in this DAML-LF version") + let dict = ERecCon (TypeConApp classTyConLf [tplTyLf, keyTyLf]) $ + map (second (ETmLam (mkVar "_", TUnit))) $ + [ (mkIndexedField 1, tplSuperDict) + , (mkIndexedField 2, key) + , (mkIndexedField 3, lookupByKey) + , (mkIndexedField 4, fetchByKey) + , (mkIndexedField 5, maintainer) + , (mkIndexedField 6, toAnyContractKey) + , (mkIndexedField 7, fromAnyContractKey) + ] + name' <- convValWithType env name + pure [defValue name name' dict] + | "$fTemplate" `T.isPrefixOf` getOccText name + , TypeCon classTyCon [tplTy@(TypeCon tplTyCon _)] <- varType name + , not (envIsGenerated env) = withRange (convNameLoc name) $ do + TCon classTyConLf <- convertTyCon env classTyCon + tplTyLf@(TCon tplTyConLf) <- convertType env tplTy + ERecCon _ + ( (_, signatory) + : (_, observer) + : (_, ensure) + : (_, agreement) + : _create + : _fetch + : (_, archive) + : _) + <- convertExpr env x + stdlibRef <- packageNameToPkgRef env damlStdlib + let anyTemplateTy = anyTemplateTyFromStdlib stdlibRef + let templateTypeRepTy = templateTypeRepTyFromStdlib stdlibRef + let create = ETmLam (this, tplTyLf) $ EUpdate $ UCreate tplTyConLf (EVar (this)) + let fetch = ETmLam (this, TContractId tplTyLf) $ EUpdate $ UFetch tplTyConLf (EVar this) + let toAnyTemplate = + if envLfVersion env `supports` featureAnyType + then ETmLam (this, tplTyLf) $ ERecCon anyTemplateTy [(anyTemplateField, EToAny tplTyLf (EVar (this)))] + else EBuiltin BEError `ETyApp` (tplTyLf :-> typeConAppToType anyTemplateTy) `ETmApp` EBuiltin (BEText "toAnyTemplate is not supported in this DAML-LF version") + let fromAnyTemplate = + if envLfVersion env `supports` featureAnyType + then ETmLam + (mkVar "any", typeConAppToType anyTemplateTy) $ + EFromAny tplTyLf (ERecProj anyTemplateTy anyTemplateField (EVar $ mkVar "any")) + else EBuiltin BEError `ETyApp` (typeConAppToType anyTemplateTy :-> TOptional tplTyLf) `ETmApp` EBuiltin (BEText "fromAnyTemplate is not supported in this DAML-LF version") + let templateTypeRep = + ETyLam (proxyVar, KArrow KStar KStar) $ + if envLfVersion env `supports` featureTypeRep + then ETmLam + (mkVar "_", mkProxy tplTyLf) $ + ERecCon templateTypeRepTy [(templateTypeRepField, ETypeRep tplTyLf)] + else EBuiltin BEError `ETyApp` (mkProxy tplTyLf :-> typeConAppToType templateTypeRepTy) `ETmApp` EBuiltin (BEText "templateTypeRep is not supported in this DAML-LF version") + let dict = ERecCon (TypeConApp classTyConLf [tplTyLf]) $ + map (second (ETmLam (mkVar "_", TUnit))) + [ (mkIndexedField 1, signatory) + , (mkIndexedField 2, observer) + , (mkIndexedField 3, ensure) + , (mkIndexedField 4, agreement) + , (mkIndexedField 5, create) + , (mkIndexedField 6, fetch) + , (mkIndexedField 7, archive) + , (mkIndexedField 8, toAnyTemplate) + , (mkIndexedField 9, fromAnyTemplate) + , (mkIndexedField 10, templateTypeRep) + ] + let choiceData = MS.findWithDefault [] (qualObject tplTyConLf) (envChoiceData env) + let convertChoice :: ChoiceData -> ConvertM TemplateChoice + convertChoice (ChoiceData ty expr) = do + TConApp _ [_, _ :-> _ :-> choiceTy@(TConApp choiceTyCon _) :-> TUpdate choiceRetTy, consumingTy] <- convertType env ty + let choiceName = ChoiceName (T.intercalate "." $ unTypeConName $ qualObject choiceTyCon) + ERecCon _ [(_, controllers), (_, action), _] <- convertExpr env expr + consuming <- case consumingTy of + TConApp (Qualified { qualObject = TypeConName con }) _ + | con == ["NonConsuming"] -> pure NonConsuming + | con == ["PreConsuming"] -> pure PreConsuming + | con == ["PostConsuming"] -> pure PostConsuming + _ -> unhandled "choice consumption type" (show consumingTy) + let update = action `ETmApp` EVar self `ETmApp` EVar this ` ETmApp` EVar (arg) + update <- pure $ if consuming /= PostConsuming + then update + else EUpdate $ UBind (Binding (res, choiceRetTy) update) $ + EUpdate $ UBind (Binding (mkVar "_", TUnit) $ archive `ETmApp` EVar self) $ + EUpdate $ UPure choiceRetTy $ EVar res + pure TemplateChoice + { chcLocation = Nothing + , chcName = choiceName + , chcConsuming = consuming == PreConsuming + , chcControllers = controllers `ETmApp` EVar this `ETmApp` EVar (arg) + , chcSelfBinder = self + , chcArgBinder = (arg, choiceTy) + , chcReturnType = choiceRetTy + , chcUpdate = update + } + choices <- NM.fromList <$> traverse convertChoice choiceData + key <- for (MS.lookup (qualObject tplTyConLf) (envTemplateKeyData env)) $ \(TemplateKeyData keyTy keyDict) -> do + keyTyLf <- convertType env keyTy + (dictName, TConApp dictTy dictTyArgs) <- convValWithType env keyDict + let dictTyConApp = TypeConApp dictTy dictTyArgs + Just m <- pure $ nameModule_maybe $ varName keyDict + qualDictName <- qualify env m dictName + pure TemplateKey + { tplKeyType = keyTyLf + , tplKeyBody = + ERecProj dictTyConApp (mkIndexedField 2) (EVal qualDictName) + `ETmApp` EUnit + `ETmApp` EVar this + , tplKeyMaintainers = + ERecProj dictTyConApp (mkIndexedField 5) (EVal qualDictName) + `ETmApp` EUnit + `ETyApp` TBuiltin BTList + `ETmApp` ENil tplTyLf + } + let template = Template + { tplLocation = convNameLoc tplTyCon + , tplTypeCon = qualObject tplTyConLf + , tplParam = this + , tplPrecondition = ensure `ETmApp` EVar this + , tplSignatories = signatory `ETmApp` EVar this + , tplObservers = observer `ETmApp` EVar this + , tplAgreement = agreement `ETmApp` EVar this + , tplChoices = choices + , tplKey = key + } + name' <- convValWithType env name + pure [defValue name name' dict, DTemplate template] + | "$fChoice" `T.isPrefixOf` getOccText name + , not (envIsGenerated env) + , TypeCon tyCon [tplTy, choiceArgTy, choiceRetTy] <- varType name = withRange (convNameLoc name) $ do + TConApp choiceTyLf _ <- convertTyCon env tyCon + ERecCon _ [(_, tplSuperDict), _, _, _] <- convertExpr env x + tplTyLf@(TCon tplTyConLf) <- convertType env tplTy + choiceArgTyLf@(TConApp choiceTyCon _) <- convertType env choiceArgTy + let choiceName = ChoiceName (T.intercalate "." $ unTypeConName $ qualObject choiceTyCon) + choiceRetTyLf <- convertType env choiceRetTy + let exercise = + ETmLam (this, TContractId tplTyLf) $ + ETmLam (arg, choiceArgTyLf) $ + EUpdate $ UExercise + tplTyConLf + choiceName + (EVar this) + Nothing + (EVar arg) + let toAnyChoice = + if envLfVersion env `supports` featureAnyType + then + ETyLam (proxyVar, KArrow KStar KStar) $ + ETmLam + (mkVar "_", mkProxy tplTyLf) $ + ETmLam (mkVar "arg", choiceArgTyLf) $ + EToAny choiceArgTyLf (EVar arg) + else EBuiltin BEError `ETyApp` + TForall (proxyVar, KArrow KStar KStar) (mkProxy tplTyLf :-> choiceArgTyLf :-> TUnit) `ETmApp` + EBuiltin (BEText "toAnyChoice is not supported in this DAML-LF version") + let fromAnyChoice = + if envLfVersion env `supports` featureAnyType + then + ETyLam (proxyVar, KArrow KStar KStar) $ + ETmLam + (mkVar "_", mkProxy tplTyLf) $ + ETmLam (mkVar "any", TAny) $ + EFromAny choiceArgTyLf (EVar $ mkVar "any") + else EBuiltin BEError `ETyApp` + TForall (proxyVar, KArrow KStar KStar) (mkProxy tplTyLf :-> TUnit :-> TOptional choiceArgTyLf) `ETmApp` + EBuiltin (BEText "fromAnyChoice is not supported in this DAML-LF version") + let dict = ERecCon (TypeConApp choiceTyLf [tplTyLf, choiceArgTyLf, choiceRetTyLf]) $ + map (second (ETmLam (mkVar "_", TUnit))) + [ (mkIndexedField 1, tplSuperDict) + , (mkIndexedField 2, exercise) + , (mkIndexedField 3, toAnyChoice) + , (mkIndexedField 4, fromAnyChoice) + ] + name' <- convValWithType env name + pure [defValue name name' dict] + -- This is inlined in the choice in the template so we can just drop this. + | "_choice_" `T.isPrefixOf` getOccText name = pure [] | Just internals <- lookupUFM internalFunctions (envGHCModuleName env) , getOccFS name `elementOfUniqSet` internals = pure [] @@ -1748,6 +1803,18 @@ anyTemplateTyFromStdlib stdlibRef = anyTemplateField :: FieldName anyTemplateField = mkField "getAnyTemplate" +templateTypeRepTyFromStdlib :: PackageRef -> TypeConApp +templateTypeRepTyFromStdlib stdlibRef = + TypeConApp + (Qualified + stdlibRef + (mkModName ["DA", "Internal", "LF"]) + (mkTypeCon ["TemplateTypeRep"])) + [] + +templateTypeRepField :: FieldName +templateTypeRepField = mkField "getTemplateTypeRep" + anyTpl :: ExprVarName anyTpl = mkVar "anyTpl" diff --git a/compiler/damlc/daml-stdlib-src/DA/Internal/Template.daml b/compiler/damlc/daml-stdlib-src/DA/Internal/Template.daml index 048c5359c5..95d358cc5c 100644 --- a/compiler/damlc/daml-stdlib-src/DA/Internal/Template.daml +++ b/compiler/damlc/daml-stdlib-src/DA/Internal/Template.daml @@ -105,11 +105,15 @@ class Template t => TemplateKey t k | t -> k where -- getting the contract instance. -- | The list of maintainers of a contract key. - maintainer : k -> [Party] + _maintainer : proxy t -> k -> [Party] _toAnyContractKey : proxy t -> k -> Any _fromAnyContractKey : proxy t -> Any -> Optional k +-- | The list of maintainers of a contract key. +maintainer : forall t k. TemplateKey t k => k -> [Party] +maintainer = _maintainer ([] : [t]) + toAnyContractKey : forall t k. TemplateKey t k => k -> AnyContractKey toAnyContractKey k = AnyContractKey @@ -148,8 +152,6 @@ data PostConsuming t = PostConsuming {} data Archive = Archive {} deriving (Eq, Show) -data HasKey t = HasKey {} - -- | Accepted ways to specify a list of parties: either a single party, or a list of parties. class IsParties a where -- | Convert to list of parties. diff --git a/compiler/damlc/daml-visual/src/DA/Daml/Visual.hs b/compiler/damlc/daml-visual/src/DA/Daml/Visual.hs index 80b7eb096e..8be514b416 100644 --- a/compiler/damlc/daml-visual/src/DA/Daml/Visual.hs +++ b/compiler/damlc/daml-visual/src/DA/Daml/Visual.hs @@ -145,12 +145,12 @@ startFromUpdate seen world update = case update of startFromExpr :: Set.Set (LF.Qualified LF.ExprValName) -> LF.World -> LF.Expr -> Set.Set Action startFromExpr seen world e = case e of LF.EVar _ -> Set.empty - -- NOTE(MH/RJR): Do not explore the `$fXInstance` dictionary because it - -- contains all the ledger actions and therefore creates too many edges + -- NOTE(MH/RJR): Do not explore the `$fChoice`/`$fTemplate` dictionaries because + -- they contain all the ledger actions and therefore creates too many edges -- in the graph. We instead detect calls to the `create`, `archive` and -- `exercise` methods from `Template` and `Choice` instances. LF.EVal (LF.Qualified _ _ (LF.ExprValName ref)) - | "$f" `T.isPrefixOf` ref && "Instance" `T.isSuffixOf` ref -> Set.empty + | any (`T.isPrefixOf` ref) ["$fChoice", "$fTemplate"] -> Set.empty LF.EVal ref -> case LF.lookupValue ref world of Right LF.DefValue{..} | ref `Set.member` seen -> Set.empty diff --git a/compiler/damlc/lib/DA/Cli/Damlc.hs b/compiler/damlc/lib/DA/Cli/Damlc.hs index 0b9b8f0ff8..727ae9a1c5 100644 --- a/compiler/damlc/lib/DA/Cli/Damlc.hs +++ b/compiler/damlc/lib/DA/Cli/Damlc.hs @@ -629,7 +629,8 @@ execInspect inFile outFile jsonOutput lvl = if jsonOutput then do - archive :: PLF.ArchivePayload <- errorOnLeft "Cannot decode archive" (PS.fromByteString bytes) + payloadBytes <- PLF.archivePayload <$> errorOnLeft "Cannot decode archive" (PS.fromByteString bytes) + archive :: PLF.ArchivePayload <- errorOnLeft "Cannot decode archive payload" $ PS.fromByteString payloadBytes writeOutputBSL outFile $ Aeson.Pretty.encodePretty $ Proto.JSONPB.toAesonValue archive diff --git a/compiler/damlc/tests/daml-test-files/ExerciseWithoutActors.daml b/compiler/damlc/tests/daml-test-files/ExerciseWithoutActors.daml index 43faacb045..8ec84eff2b 100644 --- a/compiler/damlc/tests/daml-test-files/ExerciseWithoutActors.daml +++ b/compiler/damlc/tests/daml-test-files/ExerciseWithoutActors.daml @@ -6,7 +6,7 @@ -- uses actors as a sanity check. -- @SINCE-LF 1.5 --- @QUERY-LF [.modules[] | .values[] | select(.name_with_type | lf::get_value_name($pkg) == ["$$fFooInstance"]) | .expr | .. | objects | select(has("exercise")) | .exercise | has("actor") | not] | (length > 0 and all) +-- @QUERY-LF [.modules[] | .values[] | select(.name_with_type | lf::get_value_name($pkg) == ["$$fChoiceFooBar$u0028$u0029"]) | .expr | .. | objects | select(has("exercise")) | .exercise | has("actor") | not] | (length > 0 and all) daml 1.2 module ExerciseWithoutActors where diff --git a/compiler/damlc/tests/daml-test-files/GenericTemplateError.daml b/compiler/damlc/tests/daml-test-files/GenericTemplateError.daml index dd5b68f6eb..cb9f092a37 100644 --- a/compiler/damlc/tests/daml-test-files/GenericTemplateError.daml +++ b/compiler/damlc/tests/daml-test-files/GenericTemplateError.daml @@ -1,7 +1,6 @@ -- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 --- @ERROR range=12:24-12:32; Generic templates are not supported anymore. --- @ERROR range=34:10-34:16; Generic templates are not supported anymore. +-- @ERROR range=11:24-11:34; Generic templates are no longer supported daml 1.2 module GenericTemplateError where diff --git a/compiler/damlc/tests/src/DA/Test/ShakeIdeClient.hs b/compiler/damlc/tests/src/DA/Test/ShakeIdeClient.hs index 7e134ab56c..617dcec31f 100644 --- a/compiler/damlc/tests/src/DA/Test/ShakeIdeClient.hs +++ b/compiler/damlc/tests/src/DA/Test/ShakeIdeClient.hs @@ -1165,7 +1165,7 @@ visualDamlTests = Tasty.testGroup "Visual Tests" setFilesOfInterest [fetchTest] expectNoErrors expectedGraph fetchTest ( ExpectedGraph {expectedSubgraphs = - [ExpectedSubGraph {expectedNodes = ["Create","Archive","ReducedCoin"] + [ExpectedSubGraph {expectedNodes = ["Create","ReducedCoin","Archive"] , expectedTplFields = ["owner","amount"] , expectedTemplate = "Coin"}] , expectedEdges = []}) @@ -1196,7 +1196,7 @@ visualDamlTests = Tasty.testGroup "Visual Tests" , expectedTplFields = ["owner"] , expectedTemplate = "Coin" } - , ExpectedSubGraph { expectedNodes = ["Create", "Archive", "Consume"] + , ExpectedSubGraph { expectedNodes = ["Create", "Consume", "Archive"] , expectedTplFields = ["owner"] , expectedTemplate = "TT"}] @@ -1224,12 +1224,13 @@ visualDamlTests = Tasty.testGroup "Visual Tests" setFilesOfInterest [createTest] expectNoErrors expectedGraph createTest (ExpectedGraph - {expectedSubgraphs = [ExpectedSubGraph {expectedNodes = ["Create","Archive"] + {expectedSubgraphs = [ExpectedSubGraph {expectedNodes = ["Create","CreateCoin","Archive"] + , expectedTplFields = ["owner"] + , expectedTemplate = "TT"} + ,ExpectedSubGraph {expectedNodes = ["Create","Archive"] , expectedTplFields = ["owner"] , expectedTemplate = "Coin"} - , ExpectedSubGraph {expectedNodes = ["Create","Archive","CreateCoin"] - , expectedTplFields = ["owner"] - , expectedTemplate = "TT"}] + ] , expectedEdges = [(ExpectedChoiceDetails {expectedConsuming = True, expectedName = "CreateCoin"} ,ExpectedChoiceDetails {expectedConsuming = False, expectedName = "Create"})]}) diff --git a/ghc-lib/template-desugaring.md b/ghc-lib/template-desugaring.md index 8140528852..70455e3917 100644 --- a/ghc-lib/template-desugaring.md +++ b/ghc-lib/template-desugaring.md @@ -19,13 +19,13 @@ template Iou with issuer : Party owner : Party - amount : Float + amount : Decimal regulators : [Party] where - ensure amount > 0 + ensure amount > 0.0 signatory issuer, owner observer regulators - agreement issuer <> " will pay " <> owner <> " " <> show amount + agreement show issuer <> " will pay " <> show owner <> " " <> show amount choice Transfer : ContractId Iou with @@ -67,70 +67,31 @@ data Transfer = Transfer with deriving (Eq, Show) ``` -Next we have a `class IouInstance` with the bulk of the definitions we will need. + +Next we have the instance of the `Template` typeclass: ```haskell -class IouInstance where - _signatoryIou : Iou -> [Party] - _signatoryIou this@Iou{..} = [issuer, owner] - _observerIou : Iou -> [Party] - _observerIou this@Iou{..} = regulators - _ensureIou : Iou -> Bool - _ensureIou this@Iou{..} = amount > 0.0 - _agreementIou : Iou -> Text - _agreementIou this@Iou{..} = show issuer <> " will pay " <> show owner <> " " <> show amount - _createIou : Iou -> Update (ContractId Iou) - _createIou = magic @"create" - _fetchIou : ContractId Iou -> Update Iou - _fetchIou = magic @"fetch" - _archiveIou : ContractId Iou -> Update () - _archiveIou cid = exerciseIouArchive cid Archive - _toAnyTemplateIou : Iou -> AnyTemplate - _toAnyTemplateIou = magic @"toAnyTemplate" - _fromAnyTemplateIou : AnyTemplate -> Optional Iou - _fromAnyTemplateIou = magic @"fromAnyTemplate" - - _consumptionIouArchive : PreConsuming Iou - _consumptionIouArchive = PreConsuming - _controllerIouArchive : Iou -> Archive -> [Party] - _controllerIouArchive this@Iou{..} arg@Archive = signatoryIou this - _actionIouArchive : ContractId Iou -> Iou -> Archive -> Update () - _actionIouArchive self this@Iou{..} arg@Archive = pure () - _exerciseIouArchive : ContractId Iou -> Archive -> Update () - _exerciseIouArchive = magic @"archive" - _toAnyChoiceIouArchive : proxy Iou -> Archive -> Any - _toAnyChoiceIouArchive = magic @"toAnyChoice" - _fromAnyChoiceIouArchive : proxy Iou -> Any -> Optional Archive - _fromAnyChoiceIouArchive = magic @"fromAnyChoice" - - _consumptionIouTransfer : PreConsuming Iou - _consumptionIouTransfer = PreConsuming - _controllerIouTransfer : Iou -> Transfer -> [Party] - _controllerIouTransfer this@Iou{..} arg@Transfer{..} = [owner] - _actionIouTransfer : ContractId Iou -> Iou -> Transfer -> Update (ContractId Iou) - _actionIouTransfer self this@Iou{..} arg@Transfer{..} = create this with owner = newOwner - _exerciseIouTransfer : ContractId Iou -> Transfer -> Update (ContractId Iou) - _exerciseIouTransfer = magic @"exercise" - _toAnyChoiceIouTransfer : proxy Iou -> Transfer -> Any - _toAnyChoiceIouTransfer = magic @"toAnyChoice" - _fromAnyChoiceIouTransfer : proxy Iou -> Any -> Optional Transfer - _fromAnyChoiceIouTransfer = magic @"fromAnyChoice" -``` - -With that class defined, we can define an `instance` declaration for `Iou` to declare its membership in `Template`: -```haskell -instance IouInstance => Template Iou where - signatory = _signatoryIou - observer = _observerIou - ensure = _ensureIou - agreement = _agreementIou - create = _createIou - fetch = _fetchIou - archive = _archiveIou - toAnyTemplate = _toAnyTemplate - fromAnyTemplate = _fromAnyTemplate - -instance IouInstance +instance Template Iou where + ensure this@Iou {..} = amount > 0.0 + agreement this@Iou {..} + = show issuer <> " will pay " <> show owner <> " " <> show amount + signatory this@Iou {..} + = concat + [concat + [toParties (owner), + toParties (issuer)]] + observer this@Iou {..} + = concat + [concat + [concat + [toParties (regulators)]]] + archive cid + = exercise cid Archive + create = magic @"create" + fetch = magic @"fetch" + toAnyTemplate = magic @"toAnyTemplate" + fromAnyTemplate = magic @"fromAnyTemplate" + _templateTypeRep = magic @"_templateTypeRep" ``` When a type `t` is a `Template` instance, `class Choice` (defined by the DAML standard library) defines a (multi-parameter type class) relation on types `t`, `c` and `r` such that `r` is uniquely determined by the pair `(t, c)`: @@ -148,9 +109,32 @@ The `instance` declaration establishes the triple `(Iou, Transfer, ContractId Io ```haskell instance Choice Iou Transfer (ContractId Iou) where - exercise = _exerciseIouTransfer - _toAnyChoice = _toAnyChoiceIouTransfer - _fromAnyChoice = _fromAnyChoiceIouTransfer + exercise = magic @"exerciseIouTransfer" + _toAnyChoice = magic @"toAnyChoiceIouTransfer" + _fromAnyChoice + = magic @"fromAnyChoiceIouTransfer" +``` + +Information about a choice that is not part of the `Choice` typeclass is recorded in a +separate top-level identifier. Specifically, this is a tuple containing the controller, +the choice body and information on whether the choice is pre-, post- or nonconsuming: + +``` +_choice_IouTransfer : + (Iou -> Transfer -> [Party], + ContractId Iou + -> Iou -> Transfer -> Update (ContractId Iou), + PreConsuming Iou) +_choice_IouTransfer + = (\ this@Iou {..} arg@Transfer {..} + -> let + in + concat + [toParties (owner)], + \ self this@Iou {..} arg@Transfer {..} + -> let + in do create (DA.Internal.Record.setField @"owner" newOwner this), + PreConsuming) ``` ### Example (2) @@ -163,6 +147,7 @@ class Template t => TemplateKey t k | t -> k where key : t -> k fetchByKey : k -> Update (ContractId t, t) lookupByKey : k -> Update (Optional (ContractId t)) + _maintainer : proxy t -> k -> [Party] _toAnyContractKey : proxy t -> k -> Any _fromAnyContractKey : proxy t -> Any -> Optional ks ``` @@ -200,211 +185,37 @@ data Enrollment = reg : Registration deriving (Show, Eq) -class EnrollmentInstance where - _signatoryEnrollment : Enrollment -> [Party] - _signatoryEnrollment this@Enrollment{..} = [reg.student, reg.course.institution] - _observerEnrollment : Enrollment -> [Party] - _observerEnrollment this@Enrollment{..} = [] - _ensureEnrollment : Enrollment -> Bool - _ensureEnrollment this@Enrollment{..} = True - _agreementEnrollment : Enrollment -> Text - _agreementEnrollment this@Enrollment{..} = "" - _createEnrollment : Enrollment -> Update (ContractId Enrollment) - _createEnrollment = magic @"create" - _fetchEnrollment : ContractId Enrollment -> Update Enrollment - _fetchEnrollment = magic @"fetch" - _archiveEnrollment : ContractId Enrollment -> Update () - _archiveEnrollment cid = exerciseEnrollmentArchive cid Archive - _toAnyTemplateEnrollment : Enrollment -> AnyTemplate - _toAnyTemplateEnrollment = magic @"toAnyTemplate" - _fromAnyTemplateEnrollment : AnyTemplate -> Optional Enrollment - _fromAnyTemplateEnrollment = magic @"fromAnyTemplate" - - _hasKeyEnrollment : HasKey Enrollment - _hasKeyEnrollment = HasKey - _keyEnrollment : Enrollment -> Registration - _keyEnrollment this@Enrollment{..} = reg - _maintainerEnrollment : HasKey Enrollment -> Registration -> [Party] - _maintainerEnrollment HasKey key = [key.course.institution] - _fetchByKeyEnrollment : Registration -> Update (ContractId Enrollment, Enrollment) - _fetchByKeyEnrollment = magic @"fetchByKey" - _lookupByKeyEnrollment : Registration -> Update (Optional (ContractId Enrollment)) - _lookupByKeyEnrollment = magic @"lookupByKey" - - _consumptionEnrollmentArchive : PreConsuming Enrollment - _consumptionEnrollmentArchive = PreConsuming - _controllerEnrollmentArchive : Enrollment -> Archive -> [Party] - _controllerEnrollmentArchive this@Enrollment{..} arg@Archive = signatoryEnrollment this - _actionEnrollmentArchive : ContractId Enrollment -> Enrollment -> Archive -> Update () - _actionEnrollmentArchive self this@Enrollment{..} arg@Archive = pure () - _exerciseEnrollmentArchive : ContractId Enrollment -> Archive -> Update () - _exerciseEnrollmentArchive = magic @"archive" - _toAnyChoiceEnrollmentArchive : proxy Enrollment -> Archive -> Any - _toAnyChoiceEnrollmentArchive = magic @"toAnyChoice" - _fromAnyChoiceEnrollmentArchive : proxy Enrollment -> Any -> Optional Archive - _fromAnyChoiceEnrollmentArchive = magic @"fromAnyChoice" - -instance EnrollmentInstance - -instance EnrollmentInstance => Template Enrollment where - signatory = _signatoryEnrollment - observer = _observerEnrollment - ensure = _ensureEnrollment - agreement = _agreementEnrollment - create = _createEnrollment - fetch = _fetchEnrollment - archive = _archiveEnrollment - toAnyTemplate = _toAnyTemplateEnrollment - fromAnyTemplate = _fromAnyTemplateEnrollment +instance Template Enrollment where + signatory this@Enrollment {..} + = concat + [concat + [toParties + ((DA.Internal.Record.getField + @"institution" (DA.Internal.Record.getField @"course" reg))), + toParties + ((DA.Internal.Record.getField @"student" reg))]] + observer this@Enrollment {..} = concat [] + ensure this@Enrollment {..} = True + agreement this@Enrollment {..} = "" + archive cid + = exercise cid Archive + create = magic @"create" + fetch = magic @"fetch" + toAnyTemplate = magic @"toAnyTemplate" + fromAnyTemplate = magic @"fromAnyTemplate" + _templateTypeRep = magic @"_templateTypeRep" instance TemplateKey Enrollment Registration where - key = _keyEnrollment - fetchByKey = _fetchByKeyEnrollment - lookupByKey = _lookupByKeyEnrollment - maintainer = _maintainerEnrollment (_hasKeyEnrollment : HasKey Enrollment) - _fromAnyContractKey = _fromAnyContractKeyEnrollment - _toAnyContractKey = _toAnyContractKeyEnrollment + key this@Enrollment {..} = reg + _maintainer _ key + = concat + [concat + [toParties + ((DA.Internal.Record.getField + @"institution" (DA.Internal.Record.getField @"course" key)))]] + fetchByKey = magic @"fetchByKey" + lookupByKey = magic @"lookupByKey" + _toAnyContractKey = magic @"_toAnyContractKey" + _fromAnyContractKey + = magic @"_fromAnyContractKey" ``` - -### Example (3) - -The final example shows a generic proposal template. - -```haskell -template Template t => Proposal t with - asset : t - receivers : [Party] - name : Text - where - signatory (signatory asset \\ receivers) - observer receivers - key (signatory this, name) - maintainer (fst key) - choice Accept : ContractId t - controller receivers - do - create asset -``` - -Notice that the `Proposal` template has a type argument `t` with a `Template` constraint preceding it. -We also specify a primary key for the Proposal template by combining data from the underlying template as well as the proposal. -This desugars to the following declarations. - -```haskell -data Proposal t = Proposal with - asset : t - receivers : [Party] - name : Party - deriving (Eq, Show) - -data Accept = Accept with - deriving (Eq, Show) - -class Template t => ProposalInstance t where - _signatoryProposal : Proposal t -> [Party] - _signatoryProposal this@Proposal{..} = signatory asset \\ receivers - _observerProposal : Proposal t -> [Party] - _observerProposal this@Proposal{..} = receivers - _ensureProposal : Proposal t -> Bool - _ensureProposal this@Proposal{..} = True - _agreementProposal : Proposal t -> Text - _agreementProposal this@Proposal{..} = "" - _createProposal : Proposal t -> Update (ContractId (Proposal t)) - _createProposal = magic @"create" - _fetchProposal : ContractId (Proposal t) -> Update (Proposal t) - _fetchProposal = magic @"fetch" - _archiveProposal : ContractId (Proposal t) -> Update () - _archiveProposal cid = exerciseProposalArchive cid Archive - _toAnyTemplateProposal : Proposal t -> AnyTemplate - _toAnyTemplateProposal = magic @"toAnyTemplate" - _fromAnyTemplateProposal : AnyTemplate -> Optional (Proposal t) - _fromAnyTemplateProposal = magic @"fromAnyTemplate" - - _hasKeyProposal : HasKey (Proposal t) - _hasKeyProposal = HasKey - _keyProposal : Proposal t -> ([Party], Text) - _keyProposal this@Proposal{..} = (signatory this, name) - _maintainerProposal : HasKey (Proposal t) -> ([Party], Text) -> [Party] - _maintainerProposal HasKey key = fst key - _fetchByKeyProposal : ([Party], Text) -> Update (ContractId (Proposal t), Proposal t) - _fetchByKeyProposal = magic @"fetchByKey" - _lookupByKeyProposal : ([Party], Text) -> Update (Optional (ContractId (Proposal t))) - _lookupByKeyProposal = magic @"lookupByKey" - - _consumptionProposalArchive : PreConsuming (Proposal t) - _consumptionProposalArchive = PreConsuming - _controllerProposalArchive : Proposal t -> Archive -> [Party] - _controllerProposalArchive this@Proposal{..} arg@Archive = signatoryProposal this - _actionProposalArchive : ContractId (Proposal t) -> Proposal t -> Archive -> Update () - _actionProposalArchive self this@Proposal{..} arg@Archive = pure () - _exerciseProposalArchive : ContractId (Proposal t) -> Archive -> Update () - _exerciseProposalArchive = magic @"archive" - _toAnyChoiceProposalArchive : proxy (Proposal t) -> Archive -> Any - _toAnyChoiceProposalArchive = magic @"toAnyChoice" - _fromAnyChoiceProposalArchive : proxy (Proposal t) -> Any -> Optional Archive - _fromAnyChoiceProposalArchive = magic @"fromAnyChoice" - - _consumptionProposalAccept : PreConsuming (Proposal t) - _consumptionProposalAccept = PreConsuming - _controllerProposalAccept : Proposal t -> Accept -> [Party] - _controllerProposalAccept this@Proposal{..} arg@Accept = receivers - _actionProposalAccept : ContractId (Proposal t) -> Proposal t -> Accept -> Update (ContractId t) - _actionProposalAccept self this@Proposal{..} arg@Accept = do - create asset - _exerciseProposalAccept : ContractId (Proposal t) -> Accept -> Update (ContractId t) - _exerciseProposalAccept = magic @"exercise" - _toAnyChoiceProposalAccept : proxy (Proposal t) -> Accept -> Any - _toAnyChoiceProposalAccept = magic @"toAnyChoice" - _fromAnyChoiceProposalAccept : proxy (Proposal t) -> Any -> Optional Accept - _fromAnyChoiceProposalAccept = magic @"fromAnyChoice" - -instance ProposalInstance t => Template (Proposal t) where - signatory = _signatoryProposal - observer = _observerProposal - ensure = _ensureProposal - agreement = _agreementProposal - create = _createProposal - fetch = _fetchProposal - archive = _archiveProposal - toAnyTemplate = _toAnyTemplate - fromAnyTemplate = _fromAnyTemplate - -instance ProposalInstance t => TemplateKey (Proposal t) ([Party], Text) where - key = _keyProposal - fetchByKey = _fetchByKeyProposal - lookupByKey = _lookupByKeyProposal - _toAnyContractKey = _toAnyContractKeyProposal - _fromAnyContractKey = _fromAnyContractKeyProposal - -instance ProposalInstance t => Choice (Proposal t) Accept (ContractId t) where - exercise = _exerciseProposalAccept - _toAnyChoice = _toAnyChoiceProposalAccept - _fromAnyChoice = _fromAnyChoiceProposalAccept - -instance ProposalInstance t => Choice (Proposal t) Archive () where - exercise = exerciseProposalArchive - _toAnyChoice = _toAnyChoiceProposalArchive - _fromAnyChoice = _fromAnyChoiceProposalArchive -``` - -### Example (3)(cont) - -We showed the generic proposal template above, but have not showed what an instance looks like. -Let's instantiate the `Proposal` template with the `Iou` (concrete) template from Example 1. -This is done using the syntax below. - -```haskell -template instance ProposalIou = Proposal Iou -``` - -This allows us to create and exercise choices on a proposal contract instantiated to an Iou contract. -The name `ProposalIou` is not needed in DAML code but is required when creating contracts via the Ledger API -(as client languages may not be able to express generic template and type instantiation). -The `template instance` desugars to the following declarations. - -```haskell -type ProposalIou = Proposal Iou -instance ProposalInstance Iou -``` - -The `instance` here simply leverages the implementation of the `ProposalInstance` class. diff --git a/stack-snapshot.yaml b/stack-snapshot.yaml index 948c912d23..1d40527a75 100644 --- a/stack-snapshot.yaml +++ b/stack-snapshot.yaml @@ -1,11 +1,9 @@ resolver: lts-14.1 packages: - - archive: http://digitalassetsdk.bintray.com/ghc-lib/ghc-lib-parser-8.8.1.20191120.tar.gz - sha256: "89e5e8eadd66a90970b866a0669da28b1cd4fff2511a2dc09151a5b269bc0bc1" - size: 1574480 - - archive: http://digitalassetsdk.bintray.com/ghc-lib/ghc-lib-8.8.1.20191120.tar.gz - sha256: "2433176141caffd066313876ef756e2fcb34dc96a809d40eec753a4248ba016e" - size: 2716868 + - archive: http://digitalassetsdk.bintray.com/ghc-lib/ghc-lib-parser-8.8.1.20191129.tar.gz + sha256: "c4a322af6a89d83b1b40038c9877ce7e02b2970c9aae22c1bc7b0b04d0c95ed5" + - archive: http://digitalassetsdk.bintray.com/ghc-lib/ghc-lib-8.8.1.20191129.tar.gz + sha256: "d71eec8f281967a82501ec887187ebfbcda87c5486cc1d8f631247bc537e5102" - github: digital-asset/hlint commit: "951fdb6d28d7eed8ea1c7f3be69da29b61fcbe8f" sha256: "f5fb4cf98cde3ecf1209857208369a63ba21b04313d570c41dffe9f9139a1d34"