Desugar template instances to type synonyms instead of newtypes (digi…

…tal-asset#3013) * Upgrade ghc-libs * Convert template instances as type synonyms to DAML-LF * Look for TEMPLATE_INSTANCE suffix for daml docs * Update desugaring documentation
conr2d · Sep 26, 2019 · 5bcdb3e · 5bcdb3e
1 parent cf21ad2
commit 5bcdb3e
Show file tree

Hide file tree

Showing 8 changed files with 44 additions and 39 deletions.
diff --git a/3rdparty/haskell/BUILD.ghc-lib-parser b/3rdparty/haskell/BUILD.ghc-lib-parser
@@ -52,7 +52,7 @@ haskell_library(
     "-I/compiler", "-I/compiler/utils"
   ],
   package_name = "ghc-lib-parser",
-  version = "8.8.1.20190916",
+  version = "8.8.1.20190925",
 )
 
 cc_library(

diff --git a/WORKSPACE b/WORKSPACE
@@ -484,12 +484,12 @@ GRPC_HASKELL_COMMIT = "11681ec6b99add18a8d1315f202634aea343d146"
 
 GRPC_HASKELL_HASH = "c6201f4e2fd39f25ca1d47b1dac4efdf151de88a2eb58254d61abc2760e58fda"
 
-GHC_LIB_VERSION = "8.8.1.20190918"
+GHC_LIB_VERSION = "8.8.1.20190925"
 
 http_archive(
     name = "haskell_ghc__lib__parser",
     build_file = "//3rdparty/haskell:BUILD.ghc-lib-parser",
-    sha256 = "c42c61ebdc241b2f42162c0cee1547d6acc33f32019730bcfb6441b9dd0b92ba",
+    sha256 = "02c71094a0bb06d6f6c4bbd444f9a26804c8eca423cc77fd3824ccd498ddaefe",
     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)],
 )
