Make AnyChoice and AnyContractKey take template type into account (#3541

) * Make AnyChoice and AnyContractKey take template type into account fixes #3540 * Update template desugaring * Switch to proper ghc-lib release
digital-asset · Nov 20, 2019 · 1bc4bb7 · 1bc4bb7
1 parent 917c43a
commit 1bc4bb7
Show file tree

Hide file tree

Showing 14 changed files with 131 additions and 64 deletions.
diff --git a/WORKSPACE b/WORKSPACE
@@ -520,12 +520,12 @@ HASKELL_LSP_HASH = "80a3944306fb455fce36f7b3aafb8f0f8f6096a0bd3c46ed25cc0ff288d6
 
 GRPC_HASKELL_CORE_VERSION = "0.0.0.0"
 
-GHC_LIB_VERSION = "8.8.1.20191111"
+GHC_LIB_VERSION = "8.8.1.20191120"
 
 http_archive(
     name = "haskell_ghc__lib__parser",
     build_file = "//3rdparty/haskell:BUILD.ghc-lib-parser",
-    sha256 = "2b406c537667e7a802aa1551a9c2b697b47d1b40e3d8d99f9d0711209a6636fd",
+    sha256 = "89e5e8eadd66a90970b866a0669da28b1cd4fff2511a2dc09151a5b269bc0bc1",
     strip_prefix = "ghc-lib-parser-{}".format(GHC_LIB_VERSION),
     urls = ["https://digitalassetsdk.bintray.com/ghc-lib/ghc-lib-parser-{}.tar.gz".format(GHC_LIB_VERSION)],
 )
@@ -598,7 +598,7 @@ hazel_repositories(
 
             # Read [Working on ghc-lib] for ghc-lib update instructions at
             # https://github.com/digital-asset/daml/blob/master/ghc-lib/working-on-ghc-lib.md.
-            hazel_ghclibs(GHC_LIB_VERSION, "0000000000000000000000000000000000000000000000000000000000000000", "89378f66a8283ddb785538e6d94c1a282d27fa2f3658b537ea5d3cee2efa786e") +
+            hazel_ghclibs(GHC_LIB_VERSION, "0000000000000000000000000000000000000000000000000000000000000000", "2433176141caffd066313876ef756e2fcb34dc96a809d40eec753a4248ba016e") +
             hazel_github_external("digital-asset", "hlint", "951fdb6d28d7eed8ea1c7f3be69da29b61fcbe8f", "f5fb4cf98cde3ecf1209857208369a63ba21b04313d570c41dffe9f9139a1d34") +
             # Not in stackage
             hazel_hackage(

diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
@@ -357,8 +357,6 @@ convertGenericTemplate env x
                         let thisField = FieldName "contract"
                         tupleTyCon <- qDA_Types env $ mkTypeCon ["Tuple2"]
                         let tupleType = TypeConApp tupleTyCon [TContractId polyType, polyType]
-                        let anyContractKeyTy = TypeConApp (Qualified stdlibRef (mkModName ["DA", "Internal", "LF"]) (mkTypeCon ["AnyContractKey"])) []
-                        let anyContractKeyField = mkField "getAnyContractKey"
                         let fetchByKey =
                                 ETmLam (mkVar "key", keyType) $
                                 EUpdate $ UBind (Binding (res, TTuple [(selfField, TContractId monoType), (thisField, monoType)]) $ EUpdate $ UFetchByKey $ RetrieveByKey monoTyCon $ EVar $ mkVar "key") $
@@ -379,19 +377,19 @@ convertGenericTemplate env x
                                          (mkTypeVar "proxy", KArrow KStar KStar)
                                          (ETmLam
                                             (mkVar "_", TApp (TVar $ mkTypeVar "proxy") polyType)
-                                            (ETmLam (mkVar "key", keyType) $ ERecCon anyContractKeyTy [(anyContractKeyField, EToAny keyType $ EVar $ mkVar "key")]))
+                                            (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 :-> typeConAppToType anyContractKeyTy) `ETmApp`
+                                       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", typeConAppToType anyContractKeyTy) $ EFromAny keyType $ ERecProj anyContractKeyTy anyContractKeyField $ EVar $ mkVar "any"))
+                                            (ETmLam (mkVar "any", TAny) $ EFromAny keyType $ EVar $ mkVar "any"))
                                   else EBuiltin BEError `ETyApp`
-                                       TForall (mkTypeVar "proxy", KArrow KStar KStar) (TApp (TVar $ mkTypeVar "proxy") polyType :-> typeConAppToType anyContractKeyTy :-> TOptional keyType) `ETmApp`
+                                       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)
@@ -427,27 +425,25 @@ convertGenericTemplate env x
                 let exercise =
                         mkETmLams [(self, TContractId polyType), (arg, argType)] $
                           EUpdate $ UExercise monoTyCon chcName (wrapCid $ EVar self) Nothing (EVar arg)
