Skip to content

Commit

Permalink
New template desugaring (digital-asset#2178)
Browse files Browse the repository at this point in the history 
* Update ghc-libs to use new template desugaring
* Replace old template typeclasses with generic-friendly ones
* New template desugaring doc
* Fix tests
* Fix damldoc tests regarding Archive choice
* Update visualisation code to not traverse master dictionary
* Additional class method stubs to template instance declaration for upgrades
* Increase stack limit for bond trading compilation test
* Update hlint version
  • Loading branch information
@rohanjr
rohanjr authored Jul 30, 2019
1 parent b3dac78 commit e6a4d8b
Show file tree
Hide file tree
Showing 28 changed files with 589 additions and 574 deletions.
2 changes: 1 addition & 1 deletion 3rdparty/haskell/BUILD.ghc-lib-parser
View file
Original file line number Diff line number Diff line change
Expand Up @@ -52,7 +52,7 @@ haskell_library(
"-I/compiler", "-I/compiler/utils"
],
package_name = "ghc-lib-parser",
version = "8.8.0.20190723",
version = "8.8.0.20190730.1",
)

cc_library(
Expand Down
11 changes: 5 additions & 6 deletions WORKSPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -464,12 +464,12 @@ HASKELL_LSP_COMMIT = "d73e2ccb518724e6766833ee3d7e73289cbe0018"

HASKELL_LSP_HASH = "36b92431039e6289eb709b8872f5010a57d4a45e637e1c1c945bdb3128586081"

GHC_LIB_VERSION = "8.8.0.20190723"
GHC_LIB_VERSION = "8.8.0.20190730.1"

http_archive(
name = "haskell_ghc__lib__parser",
build_file = "//3rdparty/haskell:BUILD.ghc-lib-parser",
sha256 = "139c5b58d179a806640f8b56bc3fe8c70a893191dbfd111a593544e7ac71086b",
sha256 = "dcd211cac831609cec546050b342ca94a546cb4e672cf2819189332f49361baf",
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)],
)
Expand Down Expand Up @@ -517,18 +517,17 @@ hazel_repositories(
packages = add_extra_packages(
extra =

# Read [Working on ghc-lib] for ghc-lib update
# instructions at
# Read [Working on ghc-lib] for ghc-lib update instructions at
# https://github.com/DACH-NY/daml/blob/master/ghc-lib/working-on-ghc-lib.md.
hazel_ghclibs(GHC_LIB_VERSION, "139c5b58d179a806640f8b56bc3fe8c70a893191dbfd111a593544e7ac71086b", "7cfbe3bd12fb38685b86096ad666790326020308138eaf49198631b8792f5b2a") +
hazel_ghclibs(GHC_LIB_VERSION, "dcd211cac831609cec546050b342ca94a546cb4e672cf2819189332f49361baf", "6e144d99bc43e861a2895e0c34d73964305db2ad634f14d3e3a41cf0c4523495") +

# Support for Hlint:
# - Requires haskell-src-exts 1.21.0 so override hazel/packages.bzl.
# - To build the binary : `bazel build @haskell_hlint//:bin`
# - To build the library : `bazel build @haskell_hlint//:lib`
# We'll be using it via the library, not the binary.
hazel_hackage("haskell-src-exts", "1.21.0", "95dac187824edfa23b6a2363880b5e113df8ce4a641e8a0f76e6d45aaa699ff3") +
hazel_github_external("digital-asset", "hlint", "b007fb1f9acfb1342af57d07c96149235e105b50", "61fdbd214a101653ac21cfdfd7da34e4ad4dacfe74dc841dbd782622213bff57") +
hazel_github_external("digital-asset", "hlint", "f3d3acad10c9a4418a6fcad002087fc527f15d3d", "dbd091a6d59bf2d3cc387ab4a0ffc50ffad3242b808e7205ccceef49aed682f8") +
hazel_github_external("awakesecurity", "proto3-wire", "43d8220dbc64ef7cc7681887741833a47b61070f", "1c3a7fbf4ab3308776675c6202583f9750de496757f3ad4815e81edd122d75e1") +
hazel_github_external("awakesecurity", "proto3-suite", "dd01df7a3f6d0f1ea36125a67ac3c16936b53da0", "59ea7b876b14991347918eefefe24e7f0e064b5c2cc14574ac4ab5d6af6413ca") +
hazel_hackage("happy", "1.19.10", "22eb606c97105b396e1c7dc27e120ca02025a87f3e44d2ea52be6a653a52caed") +
Expand Down
132 changes: 66 additions & 66 deletions compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Upgrade.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -231,7 +231,6 @@ generateSrcFromLf (Qualify qualify) thisPkgId pkgMap m = noLoc mod
noLoc $
mkRdrQual (mkModuleName "DA.Internal.Template") $
mkOccName varName "Template" :: LHsType GhcPs
sigRdrName = noLoc $ mkRdrUnqual $ mkOccName varName "signatory"
errTooManyNameComponents cs =
error $
"Internal error: Dalf contains type constructors with more than two name components: " <>
Expand All @@ -244,6 +243,71 @@ generateSrcFromLf (Qualify qualify) thisPkgId pkgMap m = noLoc mod
, length dataTyCon == 2
, LF.DataRecord fs <- [dataCons]
]
templateMethodNames =
map mkRdrName
[ "signatory"
, "observer"
, "agreement"
, "fetch"
, "ensure"
, "create"
, "archive"
]
classMethodStub :: Located RdrName -> LHsBindLR GhcPs GhcPs
classMethodStub funName =
noLoc $
FunBind
{ fun_ext = noExt
, fun_id = funName
, fun_matches =
MG
{ mg_ext = noExt
, mg_alts =
noLoc
[ noLoc $
Match
{ m_ext = noExt
, m_ctxt =
FunRhs
{ mc_fun = funName
, mc_fixity = Prefix
, mc_strictness = NoSrcStrict
}
, m_pats = []
, m_rhs_sig = Nothing
, m_grhss =
GRHSs
{ grhssExt = noExt
, grhssGRHSs =
[ noLoc $
GRHS
noExt
[]
(noLoc $
HsApp
noExt
(noLoc $
HsVar
noExt
(noLoc
error_RDR))
(noLoc $
HsLit noExt $
HsString
NoSourceText $
mkFastString
"undefined template class method in generated code"))
]
, grhssLocalBinds =
noLoc emptyLocalBinds
}
}
]
, mg_origin = Generated
}
, fun_co_fn = WpHole
, fun_tick = []
}
decls =
concat $ do
LF.DefDataType {..} <- NM.toList $ LF.moduleDataTypes m
Expand Down Expand Up @@ -303,71 +367,7 @@ generateSrcFromLf (Qualify qualify) thisPkgId pkgMap m = noLoc mod
HsAppTy noExt templateTy $
noLoc $ convType templType
}
, cid_binds =
listToBag
[ noLoc $
FunBind
{ fun_ext = noExt
, fun_id = sigRdrName
, fun_matches =
MG
{ mg_ext = noExt
, mg_alts =
noLoc
[ noLoc $
Match
{ m_ext =
noExt
, m_ctxt =
FunRhs
{ mc_fun =
sigRdrName
, mc_fixity =
Prefix
, mc_strictness =
NoSrcStrict
}
, m_pats = []
, m_rhs_sig =
Nothing
, m_grhss =
GRHSs
{ grhssExt =
noExt
, grhssGRHSs =
[ noLoc $
GRHS
noExt
[
]
(noLoc $
HsApp
noExt
(noLoc $
HsVar
noExt
(noLoc
error_RDR))
(noLoc $
HsLit
noExt $
HsString
NoSourceText $
mkFastString
"undefined template class method in generated code"))
]
, grhssLocalBinds =
noLoc
emptyLocalBinds
}
}
]
, mg_origin = Generated
}
, fun_co_fn = WpHole
, fun_tick = []
}
]
, cid_binds = listToBag $ map classMethodStub templateMethodNames
, cid_sigs = []
, cid_tyfam_insts = []
, cid_datafam_insts = []
Expand Down
7 changes: 5 additions & 2 deletions compiler/damlc/daml-doc/test/DA/Daml/GHC/Damldoc/Tests.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -153,7 +153,7 @@ unitTests =
check $ isNothing $ td_descr t
f1 <- getSingle $ td_payload t
check $ isNothing $ fd_descr f1
ch <- getSingle $ td_choices t
ch <- getSingle $ td_choicesWithoutArchive t
f2 <- getSingle $ cd_fields ch
check $ Just "field" == fd_descr f2))

