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

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

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"

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"

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