Simplify template desugaring (digital-asset#3670)

* Introduce a simpler template desugaring without support for generic templates This adapts the LF conversion to the new template desugaring introduced in our GHC fork. The guiding principle is that we use the typeclasses directly to avoid generating, typechecking and converting redundant code caused by indirections. I updated the template desugaring documentation so that is probably a good starting point for reviewing this. * Address review comments * Fix daml doc tests * Fix data dependency tests * Switch to new ghc-lib release
FlashSheridan · Nov 29, 2019 · 75c9b1b · 75c9b1b
1 parent 5dd38d5
commit 75c9b1b
Show file tree

Hide file tree

Showing 13 changed files with 402 additions and 540 deletions.
diff --git a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract.hs b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract.hs
@@ -123,9 +123,14 @@ extractDocs extractOpts diagsLogger ideOpts fp = do
 
             (adts, md_templateInstances) =
                 partitionEithers . flip map filteredTyCons $ \adt ->
-                    case getTemplateInstanceDoc adt of
+                    case find (\td -> td_name td == ad_name adt) md_templates of
                         Nothing -> Left adt
-                        Just ti -> Right ti
+                        Just td -> Right TemplateInstanceDoc
+                          { ti_anchor = td_anchor td
+                          , ti_name = ad_name adt
+                          , ti_descr = Nothing
+                          , ti_rhs = TypeApp Nothing (ad_name adt) []
+                          }
 
             md_adts = mapMaybe (filterTypeByExports ctx) adts
 
@@ -274,6 +279,7 @@ getFctDocs ctx@DocCtx{..} (DeclData decl docs) = do
         fct_descr = docs
 
     guard (exportsFunction dc_exports fct_name)
+    guard (not $ "_choice_" `T.isPrefixOf` packRdrName name)
     Just FunctionDoc {..}
 
 getClsDocs :: DocCtx -> DeclData -> Maybe ClassDoc
@@ -523,34 +529,6 @@ getTemplateDocs DocCtx{..} typeMap templateInstanceMap =
                       [] -> [] -- catching the dummy case here, see above
                       _other -> error "getFields: found multiple constructors"
 
--- | A template instance is desugared to a type synonym with a doc marker.
---
--- For example,
---
--- @template instance ProposalIou = Proposal Iou@
---
--- leads to the `type` declaration
---
--- @--| TEMPLATE_INSTANCE@
--- @type ProposalIou = Proposal Iou@
---
--- This function looks for the "TEMPLATE_INSTANCE" doc marker around a type
--- synonym and, if it finds it, creates the relevant doc structure.
-getTemplateInstanceDoc :: ADTDoc -> Maybe TemplateInstanceDoc
-getTemplateInstanceDoc tyConDoc
-    | TypeSynDoc{..} <- tyConDoc
-    , Just (DocText doc) <- ad_descr
-    , Just realDoc <- T.stripSuffix "TEMPLATE_INSTANCE" doc
-    = Just TemplateInstanceDoc
-        { ti_name = ad_name
-        , ti_anchor = ad_anchor
-        , ti_descr = Just (DocText realDoc)
-        , ti_rhs = ad_rhs
-        }
-
-    | otherwise
-    = Nothing
-
 -- recognising Template and Choice instances
 
 

diff --git a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Types.hs b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Types.hs
@@ -77,6 +77,7 @@ data ModuleDoc = ModuleDoc
   , md_descr     :: Maybe DocText
   , md_templates :: [TemplateDoc]
   , md_templateInstances :: [TemplateInstanceDoc]
+  -- TODO This doesn’t make sense anymore now that we killed generic templates.
   , md_adts      :: [ADTDoc]
   , md_functions :: [FunctionDoc]
   , md_classes   :: [ClassDoc]

diff --git a/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs b/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs
@@ -204,8 +204,9 @@ generateRawDalfRule =
                     setPriority priorityGenerateDalf
                     -- Generate the map from package names to package hashes
                     pkgMap <- useNoFile_ GeneratePackageMap
+                    DamlEnv{envIsGenerated} <- getDamlServiceEnv
                     -- GHC Core to DAML LF
-                    case convertModule lfVersion pkgMap file core of
+                    case convertModule lfVersion pkgMap envIsGenerated file core of
                         Left e -> return ([e], Nothing)
                         Right v -> return ([], Just $ LF.simplifyModule v)
 
@@ -340,7 +341,8 @@ generateSerializedDalfRule options =
                         Just core -> fmap (first (diags ++)) $ do
                             -- lf conversion
                             pkgMap <- useNoFile_ GeneratePackageMap
-                            case convertModule lfVersion pkgMap file core of
+                            DamlEnv{envIsGenerated} <- getDamlServiceEnv
+                            case convertModule lfVersion pkgMap envIsGenerated file core of
                                 Left e -> pure ([e], Nothing)
                                 Right rawDalf -> do
                                     -- LF postprocessing

diff --git a/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Service/Daml.hs b/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Service/Daml.hs
@@ -68,6 +68,7 @@ data DamlEnv = DamlEnv
   -- This is used to avoid unnecessary GC calls.
   , envDamlLfVersion :: LF.Version
   , envSkipScenarioValidation :: SkipScenarioValidation
+  , envIsGenerated :: Bool
   }
 
 instance IsIdeGlobal DamlEnv