-                let anyChoiceTy = TypeConApp (Qualified stdlibRef (mkModName ["DA", "Internal", "LF"]) (mkTypeCon ["AnyChoice"])) []
-                let anyChoiceField = mkField "getAnyChoice"
                 let toAnyChoice =
                         if envLfVersion env `supports` featureAnyType
                           then ETyLam
                                  (mkTypeVar "proxy", KArrow KStar KStar)
                                  (ETmLam
                                     (mkVar "_", TApp (TVar $ mkTypeVar "proxy") polyType)
-                                    (ETmLam chcArgBinder $ ERecCon anyChoiceTy [(anyChoiceField, EToAny argType $ EVar arg)]))
+                                    (ETmLam chcArgBinder $ EToAny argType $ EVar arg))
                           else EBuiltin BEError `ETyApp`
-                               TForall (mkTypeVar "proxy", KArrow KStar KStar) (TApp (TVar $ mkTypeVar "proxy") polyType :-> argType :-> typeConAppToType anyChoiceTy) `ETmApp`
+                               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", typeConAppToType anyChoiceTy) $ EFromAny argType $ ERecProj anyChoiceTy anyChoiceField $ EVar $ mkVar "any"))
+                                    (ETmLam (mkVar "any", TAny) $ EFromAny argType $ EVar $ mkVar "any"))
                           else EBuiltin BEError `ETyApp`
-                               TForall (mkTypeVar "proxy", KArrow KStar KStar) (TApp (TVar $ mkTypeVar "proxy") polyType :-> typeConAppToType anyChoiceTy :-> TOptional argType) `ETmApp`
+                               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

diff --git a/compiler/damlc/daml-stdlib-src/DA/Internal/Desugar.daml b/compiler/damlc/daml-stdlib-src/DA/Internal/Desugar.daml
@@ -11,7 +11,7 @@ module DA.Internal.Desugar (
     Eq(..), Show(..),
     Bool(..), Text, Optional,
     concat, magic,
-    Party, ContractId, Update, AnyTemplate, AnyChoice, AnyContractKey, TemplateTypeRep
+    Party, ContractId, Update, Any, AnyTemplate, AnyChoice, AnyContractKey, TemplateTypeRep
 ) where
 
 import DA.Internal.Prelude

diff --git a/compiler/damlc/daml-stdlib-src/DA/Internal/LF.daml b/compiler/damlc/daml-stdlib-src/DA/Internal/LF.daml
@@ -39,8 +39,9 @@ module DA.Internal.LF
   , unpackPair
 
   , AnyTemplate
-  , AnyChoice
-  , AnyContractKey
+  , AnyChoice(..)
+  , AnyContractKey(..)
+  , Any
 
   , TemplateTypeRep
   ) where
@@ -219,10 +220,16 @@ data Any = Any Opaque
 newtype AnyTemplate = AnyTemplate { getAnyTemplate : Any }
 
 -- | Existential choice type that can wrap an arbitrary choice.
-newtype AnyChoice = AnyChoice { getAnyChoice : Any }
+data AnyChoice = AnyChoice
+  { getAnyChoice : Any
+  , getAnyChoiceTemplateTypRep : TemplateTypeRep
+  }
 
 -- | Existential contract key type that can wrap an arbitrary contract key.
-newtype AnyContractKey = AnyContractKey { getAnyContractKey : Any }
+data AnyContractKey = AnyContractKey
+  { getAnyContractKey : Any
+  , getanyContractKeyTemplateRep : TemplateTypeRep
+  }
 
 -- | Value-level representation of a type.
 -- We do not expose this directly and instead only expose TemplateTypeRep.

