LF conversion of templates under new rules (WIP). (digital-asset#4030)

* Patterns and test for new desugaring * working on new template conversion * Update ghc-lib changelog_begin changelog_end * shut up hlint * Update desugar stdlib * update test * remove unuseful templatebinds * Add implicit qualified GHC.Types import * Add missing primitives * Remove chaff * update comments * Remove patterns that dont seem useful anymore * Capture key data in template binds * Dont make TypeRep/ToAny/FromAny classes conditional * Remove some unnecessary TODOs * Generate the template definition * Remove new template desugaring test * Fix jq query * Rename makeDesugarDFunProjection to useSingleMethodDict * Let TTypeRep and TAny be TUnit in primitives. * Fix damlc visual wrt the new desugaring * Fix visualization tests in shake test suite * Fix damldocs * Drop envTemplateKeyData * Use the new ghc-lib release Co-authored-by: Moritz Kiefer <moritz.kiefer@purelyfunctional.org>
FlashSheridan · Jan 15, 2020 · 5d30408 · 5d30408
1 parent 2dcf3f8
commit 5d30408
Show file tree

Hide file tree

Showing 10 changed files with 407 additions and 300 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
@@ -549,8 +549,7 @@ isTemplate ClsInstDecl{..}
   , HsAppTy _ (L _ t1) t2 <- ty
   , HsTyVar _ _ (L _ tmplClass) <- t1
   , Just (L _ tmplName) <- hsTyGetAppHead_maybe t2
-  , toText tmplClass == "DA.Internal.Desugar.Template"
-  || toText tmplClass == "Template" -- temporary for generic templates
+  , toText tmplClass == "DA.Internal.Desugar.HasCreate"
   = Just (Typename . packRdrName $ tmplName)
 
   | otherwise = Nothing
@@ -568,8 +567,7 @@ isChoice ClsInstDecl{..}
   , HsTyVar _ _ (L _ choiceClass) <- choice
   , Just (L _ choiceName) <- hsTyGetAppHead_maybe cName
   , Just (L _ tmplName) <- hsTyGetAppHead_maybe cTmpl
-  , toText choiceClass == "DA.Internal.Desugar.Choice"
-  || toText choiceClass == "Choice" -- temporary for generic templates
+  , toText choiceClass == "DA.Internal.Desugar.HasExercise"
   = Just (Typename . packRdrName $ tmplName, Typename . packRdrName $ choiceName)
 
   | otherwise = Nothing

diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/Primitives.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/Primitives.hs
@@ -254,13 +254,110 @@ convertPrim _ "BETextReplicate" (TInt64 :-> TText :-> TText) = EBuiltin BETextRe
 convertPrim _ "BETextSplitOn" (TText :-> TText :-> TList TText) = EBuiltin BETextSplitOn
 convertPrim _ "BETextIntercalate" (TText :-> TList TText :-> TText) = EBuiltin BETextIntercalate
 
+-- Template Desugaring.
+
+convertPrim _ "UCreate" (TCon template :-> TUpdate (TContractId (TCon template')))
+    | template == template' =
+    ETmLam (mkVar "this", TCon template) $
+    EUpdate $ UCreate template (EVar (mkVar "this"))
+
+convertPrim _ "UFetch" (TContractId (TCon template) :-> TUpdate (TCon template'))
+    | template == template' =
+    ETmLam (mkVar "this", TContractId (TCon template)) $
+    EUpdate $ UFetch template (EVar (mkVar "this"))
+
+convertPrim _ "UExercise"
+    (TContractId (TCon template) :-> TCon choice :-> TUpdate _returnTy) =
+    ETmLam (mkVar "this", TContractId (TCon template)) $
+    ETmLam (mkVar "arg", TCon choice) $
+    EUpdate $ UExercise template choiceName (EVar (mkVar "this")) Nothing (EVar (mkVar "arg"))
+  where
+    choiceName = ChoiceName (T.intercalate "." $ unTypeConName $ qualObject choice)
+
+convertPrim _ "ULookupByKey" (key :-> TUpdate (TOptional (TContractId (TCon template)))) =
+    ETmLam (mkVar "key", key) $ EUpdate $
+        ULookupByKey $ RetrieveByKey template (EVar $ mkVar "key")
+
+convertPrim _ "UFetchByKey"
+    (key :-> TUpdate ty@(TApp (TApp (TCon tuple) ty1@(TContractId (TCon template))) ty2))
+    | ty2 == TCon template =
+    ETmLam (mkVar "key", key) $
+    EUpdate $ UBind
+        (Binding (mkVar "res", TStruct
+            [ (FieldName "contractId", ty1)
+            , (FieldName "contract", ty2)])
+            (EUpdate $ UFetchByKey (RetrieveByKey template (EVar $ mkVar "key"))))
+        (EUpdate $ UPure ty $ ERecCon (TypeConApp tuple [ty1, ty2])
+            [ (mkIndexedField 1, EStructProj (FieldName "contractId") (EVar (mkVar "res")))
+            , (mkIndexedField 2, EStructProj (FieldName "contract") (EVar (mkVar "res")))
+            ])
+
+convertPrim version "ETemplateTypeRep"
+    ty@(TApp proxy (TCon template) :-> tTypeRep)
+    | tTypeRep `elem` [TTypeRep, TUnit] =
+    -- TODO: restrict to known templates
+    whenRuntimeSupports version featureTypeRep ty $
+        ETmLam (mkVar "_", TApp proxy (TCon template)) $
+        ETypeRep (TCon template)
+
+convertPrim version "EFromAnyTemplate"
+    ty@(tAny :-> TOptional (TCon template))
+    | tAny `elem` [TAny, TUnit] =
+    -- TODO: restrict to known templates
+    whenRuntimeSupports version featureAnyType ty $
+        ETmLam (mkVar "any", TAny) $
+        EFromAny (TCon template) (EVar $ mkVar "any")
+
+convertPrim version "EFromAnyChoice"
+    ty@(TApp proxy (TCon template) :-> tAny :-> TOptional choice)
+    | tAny `elem` [TAny, TUnit] =
+    -- TODO: restrict to known template/choice pairs
+    whenRuntimeSupports version featureAnyType ty $
+        ETmLam (mkVar "_", TApp proxy (TCon template)) $
+        ETmLam (mkVar "any", TAny) $
+        EFromAny choice (EVar $ mkVar "any")
+
+convertPrim version "EFromAnyContractKey"
+    ty@(TApp proxy (TCon template) :-> tAny :-> TOptional key)
+    | tAny `elem` [TAny, TUnit] =
+    -- TODO: restrict to known template/key pairs
+    whenRuntimeSupports version featureAnyType ty $
+        ETmLam (mkVar "_", TApp proxy (TCon template)) $
+        ETmLam (mkVar "any", TAny) $
+        EFromAny key (EVar $ mkVar "any")
+
+convertPrim version "EToAnyTemplate"
+    ty@(TCon template :-> tAny)
+    | tAny `elem` [TAny, TUnit] =
+    -- TODO: restrict to known templates
+    whenRuntimeSupports version featureAnyType ty $
+        ETmLam (mkVar "template", TCon template) $
+        EToAny (TCon template) (EVar $ mkVar "template")
+
+convertPrim version "EToAnyChoice"
+    ty@(TApp proxy (TCon template) :-> choice :-> tAny)
+    | tAny `elem` [TAny, TUnit] =
+    -- TODO: restrict to known template/choice pairs
+    whenRuntimeSupports version featureAnyType ty $
+        ETmLam (mkVar "_", TApp proxy (TCon template)) $
+        ETmLam (mkVar "choice", choice) $
+        EToAny choice (EVar $ mkVar "choice")
+
+convertPrim version "EToAnyContractKey"
+    ty@(TApp proxy (TCon template) :-> key :-> tAny)
+    | tAny `elem` [TAny, TUnit] =
+    -- TODO: restrict to known template/key pairs
+    whenRuntimeSupports version featureAnyType ty $
+        ETmLam (mkVar "_", TApp proxy (TCon template)) $
+        ETmLam (mkVar "key", key) $
+        EToAny key (EVar $ mkVar "key")
+
+-- Unknown primitive.
 convertPrim _ x ty = error $ "Unknown primitive " ++ show x ++ " at type " ++ renderPretty ty
 
 -- | Some builtins are only supported in specific versions of DAML-LF.
--- Since we don't have conditional compilation in daml-stdlib, we compile
--- them to calls to `error` in unsupported versions.
-_whenRuntimeSupports :: Version -> Feature -> Type -> Expr -> Expr
-_whenRuntimeSupports version feature t e
+whenRuntimeSupports :: Version -> Feature -> Type -> Expr -> Expr
+whenRuntimeSupports version feature t e
     | version `supports` feature = e
     | otherwise = runtimeUnsupported feature t
 

diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/UtilGHC.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/UtilGHC.hs
@@ -18,6 +18,7 @@ module DA.Daml.LFConversion.UtilGHC(
 
 import "ghc-lib" GHC hiding (convertLit)
 import "ghc-lib" GhcPlugins as GHC hiding (fst3, (<>))
+import "ghc-lib-parser" Class as GHC
 
 import Data.Generics.Uniplate.Data
 import Data.Maybe
@@ -92,13 +93,73 @@ pattern GHC_Tuple <- ModuleIn DamlPrim "GHC.Tuple"
 pattern GHC_Types <- ModuleIn DamlPrim "GHC.Types"
 
 -- daml-stdlib module patterns
-pattern DA_Action, DA_Generics, DA_Internal_LF, DA_Internal_Prelude, DA_Internal_Record, DA_Internal_Desugar :: GHC.Module
+pattern DA_Action, DA_Generics, DA_Internal_LF, DA_Internal_Prelude, DA_Internal_Record, DA_Internal_Desugar, DA_Internal_Template_Functions :: GHC.Module
 pattern DA_Action <- ModuleIn DamlStdlib "DA.Action"
 pattern DA_Generics <- ModuleIn DamlStdlib "DA.Generics"
 pattern DA_Internal_LF <- ModuleIn DamlStdlib "DA.Internal.LF"
 pattern DA_Internal_Prelude <- ModuleIn DamlStdlib "DA.Internal.Prelude"
 pattern DA_Internal_Record <- ModuleIn DamlStdlib "DA.Internal.Record"
 pattern DA_Internal_Desugar <- ModuleIn DamlStdlib "DA.Internal.Desugar"
+pattern DA_Internal_Template_Functions <- ModuleIn DamlStdlib "DA.Internal.Template.Functions"
+
+-- | Deconstruct a dictionary function (DFun) identifier into a tuple
+-- containing, in order:
+--   1. the foralls
+--   2. the dfun arguments (i.e. the instances it depends on)
+--   3. the type class
+--   4. the type class arguments
+splitDFunId :: GHC.Var -> Maybe ([GHC.TyCoVar], [GHC.Type], GHC.Class, [GHC.Type])
+splitDFunId v
+    | DFunId _ <- idDetails v
+    , (tyCoVars, ty1) <- splitForAllTys (varType v)
+    , (dfunArgs, ty2) <- splitFunTys ty1
+    , Just (tyCon, tyClsArgs) <- splitTyConApp_maybe ty2
+    , Just tyCls <- tyConClass_maybe tyCon
+    = Just (tyCoVars, dfunArgs, tyCls, tyClsArgs)
+
+    | otherwise
+    = Nothing
+
+-- | Pattern for template desugaring DFuns.
+pattern DesugarDFunId :: [GHC.TyCoVar] -> [GHC.Type] -> FastString -> [GHC.Type] -> GHC.Var
+pattern DesugarDFunId tyCoVars dfunArgs clsName classArgs <-
+    (splitDFunId -> Just
+        ( tyCoVars
+        , dfunArgs
+        , GHC.className -> NameIn DA_Internal_Template_Functions clsName
+        , classArgs
+        )
+    )
+
+pattern HasSignatoryDFunId, HasEnsureDFunId, HasAgreementDFunId, HasObserverDFunId,
+    HasArchiveDFunId :: TyCon -> GHC.Var
+
+pattern HasSignatoryDFunId templateTyCon <-
+    DesugarDFunId [] [] "HasSignatory"
+        [splitTyConApp_maybe -> Just (templateTyCon, [])]
+pattern HasEnsureDFunId templateTyCon <-
+    DesugarDFunId [] [] "HasEnsure"
+        [splitTyConApp_maybe -> Just (templateTyCon, [])]
+pattern HasAgreementDFunId templateTyCon <-
+    DesugarDFunId [] [] "HasAgreement"
+        [splitTyConApp_maybe -> Just (templateTyCon, [])]
+pattern HasObserverDFunId templateTyCon <-
+    DesugarDFunId [] [] "HasObserver"
+        [splitTyConApp_maybe -> Just (templateTyCon, [])]
+pattern HasArchiveDFunId templateTyCon <-
+    DesugarDFunId [] [] "HasArchive"
+        [splitTyConApp_maybe -> Just (templateTyCon, [])]
+
+pattern HasKeyDFunId, HasMaintainerDFunId :: TyCon -> Type -> GHC.Var
+
+pattern HasKeyDFunId templateTyCon keyTy <-
+    DesugarDFunId [] [] "HasKey"
+        [ splitTyConApp_maybe -> Just (templateTyCon, [])
+        , keyTy ]
+pattern HasMaintainerDFunId templateTyCon keyTy <-
+    DesugarDFunId [] [] "HasMaintainer"
+        [ splitTyConApp_maybe -> Just (templateTyCon, [])
+        , keyTy ]
 
 -- | Break down a constraint tuple projection function name
 -- into an (index, arity) pair. These names have the form

diff --git a/compiler/damlc/daml-preprocessor/src/DA/Daml/Preprocessor.hs b/compiler/damlc/daml-preprocessor/src/DA/Daml/Preprocessor.hs
@@ -93,6 +93,7 @@ importDamlPreprocessor = fmap onModule
     where
         onModule y = y {
           GHC.hsmodImports =
+            newImport True "GHC.Types" :
             newImport True "DA.Internal.Desugar" :
             newImport False "DA.Internal.RebindableSyntax" : GHC.hsmodImports y
           }