Add Any type and to_any/from_any primitives to protobuf (digital-asse…

…t#2930) * Add Any type and to_any/from_any primitives to protobuf Following a suggestion by Rémy, the protobuf representation is more general and is associated with an arbitrary type instead of a typecon. This allows us to easily extend this later to a full Any type. I’ve still called the type in the protobuf Any instead of Haskell’s Dynamic since I find AnyTemplate more clear than DynamicTemplate and having AnyTemplate and Dynamic seems confusing. Right now, the decoder enforces that the type is a TypeCon. * Fix some mistakes in the spec * Update daml-lf/spec/daml-lf-1.rst Co-Authored-By: Remy <remy.haemmerle@daml.com> * Update daml-lf/spec/daml-lf-1.rst Co-Authored-By: Remy <remy.haemmerle@daml.com> * Update daml-lf/spec/daml-lf-1.rst Co-Authored-By: Remy <remy.haemmerle@daml.com> * Update daml-lf/spec/daml-lf-1.rst Co-Authored-By: Remy <remy.haemmerle@daml.com> * Add evaluation rule for to_any_template * Update daml-lf/spec/daml-lf-1.rst Co-Authored-By: Remy <remy.haemmerle@daml.com>
TuranDev · Sep 17, 2019 · 36e95f6 · 36e95f6
1 parent 7c4cc96
commit 36e95f6
Show file tree

Hide file tree

Showing 25 changed files with 204 additions and 27 deletions.
diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Base.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Base.hs
@@ -154,6 +154,7 @@ data BuiltinType
   | BTOptional
   | BTMap
   | BTArrow
+  | BTAnyTemplate
   deriving (Eq, Data, Generic, NFData, Ord, Show)
 
 -- | Type as used in typed binders.
@@ -437,6 +438,14 @@ data Expr
   | ENone
     { noneType :: !Type
     }
+  | EToAnyTemplate
+    { toAnyTemplateTemplate :: !(Qualified TypeConName)
+    , toAnyTemplateBody :: !Expr
+    }
+  | EFromAnyTemplate
+    { fromAnyTemplateTemplate :: !(Qualified TypeConName)
+    , fromAnyTemplateBody :: !Expr
+    }
   -- | Update expression.
   | EUpdate !Update
   -- | Scenario expression.

diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Pretty.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Pretty.hs
@@ -133,6 +133,7 @@ instance Pretty BuiltinType where
     BTOptional -> "Optional"
     BTMap -> "Map"
     BTArrow -> "(->)"
+    BTAnyTemplate -> "AnyTemplate"
 
 prettyRecord :: (Pretty a) =>
   PrettyLevel -> Doc ann -> [(FieldName, a)] -> Doc ann
@@ -443,6 +444,8 @@ instance Pretty Expr where
         | otherwise -> pPrintPrec lvl prec x
     ESome typ body -> prettyAppKeyword lvl prec "some" [TyArg typ, TmArg body]
     ENone typ -> prettyAppKeyword lvl prec "none" [TyArg typ]
+    EToAnyTemplate tpl body -> prettyAppKeyword lvl prec "to_any_template" [tplArg tpl, TmArg body]
+    EFromAnyTemplate tpl body -> prettyAppKeyword lvl prec "from_any_template" [tplArg tpl, TmArg body]
 
 instance Pretty DefDataType where
   pPrintPrec lvl _prec (DefDataType mbLoc tcon (IsSerializable serializable) params dataCons) =

diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Recursive.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Recursive.hs
@@ -43,6 +43,8 @@ data ExprF expr
   | ELocationF   !SourceLoc !expr
   | ENoneF       !Type
   | ESomeF       !Type !expr
+  | EToAnyTemplateF !(Qualified TypeConName) !expr
+  | EFromAnyTemplateF !(Qualified TypeConName) !expr
   deriving (Foldable, Functor, Traversable)
 
 data BindingF expr = BindingF !(ExprVarName, Type) !expr
@@ -172,6 +174,8 @@ instance Recursive Expr where
     ELocation   a b   -> ELocationF     a b
     ENone       a     -> ENoneF         a
     ESome       a b   -> ESomeF         a b
+    EToAnyTemplate a b  -> EToAnyTemplateF a b
+    EFromAnyTemplate a b -> EFromAnyTemplateF a b
 
 instance Corecursive Expr where
   embed = \case
@@ -199,3 +203,5 @@ instance Corecursive Expr where
     ELocationF   a b   -> ELocation a b
     ENoneF       a     -> ENone a
     ESomeF       a b   -> ESome a b
+    EToAnyTemplateF a b  -> EToAnyTemplate a b
+    EFromAnyTemplateF a b -> EFromAnyTemplate a b
diff --git a/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/DecodeV1.hs b/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/DecodeV1.hs
@@ -373,6 +373,20 @@ decodeExprSum exprSum = mayDecode "exprSum" exprSum $ \case
     bodyType <- mayDecode "expr_OptionalSomeType" mbType decodeType
     bodyExpr <- mayDecode "expr_OptionalSomeBody" mbBody decodeExpr
     return (ESome bodyType bodyExpr)
+  LF1.ExprSumToAny (LF1.Expr_ToAny mbType mbExpr) -> do
+    type' <- mayDecode "expr_ToAnyType" mbType decodeType
+    case type' of
+        TCon con -> do
+            expr <- mayDecode "expr_ToAnyExpr" mbExpr decodeExpr
+            return (EToAnyTemplate con expr)
+        _ -> throwError (ExpectedTCon type')
+  LF1.ExprSumFromAny (LF1.Expr_FromAny mbType mbExpr) -> do
+    type' <- mayDecode "expr_FromAnyType" mbType decodeType
+    case type' of
+        TCon con -> do
+            expr <- mayDecode "expr_FromAnyExpr" mbExpr decodeExpr
+            return (EFromAnyTemplate con expr)
+        _ -> throwError (ExpectedTCon type')
 
 decodeUpdate :: LF1.Update -> DecodeImpl Expr
 decodeUpdate LF1.Update{..} = mayDecode "updateSum" updateSum $ \case
@@ -530,6 +544,7 @@ decodePrim = pure . \case
   LF1.PrimTypeOPTIONAL -> BTOptional
   LF1.PrimTypeMAP -> BTMap
   LF1.PrimTypeARROW -> BTArrow
+  LF1.PrimTypeANY -> BTAnyTemplate
 
 decodeType :: LF1.Type -> DecodeImpl Type
 decodeType LF1.Type{..} = mayDecode "typeSum" typeSum $ \case

diff --git a/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/EncodeV1.hs b/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/EncodeV1.hs
@@ -156,6 +156,7 @@ encodeBuiltinType _version = P.Enumerated . Right . \case
     BTMap -> P.PrimTypeMAP
     BTArrow -> P.PrimTypeARROW
     BTNumeric -> P.PrimTypeNUMERIC
+    BTAnyTemplate -> P.PrimTypeANY
 
 encodeType' :: EncodeCtx -> Type -> P.Type
 encodeType' encctx@EncodeCtx{..} typ = P.Type . Just $
@@ -379,6 +380,8 @@ encodeExpr' encctx@EncodeCtx{..} = \case
     in P.Expr (Just $ encodeSourceLoc interned loc) esum
   ENone typ -> expr (P.ExprSumOptionalNone (P.Expr_OptionalNone (encodeType encctx typ)))
   ESome typ body -> expr (P.ExprSumOptionalSome (P.Expr_OptionalSome (encodeType encctx typ) (encodeExpr encctx body)))
+  EToAnyTemplate tpl body -> expr (P.ExprSumToAny (P.Expr_ToAny (encodeType encctx (TCon tpl)) (encodeExpr encctx body)))
+  EFromAnyTemplate tpl body -> expr (P.ExprSumFromAny (P.Expr_FromAny (encodeType encctx (TCon tpl)) (encodeExpr encctx body)))
   where
     expr = P.Expr Nothing . Just
 

diff --git a/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/Error.hs b/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/Error.hs
@@ -23,6 +23,7 @@ data Error
   | DuplicateChoice ChoiceName
   | UnsupportedMinorVersion T.Text
   | MissingPackageRefId Word64
+  | ExpectedTCon Type
   deriving (Show, Eq)
 
 type Decode = Either Error
diff --git a/compiler/daml-lf-tools/src/DA/Daml/LF/Simplifier.hs b/compiler/daml-lf-tools/src/DA/Daml/LF/Simplifier.hs
@@ -57,6 +57,8 @@ freeVarsStep = \case
   EConsF _ s1 s2 -> s1 <> s2
   ENoneF _ -> mempty
   ESomeF _ s -> s
+  EToAnyTemplateF _ s -> s
+  EFromAnyTemplateF _ s -> s
   EUpdateF u ->
     case u of
       UPureF _ s -> s
@@ -206,6 +208,13 @@ safetyStep = \case
   ESomeF _ s
     | Safe _ <- s -> Safe 0
     | otherwise   -> Unsafe
+  EToAnyTemplateF _ s
+    | Safe _ <- s -> Safe 0
+    | otherwise -> Unsafe
+  EFromAnyTemplateF _ s
+    | Safe _ <- s -> Safe 0
+    | otherwise -> Unsafe
+
 
 infoStep :: ExprF Info -> Info
 infoStep e = Info (freeVarsStep (fmap freeVars e)) (safetyStep (fmap safety e))

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
@@ -119,6 +119,7 @@ kindOfBuiltin = \case
   BTOptional -> KStar `KArrow` KStar
   BTMap -> KStar `KArrow` KStar
   BTArrow -> KStar `KArrow` KStar `KArrow` KStar
+  BTAnyTemplate -> KStar
 
 kindOf :: MonadGamma m => Type -> m Kind
 kindOf = \case
@@ -497,6 +498,14 @@ typeOf = \case
   ECons elemType headExpr tailExpr -> checkCons elemType headExpr tailExpr $> TList elemType
   ESome bodyType bodyExpr -> checkSome bodyType bodyExpr $> TOptional bodyType
   ENone bodyType -> checkType bodyType KStar $> TOptional bodyType
+  EToAnyTemplate tpl bodyExpr -> do
+    _ :: Template <- inWorld (lookupTemplate tpl)
+    checkExpr bodyExpr (TCon tpl)
+    pure $ TBuiltin BTAnyTemplate
+  EFromAnyTemplate tpl bodyExpr -> do
+    _ :: Template <- inWorld (lookupTemplate tpl)
+    checkExpr bodyExpr (TBuiltin BTAnyTemplate)
+    pure $ TOptional (TCon tpl)
   EUpdate upd -> typeOfUpdate upd
   EScenario scen -> typeOfScenario scen
   ELocation _ expr -> typeOf expr

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
@@ -61,6 +61,7 @@ data UnserializabilityReason
   | URNumericNotFixed
   | URNumericOutOfRange !Natural
   | URTypeLevelNat
+  | URAnyTemplate -- ^ It contains a value of type AnyTemplate.
 
 data Error
   = EUnknownTypeVar        !TypeVarName
@@ -94,6 +95,7 @@ data Error
   | EExpectedOptionalType  !Type
   | EEmptyCase
   | EExpectedTemplatableType !TypeConName
+  | EExpectedTemplateType !Type
   | EImportCycle           ![ModuleName]
   | EDataTypeCycle         ![TypeConName]
   | EValueCycle            ![ExprValName]
@@ -164,6 +166,7 @@ instance Pretty UnserializabilityReason where
     URNumericNotFixed -> "Numeric scale is not fixed"
     URNumericOutOfRange n -> "Numeric scale " <> integer (fromIntegral n) <> " is out of range (needs to be between 0 and 38)"
     URTypeLevelNat -> "type-level nat"
+    URAnyTemplate -> "AnyTemplate"
 
 instance Pretty Error where
   pPrint = \case
@@ -244,6 +247,9 @@ instance Pretty Error where
     EExpectedTemplatableType tpl ->
       "expected monomorphic record type in template definition, but found:"
       <-> pretty tpl
+    EExpectedTemplateType ty ->
+      "expected template type as argument to to_any_template, but got:"
+      <-> pretty ty
     EImportCycle mods ->
       "found import cycle:" $$ vcat (map (\m -> "*" <-> pretty m) mods)
     EDataTypeCycle tycons ->

diff --git a/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Serializability.hs b/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker/Serializability.hs
@@ -97,6 +97,7 @@ serializabilityConditionsType world0 _version mbModNameTpls vars = go
                                            -- (or polymorphically in DAML-LF <= 1.4).
         BTArrow -> Left URFunction
         BTNumeric -> Left URNumeric -- 'Numeric' is used as a higher-kinded type constructor.
+        BTAnyTemplate -> Left URAnyTemplate
       TForall{} -> Left URForall
       TTuple{} -> Left URTuple
 

diff --git a/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Upgrade.hs b/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Upgrade.hs
@@ -533,6 +533,8 @@ generateSrcFromLf (Qualify qualify) thisPkgId pkgMap m = noLoc mod
             LF.BTArrow -> mkTyConTypeUnqual funTyCon
             -- TODO (#2289): Add support for Numeric types.
             LF.BTNumeric -> error "Numeric type not yet supported in upgrades"
+            -- TODO see https://github.com/digital-asset/daml/issues/2876
+            LF.BTAnyTemplate -> error "AnyTemplate type not yet supported in upgrades"
     mkGhcType =
         HsTyVar noExt NotPromoted .
         noLoc . mkOrig gHC_TYPES . mkOccName varName
@@ -637,6 +639,8 @@ generateSrcFromLf (Qualify qualify) thisPkgId pkgMap m = noLoc mod
             LF.BTArrow -> (primUnitId, translateModName funTyCon)
             -- TODO (#2289): Add support for Numeric types.
             LF.BTNumeric -> error "Numeric type not yet supported in upgrades"
+            -- TODO: see https://github.com/digital-asset/daml/issues/2876
+            LF.BTAnyTemplate -> error "AnyTemplate type not yet supported in upgrades"
 
     translateModName ::
            forall a. NamedThing a

diff --git a/daml-lf/archive/da/daml_lf_1.proto b/daml-lf/archive/da/daml_lf_1.proto
@@ -234,6 +234,9 @@ enum PrimType {
   // *Available in versions >= 1.dev*
   NUMERIC = 17;
 
+  // Builtin type 'Any'
+  // *Available in versions >= 1.dev*
+  ANY = 18;
 }
 
 // Types
@@ -711,6 +714,24 @@ message Expr {
     Expr body = 2;
   }
 
+  // Wrap a value in Any
+ // *Available in versions >= 1.dev*
+  message ToAny {
+    // type of argument. Must be the TypeConName of a template.
+    Type type = 1;
+    // argument
+    Expr expr = 2;
+  }
+
+  // Extract the given type from Any or return None on type-mismatch
+ // *Available in versions >= 1.dev*
+  message FromAny {
+    // type that should be extracted. Must be the TypeConName of a template.
+    Type type = 1;
+    // Value of type Any
+    Expr expr = 2;
+  }
+
   // Location of the expression in the DAML code source.
   // Optional
   Location location = 25;
@@ -794,6 +815,14 @@ message Expr {
     // non empty optional value ('ExpSome')
     // *Available in versions >= 1.1*
     OptionalSome optional_some = 27;
+
+    // Wrap an arbitrary value in Any ('ExpToAny')
+    // *Available in versions >= 1.dev*
+    ToAny to_any = 29;
+
+    // Extract the given type from Any or return None on type-mismatch ('ExpFromAny')
+    // *Available in versions >= 1.dev*
+    FromAny from_any = 30;
   }
 
   reserved 19; // This was equals. Removed in favour of BuiltinFunction.EQUAL_*

diff --git a/daml-lf/archive/src/main/scala/com/digitalasset/daml/lf/archive/DecodeV1.scala b/daml-lf/archive/src/main/scala/com/digitalasset/daml/lf/archive/DecodeV1.scala
@@ -539,6 +539,25 @@ private[archive] class DecodeV1(minor: LV.Minor) extends Decode.OfPackage[PLF.Pa
           val some = lfExpr.getOptionalSome
           ESome(decodeType(some.getType), decodeExpr(some.getBody, definition))
 
+        case PLF.Expr.SumCase.TO_ANY =>
+          assertSince(LV.Features.anyTemplate, "Expr.ToAnyTemplate")
+          decodeType(lfExpr.getToAny.getType) match {
+            case TTyCon(tmplId) =>
+              EToAnyTemplate(
+                tmplId = tmplId,
+                body = decodeExpr(lfExpr.getToAny.getExpr, definition))
+            case ty => throw ParseError(s"TO_ANY must be applied to a template type but got $ty")
+          }
+
+        case PLF.Expr.SumCase.FROM_ANY =>
+          assertSince(LV.Features.anyTemplate, "Expr.FromAnyTemplate")
+          val fromAny = lfExpr.getFromAny
+          decodeType(fromAny.getType) match {
+            case TTyCon(tmplId) =>
+              EFromAnyTemplate(tmplId = tmplId, body = decodeExpr(fromAny.getExpr, definition))
+            case ty => throw ParseError(s"FROM_ANY must be applied to a template type but got $ty")
+          }
+
         case PLF.Expr.SumCase.SUM_NOT_SET =>
           throw ParseError("Expr.SUM_NOT_SET")
       }
@@ -796,7 +815,8 @@ private[lf] object DecodeV1 {
       BuiltinTypeInfo(OPTIONAL, BTOptional, minVersion = optional),
       BuiltinTypeInfo(MAP, BTMap, minVersion = optional),
       BuiltinTypeInfo(ARROW, BTArrow, minVersion = arrowType),
-      BuiltinTypeInfo(NUMERIC, BTNumeric, minVersion = numeric)
+      BuiltinTypeInfo(NUMERIC, BTNumeric, minVersion = numeric),
+      BuiltinTypeInfo(ANY, BTAnyTemplate, minVersion = anyTemplate)
     )
   }
 

diff --git a/daml-lf/archive/src/test/scala/com/digitalasset/daml/lf/archive/DecodeV1Spec.scala b/daml-lf/archive/src/test/scala/com/digitalasset/daml/lf/archive/DecodeV1Spec.scala
@@ -64,6 +64,18 @@ class DecodeV1Spec
     LV.Minor.Dev
   )
 
+  private val preAnyTemplateVersions = Table(
+    "minVersion",
+    List(1, 4, 6).map(i => LV.Minor.Stable(i.toString)): _*
+  )
+
+  // FixMe: https://github.com/digital-asset/daml/issues/2876
+  //        add stable version when AnyTemplate is released
+  private val postAnyTemplateVersions = Table(
+    "minVersion",
+    LV.Minor.Dev
+  )
+
   "decodeKind" should {
 
     "reject nat kind if lf version < 1.dev" in {
@@ -187,6 +199,20 @@ class DecodeV1Spec
         }
       }
     }
+
+    "reject AnyTemplate if version < 1.dev" in {
+      forEvery(preAnyTemplateVersions) { version =>
+        val decoder = moduleDecoder(version)
+        a[ParseError] shouldBe thrownBy(decoder.decodeType(buildPrimType(ANY)))
+      }
+    }
+
+    "accept AnyTemplate if version >= 1.dev" in {
+      forEvery(postAnyTemplateVersions) { minVersion =>
+        val decoder = moduleDecoder(minVersion)
+        decoder.decodeType(buildPrimType(ANY)) shouldBe TAnyTemplate
+      }
+    }
   }
 
   "decodeExpr" should {

diff --git a/daml-lf/interpreter/src/main/scala/com/digitalasset/daml/lf/speedy/Compiler.scala b/daml-lf/interpreter/src/main/scala/com/digitalasset/daml/lf/speedy/Compiler.scala
@@ -589,7 +589,7 @@ final case class Compiler(packages: PackageId PartialFunction Package) {
       case ELocation(loc, e) =>
         SELocation(loc, translate(e))
 
-      case EToAnyTemplate(e) =>
+      case EToAnyTemplate(_, e) =>
         SEApp(SEBuiltin(SBToAnyTemplate), Array(translate(e)))
 
       case EFromAnyTemplate(tmplId, e) =>

diff --git a/daml-lf/interpreter/src/test/scala/com/digitalasset/daml/lf/speedy/SpeedyTest.scala b/daml-lf/interpreter/src/test/scala/com/digitalasset/daml/lf/speedy/SpeedyTest.scala
@@ -122,10 +122,10 @@ class SpeedyTest extends WordSpec with Matchers {
   "to_any_template" should {
 
     "throw an exception on Int64" in {
-      eval(e"""to_any_template 1""", anyTemplatePkgs) shouldBe 'left
+      eval(e"""to_any_template @Test:T1 1""", anyTemplatePkgs) shouldBe 'left
     }
     "succeed on template type" in {
-      eval(e"""to_any_template (Test:T1 {party = 'Alice'})""", anyTemplatePkgs) shouldBe
+      eval(e"""to_any_template @Test:T1 (Test:T1 {party = 'Alice'})""", anyTemplatePkgs) shouldBe
         Right(
           SAnyTemplate(SRecord(
             Identifier(pkgId, QualifiedName.assertFromString("Test:T1")),
@@ -144,7 +144,7 @@ class SpeedyTest extends WordSpec with Matchers {
 
     "return Some(tpl) if template id matches" in {
       eval(
-        e"""from_any_template @Test:T1 (to_any_template (Test:T1 {party = 'Alice'}))""",
+        e"""from_any_template @Test:T1 (to_any_template @Test:T1 (Test:T1 {party = 'Alice'}))""",
         anyTemplatePkgs) shouldBe
         Right(
           SOptional(Some(SRecord(
@@ -156,7 +156,7 @@ class SpeedyTest extends WordSpec with Matchers {
 
     "return None if template id does not match" in {
       eval(
-        e"""from_any_template @Test:T2 (to_any_template (Test:T1 {party = 'Alice'}))""",
+        e"""from_any_template @Test:T2 (to_any_template @Test:T1 (Test:T1 {party = 'Alice'}))""",
         anyTemplatePkgs) shouldBe Right(SOptional(None))
     }
   }

diff --git a/daml-lf/language/src/main/scala/com/digitalasset/daml/lf/language/Ast.scala b/daml-lf/language/src/main/scala/com/digitalasset/daml/lf/language/Ast.scala
@@ -146,7 +146,7 @@ object Ast {
   final case class ESome(typ: Type, body: Expr) extends Expr
 
   /** AnyTemplate constructor **/
-  final case class EToAnyTemplate(body: Expr) extends Expr
+  final case class EToAnyTemplate(tmplId: TypeConName, body: Expr) extends Expr
 
   /** Extract the underlying template if it matches the tmplId **/
   final case class EFromAnyTemplate(tmplId: TypeConName, body: Expr) extends Expr