diff --git a/compiler/damlc/daml-stdlib-src/DA/Internal/Template.daml b/compiler/damlc/daml-stdlib-src/DA/Internal/Template.daml
@@ -58,14 +58,20 @@ stakeholder t = signatory t ++ observer t
 class Template t => Choice t c r | t c -> r where
   -- | Exercise a choice on the contract with the given contract ID.
   exercise : ContractId t -> c -> Update r
-  _toAnyChoice : proxy t -> c -> AnyChoice
-  _fromAnyChoice : proxy t -> AnyChoice -> Optional c
+  _toAnyChoice : proxy t -> c -> Any
+  _fromAnyChoice : proxy t -> Any -> Optional c
 
 toAnyChoice : forall t c r. Choice t c r => c -> AnyChoice
-toAnyChoice = _toAnyChoice ([] : [t])
+toAnyChoice c =
+  AnyChoice
+    (_toAnyChoice ([] : [t]) c)
+    (templateTypeRep @t)
 
 fromAnyChoice : forall t c r. Choice t c r => AnyChoice -> Optional c
-fromAnyChoice = _fromAnyChoice ([] : [t])
+fromAnyChoice (AnyChoice any typeRep)
+  | Some c <- _fromAnyChoice ([] : [t]) any
+  , templateTypeRep @t == typeRep = Some c
+  | otherwise = None
 
 class Template t => TemplateKey t k | t -> k where
   -- | The key of a contract.
@@ -101,14 +107,20 @@ class Template t => TemplateKey t k | t -> k where
   -- | The list of maintainers of a contract key.
   maintainer : k -> [Party]
 
-  _toAnyContractKey : proxy t -> k -> AnyContractKey
-  _fromAnyContractKey : proxy t -> AnyContractKey -> Optional k
+  _toAnyContractKey : proxy t -> k -> Any
+  _fromAnyContractKey : proxy t -> Any -> Optional k
 
 toAnyContractKey : forall t k. TemplateKey t k => k -> AnyContractKey
-toAnyContractKey = _toAnyContractKey ([] : [t])
+toAnyContractKey k =
+  AnyContractKey
+    (_toAnyContractKey ([] : [t]) k)
+    (templateTypeRep @t)
 
 fromAnyContractKey : forall t k. TemplateKey t k => AnyContractKey -> Optional k
-fromAnyContractKey = _fromAnyContractKey ([] : [t])
+fromAnyContractKey (AnyContractKey any rep)
+  | Some k <- _fromAnyContractKey ([] : [t]) any
+  , templateTypeRep @t == rep = Some k
+  | otherwise = None
 
 -- | Exercise a choice on the contract associated with the given key.
 --

diff --git a/compiler/damlc/daml-stdlib-src/Prelude.daml b/compiler/damlc/daml-stdlib-src/Prelude.daml
@@ -7,7 +7,7 @@ daml 1.2
 module Prelude (module X) where
 
 import DA.Internal.Prelude as X hiding (magic)
-import DA.Internal.LF as X hiding (Pair(..), TextMap, unpackPair)
+import DA.Internal.LF as X hiding (Pair(..), TextMap, unpackPair, Any)
 -- Template desugaring uses fromAnyTemplate and toAnyTemplate so we
 -- can’t remove them from the typeclass for older LF versions
 -- but we can hide them.

diff --git a/compiler/damlc/tests/daml-test-files/AnyChoice.daml b/compiler/damlc/tests/daml-test-files/AnyChoice.daml
@@ -58,3 +58,5 @@ main = scenario do
   fromAnyChoice @GT2 @(CT T2) (toAnyChoice @GT1 ct1) === None
   fromAnyChoice @GT2 @(CT T2) (toAnyChoice @GT2 ct2) === Some ct2
   fromAnyChoice @GT1 @(CT T1) (toAnyChoice @GT2 ct2) === None
+  fromAnyChoice @T1 @Archive (toAnyChoice @T2 Archive) === None
+  fromAnyChoice @T2 @Archive (toAnyChoice @T2 Archive) === Some Archive
diff --git a/compiler/damlc/tests/daml-test-files/AnyContractKey.daml b/compiler/damlc/tests/daml-test-files/AnyContractKey.daml
@@ -15,6 +15,15 @@ template T1
     key p : Party
     maintainer key
 