@@ -84,6 +85,7 @@ mkDamlEnv opts scenarioService = do
         , envPreviousScenarioContexts = previousScenarioContextsVar
         , envDamlLfVersion = optDamlLfVersion opts
         , envSkipScenarioValidation = optSkipScenarioValidation opts
+        , envIsGenerated = optIsGenerated opts
         }
 
 getDamlServiceEnv :: Action DamlEnv

diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
diff --git a/compiler/damlc/daml-stdlib-src/DA/Internal/Template.daml b/compiler/damlc/daml-stdlib-src/DA/Internal/Template.daml
@@ -105,11 +105,15 @@ class Template t => TemplateKey t k | t -> k where
   --    getting the contract instance.
 
   -- | The list of maintainers of a contract key.
-  maintainer : k -> [Party]
+  _maintainer : proxy t -> k -> [Party]
 
   _toAnyContractKey : proxy t -> k -> Any
   _fromAnyContractKey : proxy t -> Any -> Optional k
 
+-- | The list of maintainers of a contract key.
+maintainer : forall t k. TemplateKey t k => k -> [Party]
+maintainer = _maintainer ([] : [t])
+
 toAnyContractKey : forall t k. TemplateKey t k => k -> AnyContractKey
 toAnyContractKey k =
   AnyContractKey
@@ -148,8 +152,6 @@ data PostConsuming t = PostConsuming {}
 data Archive = Archive {}
   deriving (Eq, Show)
 
-data HasKey t = HasKey {}
-
 -- | Accepted ways to specify a list of parties: either a single party, or a list of parties.
 class IsParties a where
   -- | Convert to list of parties.

diff --git a/compiler/damlc/daml-visual/src/DA/Daml/Visual.hs b/compiler/damlc/daml-visual/src/DA/Daml/Visual.hs
@@ -145,12 +145,12 @@ startFromUpdate seen world update = case update of
 startFromExpr :: Set.Set (LF.Qualified LF.ExprValName) -> LF.World -> LF.Expr -> Set.Set Action
 startFromExpr seen world e = case e of
     LF.EVar _ -> Set.empty
-    -- NOTE(MH/RJR): Do not explore the `$fXInstance` dictionary because it
-    -- contains all the ledger actions and therefore creates too many edges
+    -- NOTE(MH/RJR): Do not explore the `$fChoice`/`$fTemplate` dictionaries because
+    -- they contain all the ledger actions and therefore creates too many edges
     -- in the graph. We instead detect calls to the `create`, `archive` and
     -- `exercise` methods from `Template` and `Choice` instances.
     LF.EVal (LF.Qualified _ _ (LF.ExprValName ref))
-        | "$f" `T.isPrefixOf` ref && "Instance" `T.isSuffixOf` ref -> Set.empty
+        | any (`T.isPrefixOf` ref) ["$fChoice", "$fTemplate"] -> Set.empty
     LF.EVal ref -> case LF.lookupValue ref world of
         Right LF.DefValue{..}
             | ref `Set.member` seen -> Set.empty

diff --git a/compiler/damlc/lib/DA/Cli/Damlc.hs b/compiler/damlc/lib/DA/Cli/Damlc.hs
@@ -629,7 +629,8 @@ execInspect inFile outFile jsonOutput lvl =
 
       if jsonOutput
       then do
