From dcbb398cae38434d187da5abc23043a0e732c18e Mon Sep 17 00:00:00 2001
From: Sofia Faro <sofia.faro@digitalasset.com>
Date: Mon, 31 Jan 2022 09:33:34 +0000
Subject: [PATCH] Typecheck experimental primitives in damlc (#12650)

Adds a check that experimental primitive is defined in damlc, before you can use it.

This is only for the Haskell side, and only intended so we can catch bugs in the compiler more easily. (It would have caught the bug where `observer` wasn't defined correctly in LFConversion.)

I also removed RESOLVE_VIRTUAL_CREATE since we're not using it anywhere, it has been superseded by UCreateInterface.

changelog_begin
changelog_end
---
 .../src/DA/Daml/LF/TypeChecker/Check.hs       | 20 ++++++++++++++++---
 .../src/DA/Daml/LF/TypeChecker/Error.hs       |  3 +++
 .../daml-test-files/ExperimentalCheck.daml    | 11 ++++++++++
 .../daml/lf/speedy/SBuiltin.scala             |  1 -
 4 files changed, 31 insertions(+), 4 deletions(-)
 create mode 100644 compiler/damlc/tests/daml-test-files/ExperimentalCheck.daml

diff --git a/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs b/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs
index 0bab2cf2a9ea..5353ea6813a1 100644
--- a/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs
+++ b/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Check.hs
@@ -47,6 +47,7 @@ import           Data.Maybe (listToMaybe)
 import qualified Data.Map.Strict as Map
 import qualified Data.NameMap as NM
 import qualified Data.IntSet as IntSet
+import qualified Data.Text as T
 import           Safe.Exact (zipExactMay)
 
 import           DA.Daml.LF.Ast
@@ -767,7 +768,20 @@ typeOf' = \case
   EUpdate upd -> typeOfUpdate upd
   EScenario scen -> typeOfScenario scen
   ELocation _ expr -> typeOf' expr
-  EExperimental _ ty -> pure ty
+  EExperimental name ty -> do
+    checkFeature featureExperimental
+    checkExperimentalType name ty
+    pure ty
+
+checkExperimentalType :: MonadGamma m => T.Text -> Type -> m ()
+checkExperimentalType "ANSWER" (TUnit :-> TInt64) = pure ()
+checkExperimentalType "TO_TYPE_REP" (TCon _iface :-> TTypeRep) = pure ()
+checkExperimentalType "RESOLVE_VIRTUAL_SIGNATORY"
+  (TCon iface1 :-> TCon iface2 :-> TList TParty) | iface1 == iface2 = pure ()
+checkExperimentalType "RESOLVE_VIRTUAL_OBSERVER"
+  (TCon iface1 :-> TCon iface2 :-> TList TParty) | iface1 == iface2 = pure ()
+checkExperimentalType name ty =
+  throwWithContext (EUnknownExperimental name ty)
 
 typeOf :: MonadGamma m => Expr -> m Type
 typeOf expr = do
@@ -932,8 +946,8 @@ checkIfaceImplementation Template{tplImplements} tplTcon TemplateImplements{..}
       Just InterfaceMethod{ifmType} ->
         checkExpr tpiMethodExpr (TCon tplTcon :-> ifmType)
 
-_checkFeature :: MonadGamma m => Feature -> m ()
-_checkFeature feature = do
+checkFeature :: MonadGamma m => Feature -> m ()
+checkFeature feature = do
     version <- getLfVersion
     unless (version `supports` feature) $
         throwWithContext $ EUnsupportedFeature feature
diff --git a/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs b/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs
index 443e7b786d45..c22594a9e5d2 100644
--- a/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs
+++ b/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Error.hs
@@ -147,6 +147,7 @@ data Error
   | EUnknownInterfaceMethod !TypeConName !(Qualified TypeConName) !MethodName
   | ETemplateDoesNotImplementInterface !(Qualified TypeConName) !(Qualified TypeConName)
   | EWrongInterfaceRequirement !(Qualified TypeConName) !(Qualified TypeConName)
+  | EUnknownExperimental !T.Text !Type
 
 contextLocation :: Context -> Maybe SourceLoc
 contextLocation = \case
@@ -432,6 +433,8 @@ instance Pretty Error where
       "Template " <> pretty tpl <> " does not implement interface " <> pretty iface
     EWrongInterfaceRequirement requiringIface requiredIface ->
       "Interface " <> pretty requiringIface <> " does not require interface " <> pretty requiredIface
+    EUnknownExperimental name ty ->
+      "Unknown experimental primitive " <> string (show name) <> " : " <> pretty ty
 
 prettyConsuming :: Bool -> Doc ann
 prettyConsuming consuming = if consuming then "consuming" else "non-consuming"
diff --git a/compiler/damlc/tests/daml-test-files/ExperimentalCheck.daml b/compiler/damlc/tests/daml-test-files/ExperimentalCheck.daml
new file mode 100644
index 000000000000..d4db233bc92f
--- /dev/null
+++ b/compiler/damlc/tests/daml-test-files/ExperimentalCheck.daml
@@ -0,0 +1,11 @@
+-- Copyright (c) 2022, Digital Asset (Switzerland) GmbH and/or its affiliates.
+-- SPDX-License-Identifier: Apache-2.0
+
+-- @SINCE-LF-FEATURE DAML_EXPERIMENTAL
+-- @ERROR Unknown experimental primitive "DOES_NOT_EXIST" : Unit
+
+-- | Check that experimental primitives are verified in damlc.
+module ExperimentalCheck where
+
+test : ()
+test = GHC.Types.primitive @"$DOES_NOT_EXIST"
diff --git a/daml-lf/interpreter/src/main/scala/com/digitalasset/daml/lf/speedy/SBuiltin.scala b/daml-lf/interpreter/src/main/scala/com/digitalasset/daml/lf/speedy/SBuiltin.scala
index 343d9a105fd3..aa00f261de1e 100644
--- a/daml-lf/interpreter/src/main/scala/com/digitalasset/daml/lf/speedy/SBuiltin.scala
+++ b/daml-lf/interpreter/src/main/scala/com/digitalasset/daml/lf/speedy/SBuiltin.scala
@@ -1850,7 +1850,6 @@ private[lf] object SBuiltin {
       List(
         "ANSWER" -> SBExperimentalAnswer,
         "TO_TYPE_REP" -> SBExperimentalToTypeRep,
-        "RESOLVE_VIRTUAL_CREATE" -> new SBResolveVirtual(CreateDefRef),
         "RESOLVE_VIRTUAL_SIGNATORY" -> new SBResolveVirtual(SignatoriesDefRef),
         "RESOLVE_VIRTUAL_OBSERVER" -> new SBResolveVirtual(ObserversDefRef),
       ).view.map { case (name, builtin) => name -> compileTime.SEBuiltin(builtin) }.toMap