+template T1'
+  with
+    x : Int
+    p : Party
+  where
+    signatory p
+    key p : Party
+    maintainer key
+
 template T2
   with
     y : Text
@@ -39,6 +48,7 @@ template instance GT2 = GenericT T2
 main = scenario do
   p <- getParty "alice"
   fromAnyContractKey @T1 (toAnyContractKey @T1 p) === Some p
+  fromAnyContractKey @T1' (toAnyContractKey @T1 p) === None
   fromAnyContractKey @T2 (toAnyContractKey @T2 (p, "foobar")) === Some (p, "foobar")
 
   fromAnyContractKey @T2 (toAnyContractKey @T1 p) === None

diff --git a/compiler/damlc/tests/daml-test-files/ProposalDesugared.daml b/compiler/damlc/tests/daml-test-files/ProposalDesugared.daml
@@ -10,6 +10,7 @@ module ProposalDesugared
   ( main
   ) where
 
+import DA.Internal.Desugar
 import DA.Assert
 import DA.List
 import DA.Text
@@ -92,9 +93,9 @@ class Template t => ProposalInstance t where
     _fetchByKeyProposal = error "code will be injected by the compiler"
     _lookupByKeyProposal : ([Party], Text) -> Update (Optional (ContractId (Proposal t)))
     _lookupByKeyProposal = error "code will be injected by the compiler"
-    _toAnyContractKeyProposal : proxy (Proposal t) -> ([Party], Text) -> AnyContractKey
+    _toAnyContractKeyProposal : proxy (Proposal t) -> ([Party], Text) -> Any
     _toAnyContractKeyProposal = error "code will be injected by the compiler"
-    _fromAnyContractKeyProposal : proxy (Proposal t) -> AnyContractKey -> Optional ([Party], Text)
+    _fromAnyContractKeyProposal : proxy (Proposal t) -> Any -> Optional ([Party], Text)
     _fromAnyContractKeyProposal = error "code will be injected by the compiler"
 
     _consumptionProposalArchive : PreConsuming (Proposal t)
@@ -106,9 +107,9 @@ class Template t => ProposalInstance t where
         pure ()
     _exerciseProposalArchive : ContractId (Proposal t) -> Archive -> Update ()
     _exerciseProposalArchive = error "code will be injected by the compiler"
-    _toAnyChoiceProposalArchive : proxy (Proposal t) -> Archive -> AnyChoice
+    _toAnyChoiceProposalArchive : proxy (Proposal t) -> Archive -> Any
     _toAnyChoiceProposalArchive = error "code will be injected by the compiler"
-    _fromAnyChoiceProposalArchive : proxy (Proposal t) -> AnyChoice -> Optional Archive
+    _fromAnyChoiceProposalArchive : proxy (Proposal t) -> Any -> Optional Archive
     _fromAnyChoiceProposalArchive = error "code will be injected by the compiler"
 
     _consumptionProposalAccept : PreConsuming (Proposal t)
@@ -120,9 +121,9 @@ class Template t => ProposalInstance t where
         create asset
     _exerciseProposalAccept : ContractId (Proposal t) -> Accept -> Update (ContractId t)
     _exerciseProposalAccept = error "code will be injected by the compiler"
-    _toAnyChoiceProposalAccept : proxy (Proposal t) -> Accept -> AnyChoice
+    _toAnyChoiceProposalAccept : proxy (Proposal t) -> Accept -> Any
     _toAnyChoiceProposalAccept = error "code will be injected by the compiler"
-    _fromAnyChoiceProposalAccept : proxy (Proposal t) -> AnyChoice -> Optional Accept
+    _fromAnyChoiceProposalAccept : proxy (Proposal t) -> Any -> Optional Accept
     _fromAnyChoiceProposalAccept = error "code will be injected by the compiler"
 
 
@@ -190,9 +191,9 @@ class IouInstance where
     pure ()
   _exerciseIouArchive : ContractId Iou -> Archive -> Update ()
   _exerciseIouArchive = error "code will be injected by the compiler"
-  _toAnyChoiceIouArchive : proxy Iou -> Archive -> AnyChoice
+  _toAnyChoiceIouArchive : proxy Iou -> Archive -> Any
   _toAnyChoiceIouArchive = error "code will be injected by the compiler"
