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

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
 
 

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]

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

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

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"
 

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.

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

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

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
 

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

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"})]})
 

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.

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"