@@ -562,7 +562,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, "c42c61ebdc241b2f42162c0cee1547d6acc33f32019730bcfb6441b9dd0b92ba", "1305b7959d4ee9cdb95d51e6a6f87664a8311cd84c36a8d5e496ce523c203d0d") +
+            hazel_ghclibs(GHC_LIB_VERSION, "02c71094a0bb06d6f6c4bbd444f9a26804c8eca423cc77fd3824ccd498ddaefe", "4aa88ed404dcf8a67f712ad37d8ad9f4ed51fe6180c15978a97034acf7dee834") +
             hazel_github_external("digital-asset", "hlint", "f407a620cf38821320fb000e6ccd52f6bb081fc6", "5b5429a332910ebec481fe0f99ffce3159b10aef9188ba661512f8267fcde9a8") +
             hazel_github_external("awakesecurity", "proto3-wire", "4f355bbac895d577d8a28f567ab4380f042ccc24", "031e05d523a887fbc546096618bc11dceabae224462a6cdd6aab11c1658e17a3") +
             hazel_github_external(

diff --git a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract.hs b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract.hs
@@ -114,12 +114,14 @@ extractDocs extractOpts diagsLogger ideOpts fp = do
             md_functions = mapMaybe (getFctDocs ctx) dc_decls
             md_instances = map (getInstanceDocs ctx) dc_insts
 
-            filteredAdts -- all ADT docs without templates or choices
+            -- Type constructor docs without data types corresponding to
+            -- templates and choices
+            filteredTyCons
                 = MS.elems . MS.withoutKeys typeMap . Set.unions
                 $ dc_templates : MS.elems dc_choices
 
             (md_adts, md_templateInstances) =
-                partitionEithers . flip map filteredAdts $ \adt ->
+                partitionEithers . flip map filteredTyCons $ \adt ->
                     case getTemplateInstanceDoc adt of
                         Nothing -> Left adt
                         Just ti -> Right ti
@@ -180,16 +182,17 @@ data DeclData = DeclData
 
 buildDocCtx :: ExtractOptions -> TypecheckedModule -> DocCtx
 buildDocCtx dc_extractOptions dc_tcmod  =
-    let dc_ghcMod = ms_mod . pm_mod_summary . tm_parsed_module $ dc_tcmod
+    let parsedMod = tm_parsed_module dc_tcmod
+        checkedModInfo = tm_checked_module_info dc_tcmod
+        dc_ghcMod = ms_mod $ pm_mod_summary parsedMod
         dc_modname = getModulename dc_ghcMod
         dc_decls
             = map (uncurry DeclData) . collectDocs . hsmodDecls . unLoc
-            . pm_parsed_source . tm_parsed_module $ dc_tcmod
-        (dc_templates, dc_choices)
-            = getTemplateData . tm_parsed_module $ dc_tcmod
+            . pm_parsed_source $ parsedMod
+        (dc_templates, dc_choices) = getTemplateData parsedMod
 
-        tythings = modInfoTyThings . tm_checked_module_info $ dc_tcmod
-        dc_insts = modInfoInstances . tm_checked_module_info $ dc_tcmod
+        tythings = modInfoTyThings checkedModInfo
+        dc_insts = modInfoInstances checkedModInfo
 
         dc_tycons = MS.fromList
             [ (typename, tycon)
@@ -209,7 +212,7 @@ buildDocCtx dc_extractOptions dc_tcmod  =
             , let fieldname = Fieldname . packId $ id
             ]
 
-        dc_exports = extractExports . tm_parsed_module $ dc_tcmod
+        dc_exports = extractExports parsedMod
 
     in DocCtx {..}
 
@@ -497,28 +500,29 @@ getTemplateDocs DocCtx{..} typeMap templateInstanceMap =
                       [] -> [] -- catching the dummy case here, see above
                       _other -> error "getFields: found multiple constructors"
 
--- | A template instance is desugared into a newtype with a docs marker.
+-- | A template instance is desugared to a type synonym with a doc marker.
+--
 -- For example,
 --
 -- @template instance ProposalIou = Proposal Iou@
 --
--- becomes
+-- leads to the `type` declaration
 --
--- @newtype ProposalIou = ProposalIou (Proposal Iou) -- ^ TEMPLATE_INSTANCE@
+-- @--| TEMPLATE_INSTANCE@
+-- @type ProposalIou = Proposal Iou@
 --
--- So the goal of this function is to extract the template instance doc
--- from the newtype doc if it exists.
+-- 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 adt
-    | ADTDoc{..} <- adt
-    , [PrefixC{..}] <- ad_constrs
-    , Just (DocText "TEMPLATE_INSTANCE") <- ac_descr
-    , [argType] <- ac_args
+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 = ad_descr
-        , ti_rhs = argType
+        , ti_descr = Just (DocText realDoc)
+        , ti_rhs = ad_rhs
         }
 
     | otherwise

diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
@@ -158,7 +158,7 @@ data Env = Env
     ,envAliases :: MS.Map Var LF.Expr
     ,envPkgMap :: MS.Map GHC.UnitId T.Text
     ,envLfVersion :: LF.Version
-    ,envNewtypes :: [(GHC.Type, TyCon)]
+    ,envTypeSynonyms :: [(GHC.Type, TyCon)]
     ,envInstances :: [(TyCon, [GHC.Type])]
     }
 
@@ -315,10 +315,10 @@ convertModule lfVersion pkgMap file x = runConvertM (ConversionEnv file Nothing)
                 | otherwise -> [(name, body)]
               Rec binds -> binds
           ]
-        newtypes =
+        typeSynonyms =
           [ (wrappedT, t)
           | ATyCon t <- eltsUFM (cm_types x)
-          , Just ([], wrappedT, _co) <- [unwrapNewTyCon_maybe t]
+          , Just ([], wrappedT) <- [synTyConDefn_maybe t]
           ]
         instances =
             [ (c, ts)
@@ -333,7 +333,7 @@ convertModule lfVersion pkgMap file x = runConvertM (ConversionEnv file Nothing)
           , envAliases = MS.empty
           , envPkgMap = pkgMap
           , envLfVersion = lfVersion
-          , envNewtypes = newtypes
+          , envTypeSynonyms = typeSynonyms
           , envInstances = instances
           }
 
@@ -476,7 +476,7 @@ convertGenericTemplate env x
     findMonoTyp :: GHC.Type -> Maybe TyCon
     findMonoTyp t = case t of
         TypeCon tcon [] -> Just tcon
-        t -> snd <$> find (eqType t . fst) (envNewtypes env)
+        t -> snd <$> find (eqType t . fst) (envTypeSynonyms env)
     this = mkVar "this"
     self = mkVar "self"
     arg = mkVar "arg"