-  _fromAnyChoiceIouArchive : proxy Iou -> AnyChoice -> Optional Archive
+  _fromAnyChoiceIouArchive : proxy Iou -> Any -> Optional Archive
   _fromAnyChoiceIouArchive = error "code will be injected by the compiler"
 
   _consumptionIouBurn : PreConsuming Iou
@@ -204,9 +205,9 @@ class IouInstance where
     pure ()
   _exerciseIouBurn : ContractId Iou -> Burn -> Update ()
   _exerciseIouBurn = error "code will be injected by the compiler"
-  _toAnyChoiceIouBurn : proxy Iou -> Burn -> AnyChoice
+  _toAnyChoiceIouBurn : proxy Iou -> Burn -> Any
   _toAnyChoiceIouBurn = error "code will be injected by the compiler"
-  _fromAnyChoiceIouBurn : proxy Iou -> AnyChoice -> Optional Burn
+  _fromAnyChoiceIouBurn : proxy Iou -> Any -> Optional Burn
   _fromAnyChoiceIouBurn = error "code will be injected by the compiler"
 
 instance IouInstance where

diff --git a/compiler/damlc/tests/src/DA/Test/DamlcIntegration.hs b/compiler/damlc/tests/src/DA/Test/DamlcIntegration.hs
@@ -120,6 +120,7 @@ getIntegrationTests registerTODO scenarioService version = do
     -- only run Test.daml (see https://github.com/digital-asset/daml/issues/726)
     bondTradingLocation <- locateRunfiles $ mainWorkspace </> "compiler/damlc/tests/bond-trading"
     let allTestFiles = damlTestFiles ++ [("bond-trading/Test.daml", bondTradingLocation </> "Test.daml")]
+    let (generatedFiles, nongeneratedFiles) = partition (\(f, _) -> takeFileName f == "ProposalDesugared.daml") allTestFiles
 
     let outdir = "compiler/damlc/output"
     createDirectoryIfMissing True outdir
@@ -134,12 +135,17 @@ getIntegrationTests registerTODO scenarioService version = do
     -- initialise the compiler service
     vfs <- makeVFSHandle
     damlEnv <- mkDamlEnv opts (Just scenarioService)
+    -- We use a separate service for generated files so that we can test files containing internal imports.
     pure $
-      withResource
-      (initialise (mainRule opts) (pure $ LSP.IdInt 0) (const $ pure ()) IdeLogger.noLogging damlEnv (toCompileOpts opts (IdeReportProgress False)) vfs)
-      shutdown $ \service ->
-      withTestArguments $ \args -> testGroup ("Tests for DAML-LF " ++ renderPretty version) $
-        map (testCase args version service outdir registerTODO) allTestFiles
+          withResource
+          (initialise (mainRule opts) (pure $ LSP.IdInt 0) (const $ pure ()) IdeLogger.noLogging damlEnv (toCompileOpts opts (IdeReportProgress False)) vfs)
+          shutdown $ \service ->
+          withResource
+          (initialise (mainRule opts) (pure $ LSP.IdInt 0) (const $ pure ()) IdeLogger.noLogging damlEnv (toCompileOpts opts { optIsGenerated = True } (IdeReportProgress False)) vfs)
+          shutdown $ \serviceGenerated ->
+          withTestArguments $ \args -> testGroup ("Tests for DAML-LF " ++ renderPretty version) $
+            map (testCase args version service outdir registerTODO) nongeneratedFiles <>
+            map (testCase args version serviceGenerated outdir registerTODO) generatedFiles
 
 newtype TestCase = TestCase ((String -> IO ()) -> IO Result)
 

diff --git a/daml-script/runner/src/main/scala/com/digitalasset/daml/lf/engine/script/Converter.scala b/daml-script/runner/src/main/scala/com/digitalasset/daml/lf/engine/script/Converter.scala
@@ -83,7 +83,7 @@ object Converter {
 
   def toAnyChoice(v: SValue): Either[String, AnyChoice] = {
     v match {
-      case SRecord(_, _, vals) if vals.size == 1 => {
+      case SRecord(_, _, vals) if vals.size == 2 => {
         vals.get(0) match {
           case SAny(_, choiceVal @ SRecord(_, _, _)) =>
             Right(AnyChoice(choiceVal.id.qualifiedName.name.toString, choiceVal))