Interface fixed choices: ghc parser (#11275)

* Interface fixed choices: ghc parser (WIP) changelog_begin changelog_end * . * .. * ... * stackage unpin unix * ... * fold create/observer/signatory into fake lfconversion primitives * stackage unpin * ..... * ...... * ........ * ......... * . . . . . * unpin stackage on unix * ...... ...... * ... * . . . . . * unpin stackage on unix * . . . . . . . . . * unpin stackage on unix * Loosen restriction on ETo/FromAnyChoice fake primitives * uncomment exercise in Interface.daml * remove comments * !!! * the final re-pinning, part 1 * the final re-pinning: part 2
digital-asset · Oct 20, 2021 · 76eb165 · 76eb165
1 parent da27a1e
commit 76eb165
Show file tree

Hide file tree

Showing 11 changed files with 83 additions and 69 deletions.
diff --git a/ci/da-ghc-lib/compile.yml b/ci/da-ghc-lib/compile.yml
@@ -12,7 +12,7 @@ jobs:
   variables:
     ghc-lib-sha: '42e5c306dcfbc84b83336fdd531023e93bfcc5b2'
     base-sha: '9c787d4d24f2b515934c8503ee2bbd7cfac4da20'
-    patches: '14038856dada496345a02619b7e34200ef6523ef 833ca63be2ab14871874ccb6974921e8952802e9'
+    patches: '9fcd347e46790d0d054c347de7d36303426ee173 833ca63be2ab14871874ccb6974921e8952802e9'
     flavor: 'ghc-8.8.1'
   steps:
   - checkout: self

diff --git a/compiler/damlc/daml-ghc-util/src/DA/Daml/UtilGHC.hs b/compiler/damlc/daml-ghc-util/src/DA/Daml/UtilGHC.hs
@@ -272,6 +272,15 @@ hasDamlInterfaceCtx t
     = True
 hasDamlInterfaceCtx _ = False
 
+hasDamlTemplateCtx :: TyCon -> Bool
+hasDamlTemplateCtx t
+    | isAlgTyCon t
+    , [theta] <- tyConStupidTheta t
+    , TypeCon tycon [] <- theta
+    , NameIn GHC_Types "DamlTemplate" <- tycon
+    = True
+hasDamlTemplateCtx _ = False
+
 -- Pretty printing is very expensive, so clone the logic for when to add unique suffix
 varPrettyPrint :: Var -> T.Text
 varPrettyPrint (varName -> x) = getOccText x <> (if isSystemName x then "_" <> T.pack (show $ nameUnique x) else "")

diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
@@ -391,6 +391,7 @@ scrapeTemplateBinds binds = MS.filter (isJust . tbTyCon) $ MS.map ($ emptyTempla
         ShowDFunId tpl ->
             Just (tpl, \tb -> tb { tbShow = Just name })
         _ -> Nothing
+    , hasDamlTemplateCtx tpl
     ]
 
 data ExceptionBinds = ExceptionBinds

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
@@ -372,11 +372,11 @@ convertPrim version "EFromAnyTemplate"
         EFromAny (TCon template) (EVar $ mkVar "any")
 
 convertPrim version "EFromAnyChoice"
-    ty@(TApp proxy (TCon template) :-> tAny :-> TOptional choice)
+    ty@(tProxy :-> 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 "_", tProxy) $
         ETmLam (mkVar "any", TAny) $
         EFromAny choice (EVar $ mkVar "any")
 
@@ -398,11 +398,11 @@ convertPrim version "EToAnyTemplate"
         EToAny (TCon template) (EVar $ mkVar "template")
 
 convertPrim version "EToAnyChoice"
-    ty@(TApp proxy (TCon template) :-> choice :-> tAny)
+    ty@(tProxy :-> 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 "_", tProxy) $
         ETmLam (mkVar "choice", choice) $
         EToAny choice (EVar $ mkVar "choice")
 
@@ -415,6 +415,25 @@ convertPrim version "EToAnyContractKey"
         ETmLam (mkVar "key", key) $
         EToAny key (EVar $ mkVar "key")
 
+convertPrim _ "UCreateInterface" (TCon interface :-> TUpdate (TContractId (TCon interface')))
+    | interface == interface' =
+    ETmLam (mkVar "this", TCon interface) $
+    EExperimental "RESOLVE_VIRTUAL_CREATE"
+        (TCon interface :-> TCon interface :-> TUpdate (TContractId (TCon interface)))
+        `ETmApp` EVar (mkVar "this") `ETmApp` EVar (mkVar "this")
+
+convertPrim _ "ESignatoryInterface" (TCon interface :-> TList TParty) =
+    ETmLam (mkVar "this", TCon interface) $
+    EExperimental "RESOLVE_VIRTUAL_SIGNATORIES"
+        (TCon interface :-> TCon interface :-> TList TParty)
+        `ETmApp` EVar (mkVar "this") `ETmApp` EVar (mkVar "this")
+
+convertPrim _ "EObserverInterface" (TCon interface :-> TList TParty) =
+    ETmLam (mkVar "this", TCon interface) $
+    EExperimental "RESOLVE_VIRTUAL_OBSERVERS"
+        (TCon interface :-> TCon interface :-> TList TParty)
+        `ETmApp` EVar (mkVar "this") `ETmApp` EVar (mkVar "this")
+
 -- Exceptions
 convertPrim _ "BEAnyExceptionMessage" (TBuiltin BTAnyException :-> TText) =
     EBuiltin BEAnyExceptionMessage

diff --git a/compiler/damlc/daml-prim-src/GHC/Types.daml b/compiler/damlc/daml-prim-src/GHC/Types.daml
@@ -24,6 +24,7 @@ module GHC.Types (
         primitive, primitiveInterface, magic, external,
         DamlEnum,
         DamlInterface,
+        DamlTemplate,
 
 #ifdef DAML_NUMERIC
         Nat, Numeric,
@@ -169,6 +170,11 @@ data Text =
 class DamlEnum
 instance DamlEnum
 
+-- | HIDE Used to tag daml template types in the desugarer.
+class DamlTemplate
+instance DamlTemplate
+
+-- | HIDE Used to tag daml interface types in the desugarer.
 class DamlInterface
 instance DamlInterface
 

diff --git a/compiler/damlc/tests/daml-test-files/Interface.daml b/compiler/damlc/tests/daml-test-files/Interface.daml
@@ -24,36 +24,13 @@ interface Token where
     with
       nothing : ()
 
--- TODO https://github.com/digital-asset/daml/issues/10810
---   Add HasCreate, HasSignatory, HasObserver instances in GHC parser
-instance HasCreate Token where
-  create x = GHC.Types.primitive @"$RESOLVE_VIRTUAL_CREATE" x x
-instance HasObserver Token where
-  observer x = GHC.Types.primitive @"$RESOLVE_VIRTUAL_OBSERVERS" x x
--- TODO https://github.com/digital-asset/daml/issues/11198
---   Instance disabled until issue is resolved.
--- instance HasSignatory Token where
---   signatory x = GHC.Types.primitive @"$RESOLVE_VIRTUAL_SIGNATORIES" x x
-
--- TODO https://github.com/digital-asset/daml/issues/11137
---   Implement fixed choices in GHC parser.
-data GetRich = GetRich { byHowMuch : Int }
-_choice_TokenGetRich :
-  ( Token -> GetRich -> [DA.Internal.Desugar.Party]
-  , DA.Internal.Desugar.ContractId Token -> Token -> GetRich -> DA.Internal.Desugar.Update (ContractId Token)
-  , DA.Internal.Desugar.Consuming Token
-  , DA.Internal.Desugar.Optional (Token -> GetRich -> [DA.Internal.Desugar.Party])
-  )
-_choice_TokenGetRich =
-  ( \this _ -> [getOwner this]
-  , \self this GetRich{byHowMuch} -> do
-      assert (byHowMuch > 0)
-      create $ setAmount this (getAmount this + byHowMuch)
-  , DA.Internal.Desugar.Consuming
-  , DA.Internal.Desugar.None
-  )
-instance IsToken t => HasExercise t GetRich (ContractId Token) where
-  exercise cid = GHC.Types.primitive @"UExerciseInterface" (toTokenContractId cid)
+  choice GetRich : ContractId Token
+    with
+      byHowMuch : Int
+    controller getOwner this
+    do
+        assert (byHowMuch > 0)
+        create $ setAmount this (getAmount this + byHowMuch)
 
 template Asset
   with

diff --git a/compiler/damlc/tests/daml-test-files/InterfaceDesugared.daml b/compiler/damlc/tests/daml-test-files/InterfaceDesugared.daml
@@ -33,13 +33,11 @@ class
   setAmount : t -> Int -> Token
 
 instance HasCreate Token where
-  create x = GHC.Types.primitive @"$RESOLVE_VIRTUAL_CREATE" x x
+  create = GHC.Types.primitive @"UCreateInterface"
 instance HasObserver Token where
-  observer x = GHC.Types.primitive @"$RESOLVE_VIRTUAL_OBSERVERS" x x
--- TODO https://github.com/digital-asset/daml/issues/11198
---   Instance disabled until issue is resolved.
--- instance HasSignatory Token where
---   signatory x = GHC.Types.primitive @"$RESOLVE_VIRTUAL_SIGNATORIES" x x
+  observer = GHC.Types.primitive @"EObserverInterface"
+instance HasSignatory Token where
+  signatory = GHC.Types.primitive @"ESignatoryInterface"
 
 instance HasFetch Token where
   fetch = GHC.Types.primitive @"UFetchInterface"
@@ -103,8 +101,12 @@ _choice_TokenGetRich =
   )
 instance IsToken t => HasExercise t GetRich (ContractId Token) where
   exercise cid = GHC.Types.primitive @"UExerciseInterface" (toTokenContractId cid)
+instance IsToken t => HasToAnyChoice t GetRich (ContractId Token) where
+  _toAnyChoice = GHC.Types.primitive @"EToAnyChoice"
+instance IsToken t => HasFromAnyChoice t GetRich (ContractId Token) where
+  _fromAnyChoice = GHC.Types.primitive @"EFromAnyChoice"
 
-data Asset = Asset { amount : Int, issuer : Party, owner : Party }
+data GHC.Types.DamlTemplate => Asset = Asset { amount : Int, issuer : Party, owner : Party }
   deriving (Eq, Show)
 
 instance IsToken Asset where

diff --git a/ghc-lib/new-working-on-ghc-lib.md b/ghc-lib/new-working-on-ghc-lib.md
@@ -67,7 +67,7 @@ Once you have the GHC patch you want to incorporate into the Daml repo, here's t
 4. Before merging the PR, the pin command will also have to be run on windows, and those changes committed as well. You will need access to a windows machine for that: `ad-hoc.sh windows create`
 
 
-### Working on an `add-hoc` windows machine
+### Working on an `ad-hoc` windows machine
 
 1. First time, clone the `daml-language-ad-hoc` repo: (On following times, just pull for any updates to the scripts)
 ```

diff --git a/stack-snapshot.yaml b/stack-snapshot.yaml
@@ -3,10 +3,10 @@
 
 resolver: lts-18.0
 packages:
-  - archive: https://daml-binaries.da-ext.net/da-ghc-lib/ghc-lib-289a88911c02efcaeaf440c289a1bc60.tar.gz
-    sha256: "867c7fcf52ea3245cdd98f1044db29d19a2ac19db2b3114fcb78dc045d9eb69c"
-  - archive: https://daml-binaries.da-ext.net/da-ghc-lib/ghc-lib-parser-289a88911c02efcaeaf440c289a1bc60.tar.gz
-    sha256: "fe0082d84a095213a89b2ba23fa6cb85831604e0c69bad06c16f1be40444aa0c"
+  - archive: https://daml-binaries.da-ext.net/da-ghc-lib/ghc-lib-f5ac369874d523562066264f7facc06b.tar.gz
+    sha256: "ac7f2f212f1b1d69f107664059292133a08eabf6550b05371432216718460647"
+  - archive: https://daml-binaries.da-ext.net/da-ghc-lib/ghc-lib-parser-f5ac369874d523562066264f7facc06b.tar.gz
+    sha256: "99b90740b5c17574ed5fc7df8d3449e35bf614bd9d3fda2515ac90c2f389cbdb"
   - github: digital-asset/hlint
     commit: "c8246c1feb932858ff2b5d7e9e900068a974bf57"
     sha256: "3da24baf789c5f00211a92e24153e6b88102befaa946ada1f707935554500fe2"