@@ -496,11 +496,10 @@ convertTypeDef env (ATyCon t)
   , getOccFS t `elementOfUniqSet` internalTypes
   = pure []
 convertTypeDef env (ATyCon t)
-    -- NOTE(MH): We detect `newtype` definitions produced by the desugring
+    -- NOTE(MH): We detect type synonyms produced by the desugring
     -- of `template instance` declarations and inline the record definition
     -- of the generic template.
-    | isNewTyCon t
-    , ([], TypeCon tpl args) <- newTyConRhs t
+    | Just ([], TypeCon tpl args) <- synTyConDefn_maybe t
     , any (\(c, args') -> getOccFS c == getOccFS tpl <> "Instance" && eqTypes args args') $ envInstances env
     = do
         ctors0 <- toCtors env tpl

diff --git a/compiler/damlc/tests/daml-test-files/ProposalDesugared.daml b/compiler/damlc/tests/daml-test-files/ProposalDesugared.daml
@@ -177,7 +177,7 @@ instance IouInstance where
 
 -- The instantiation of the generic `Proposal a` template for `a = Iou`
 -- in its deugared form.
-newtype ProposalIou = ProposalIou (Proposal Iou) -- ^ TEMPLATE_INSTANCE
+type ProposalIou = Proposal Iou -- ^ TEMPLATE_INSTANCE
 
 instance ProposalInstance Iou where
 

diff --git a/compiler/damlc/tests/daml-test-files/ProposalIou.EXPECTED.md b/compiler/damlc/tests/daml-test-files/ProposalIou.EXPECTED.md
@@ -23,3 +23,4 @@
 <a name="type-proposaliou-proposaliou-81988"></a>**template instance** [ProposalIou](#type-proposaliou-proposaliou-81988)
 
 > = Proposal [Iou](#type-proposaliou-iou-51326)
+> 
diff --git a/compiler/damlc/tests/daml-test-files/ProposalIou.EXPECTED.rst b/compiler/damlc/tests/daml-test-files/ProposalIou.EXPECTED.rst
@@ -40,3 +40,4 @@ Template Instances
 
 **template instance** `ProposalIou <type-proposaliou-proposaliou-81988_>`_
   \= Proposal `Iou <type-proposaliou-iou-51326_>`_
+
diff --git a/ghc-lib/template-desugaring.md b/ghc-lib/template-desugaring.md
@@ -116,7 +116,7 @@ instance IouInstance => Template Iou where
   fetch = fetchIou
   archive = archiveIou
 
-instance IouInstance where
+instance IouInstance
 ```
 
 When a type `t` is a `Template` instance, `class Choice` (defined by the DAML standard library) defines a (multi-parameter type class) relation on types `t`, `c` and `r` such that `r` is uniquely determined by the pair `(t, c)`:
@@ -216,7 +216,7 @@ class EnrollmentInstance where
   exerciseEnrollmentArchive : ContractId Enrollment -> Archive -> Update ()
   exerciseEnrollmentArchive = magic @"archive"
 
-instance EnrollmentInstance where
+instance EnrollmentInstance
 
 instance EnrollmentInstance => Template Enrollment where
   signatory = signatoryEnrollment
@@ -355,8 +355,8 @@ The name `ProposalIou` is not needed in DAML code but is required when creating
 The `template instance` desugars to the following declarations.
 
 ```haskell
-newtype ProposalIou = ProposalIou (Proposal Iou)
-instance ProposalInstance Iou where
+type ProposalIou = Proposal Iou
+instance ProposalInstance Iou
 ```
 
-The `instance` here simply leverages the implementation of the `ProposalInstance` class.
+The `instance` here simply leverages the implementation of the `ProposalInstance` class.
Original file line number	Diff line number	Diff line change
Expand Up		@@ -23,3 +23,4 @@
		<a name="type-proposaliou-proposaliou-81988"></a>template instance [ProposalIou](#type-proposaliou-proposaliou-81988)

		> = Proposal [Iou](#type-proposaliou-iou-51326)
		>
Original file line number	Diff line number	Diff line change
Expand Up		@@ -40,3 +40,4 @@ Template Instances

		template instance `ProposalIou <type-proposaliou-proposaliou-81988_>`_
		\= Proposal `Iou <type-proposaliou-iou-51326_>`_