Expand All @@ -177,7 +177,7 @@ unitTests =
("Expected two choices in doc, got " <> show md)
(isJust $ do t <- getSingle $ md_templates md
check $ isNothing $ td_descr t
cs <- Just $ td_choices t
cs <- Just $ td_choicesWithoutArchive t
check $ length cs == 2
check $ ["DoMore", "DoSomething"] == sort (map cd_name cs)))

Expand Down Expand Up @@ -208,6 +208,9 @@ unitTests =
check True = Just ()
check False = Nothing

td_choicesWithoutArchive :: TemplateDoc -> [ChoiceDoc]
td_choicesWithoutArchive = filter (\ch -> cd_name ch /= "External:Archive") . td_choices


testModule :: String
testModule = "Testfile"
Expand Down
4 changes: 2 additions & 2 deletions compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -345,8 +345,8 @@ convertGenericTemplate env x
let applyThis e = ETmApp e $ unwrapTpl $ EVar this
tplSignatories <- applyThis <$> convertExpr env (Var signatories)
tplObservers <- applyThis <$> convertExpr env (Var observers)
let tplPrecondition = ETrue
let tplAgreement = mkEmptyText
tplPrecondition <- applyThis <$> convertExpr env (Var ensure)
tplAgreement <- applyThis <$> convertExpr env (Var agreement)
archive <- convertExpr env (Var archive)
(tplKey, key, choices) <- case keyAndChoices of
hasKey : key : maintainers : _fetchByKey : _lookupByKey : choices
Expand Down
13 changes: 6 additions & 7 deletions compiler/damlc/daml-stdlib-src/DA/Internal/Desugar.daml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,14 +7,13 @@ daml 1.2