-        archive :: PLF.ArchivePayload <- errorOnLeft "Cannot decode archive" (PS.fromByteString bytes)
+        payloadBytes <- PLF.archivePayload <$> errorOnLeft "Cannot decode archive" (PS.fromByteString bytes)
+        archive :: PLF.ArchivePayload <- errorOnLeft "Cannot decode archive payload" $ PS.fromByteString payloadBytes
         writeOutputBSL outFile
          $ Aeson.Pretty.encodePretty
          $ Proto.JSONPB.toAesonValue archive

diff --git a/compiler/damlc/tests/daml-test-files/ExerciseWithoutActors.daml b/compiler/damlc/tests/daml-test-files/ExerciseWithoutActors.daml
@@ -6,7 +6,7 @@
 -- uses actors as a sanity check.
 
 -- @SINCE-LF 1.5
--- @QUERY-LF [.modules[] | .values[] | select(.name_with_type | lf::get_value_name($pkg) == ["$$fFooInstance"]) | .expr | .. | objects | select(has("exercise")) | .exercise | has("actor") | not] | (length > 0 and all)
+-- @QUERY-LF [.modules[] | .values[] | select(.name_with_type | lf::get_value_name($pkg) == ["$$fChoiceFooBar$u0028$u0029"]) | .expr | .. | objects | select(has("exercise")) | .exercise | has("actor") | not] | (length > 0 and all)
 daml 1.2
 module ExerciseWithoutActors where
 

diff --git a/compiler/damlc/tests/daml-test-files/GenericTemplateError.daml b/compiler/damlc/tests/daml-test-files/GenericTemplateError.daml
@@ -1,7 +1,6 @@
 -- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
--- @ERROR range=12:24-12:32; Generic templates are not supported anymore.
--- @ERROR range=34:10-34:16; Generic templates are not supported anymore.
+-- @ERROR range=11:24-11:34; Generic templates are no longer supported
 
 daml 1.2
 module GenericTemplateError where

diff --git a/compiler/damlc/tests/src/DA/Test/ShakeIdeClient.hs b/compiler/damlc/tests/src/DA/Test/ShakeIdeClient.hs
@@ -1165,7 +1165,7 @@ visualDamlTests = Tasty.testGroup "Visual Tests"
             setFilesOfInterest [fetchTest]
             expectNoErrors
             expectedGraph fetchTest ( ExpectedGraph {expectedSubgraphs =
-                                        [ExpectedSubGraph {expectedNodes = ["Create","Archive","ReducedCoin"]
+                                        [ExpectedSubGraph {expectedNodes = ["Create","ReducedCoin","Archive"]
                                             , expectedTplFields = ["owner","amount"]
                                             , expectedTemplate = "Coin"}]
                               , expectedEdges = []})
@@ -1196,7 +1196,7 @@ visualDamlTests = Tasty.testGroup "Visual Tests"
                                    , expectedTplFields = ["owner"]
                                    , expectedTemplate = "Coin"
                                     }
-                , ExpectedSubGraph { expectedNodes = ["Create", "Archive", "Consume"]
+                , ExpectedSubGraph { expectedNodes = ["Create", "Consume", "Archive"]
                                    , expectedTplFields = ["owner"]
                                    , expectedTemplate = "TT"}]
 
@@ -1224,12 +1224,13 @@ visualDamlTests = Tasty.testGroup "Visual Tests"
             setFilesOfInterest [createTest]
             expectNoErrors
             expectedGraph createTest (ExpectedGraph
-                {expectedSubgraphs = [ExpectedSubGraph {expectedNodes = ["Create","Archive"]
+                {expectedSubgraphs = [ExpectedSubGraph {expectedNodes = ["Create","CreateCoin","Archive"]
+                                                        , expectedTplFields = ["owner"]
+                                                        , expectedTemplate = "TT"}
+                                     ,ExpectedSubGraph {expectedNodes = ["Create","Archive"]
                                                        , expectedTplFields = ["owner"]
                                                        , expectedTemplate = "Coin"}
-                                     , ExpectedSubGraph {expectedNodes = ["Create","Archive","CreateCoin"]
-                                                        , expectedTplFields = ["owner"]
-                                                        , expectedTemplate = "TT"}]
+                                     ]
                 , expectedEdges = [(ExpectedChoiceDetails {expectedConsuming = True, expectedName = "CreateCoin"}
                                    ,ExpectedChoiceDetails {expectedConsuming = False, expectedName = "Create"})]})