mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-20 01:07:18 +03:00
Desugar template instances to type synonyms instead of newtypes (#3013)
* Upgrade ghc-libs * Convert template instances as type synonyms to DAML-LF * Look for TEMPLATE_INSTANCE suffix for daml docs * Update desugaring documentation
This commit is contained in:
parent
cf21ad2e81
commit
5bcdb3e8a0
2
3rdparty/haskell/BUILD.ghc-lib-parser
vendored
2
3rdparty/haskell/BUILD.ghc-lib-parser
vendored
@ -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(
|
||||
|
@ -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(
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -23,3 +23,4 @@
|
||||
<a name="type-proposaliou-proposaliou-81988"></a>**template instance** [ProposalIou](#type-proposaliou-proposaliou-81988)
|
||||
|
||||
> = Proposal [Iou](#type-proposaliou-iou-51326)
|
||||
>
|
||||
|
@ -40,3 +40,4 @@ Template Instances
|
||||
|
||||
**template instance** `ProposalIou <type-proposaliou-proposaliou-81988_>`_
|
||||
\= Proposal `Iou <type-proposaliou-iou-51326_>`_
|
||||
|
||||
|
@ -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.
|
Loading…
Reference in New Issue
Block a user