-- | Automatically imported qualified in every module.
module DA.Internal.Desugar (
concat,
Template(ensure, signatory, observer, agreement),
TemplateKey(key, maintainer),
Choice(consuming, choiceController, choice), preconsuming, nonconsuming, postconsuming, NoEvent(..),
IsParties(toParties),
Eq(..),
Show(..)
module DA.Internal.Template,
Eq(..), Show(..),
Bool(..), Text, Optional,
concat, magic,
Party, ContractId, Update
) where

import DA.Internal.Prelude
import DA.Internal.Template
import DA.Internal.LF
2 changes: 1 addition & 1 deletion compiler/damlc/daml-stdlib-src/DA/Internal/LF.daml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,7 +38,7 @@ module DA.Internal.LF
, unpackPair
) where

import GHC.Types (Opaque, Symbol, magic)
import GHC.Types (Opaque, Symbol)
import DA.Internal.Prelude

-- | The `Party` type represents a party to a contract.
Expand Down
2 changes: 1 addition & 1 deletion compiler/damlc/daml-stdlib-src/DA/Internal/Prelude.daml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,7 @@ import GHC.Real as GHC (fromRational)
import GHC.Show as GHC
import DA.Types as GHC (Either(..))
import GHC.Tuple()
import GHC.Types as GHC (Bool (..), Int, Ordering (..), Text, Decimal, ifThenElse, primitive)
import GHC.Types as GHC (Bool (..), Int, Ordering (..), Text, Decimal, ifThenElse, primitive, magic)

infixr 0 $
-- | Take a function from `a` to `b` and a value of type `a`, and apply the
Expand Down
Loading

0 comments on commit e6a4d8b

Please sign in to comment.