diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Pretty.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Pretty.hs index bba94a80587f..68c81bbb8bce 100644 --- a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Pretty.hs +++ b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Pretty.hs @@ -566,7 +566,7 @@ instance Pretty DefDataType where DataEnum enums -> (keyword_ "enum" <-> lhsDoc) $$ nest 2 (vcat (map pPrintEnumCon enums)) DataInterface -> - keyword_ "interface" + keyword_ "interface" <-> pPrint tcon where lhsDoc = serializableDoc <-> pPrint tcon <-> hsep (map (pPrintAndKind lvl precParam) params) <-> "=" diff --git a/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DataDependencies.hs b/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DataDependencies.hs index d2aadc487a13..6b30a83a40df 100644 --- a/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DataDependencies.hs +++ b/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DataDependencies.hs @@ -28,6 +28,7 @@ import qualified Data.NameMap as NM import qualified Data.Text as T import Development.IDE.Types.Location import GHC.Generics (Generic) +import GHC.Stack import Safe import System.FilePath @@ -52,11 +53,13 @@ import qualified DA.Daml.LF.TypeChecker.Env as LF import qualified DA.Daml.LF.TypeChecker.Error as LF import qualified DA.Daml.LFConversion.MetadataEncoding as LFC import DA.Daml.Options +import DA.Daml.UtilGHC (fsFromText) import SdkVersion -panicOnError :: Either LF.Error a -> a -panicOnError (Left e) = error $ "Internal LF type error: " <> renderPretty e +panicOnError :: HasCallStack => Either LF.Error a -> a +panicOnError (Left e) = + withFrozenCallStack $ error $ "Internal LF type error: " <> renderPretty e panicOnError (Right a) = a -- | Newtype wrapper around an LF type where all type synonyms have been expanded. @@ -330,6 +333,7 @@ generateSrcFromLf env = noLoc mod , synonymDecls , dataTypeDecls , valueDecls + , interfaceDecls ] instDecls <- sequence instanceDecls pure $ decls <> catMaybes instDecls @@ -505,8 +509,17 @@ generateSrcFromLf env = noLoc mod -- convDataCons. [dataTypeCon0] <- [LF.unTypeConName dataTypeCon] let occName = mkOccName varName (T.unpack dataTypeCon0) - [ mkDataDecl env thisModule occName dataParams =<< - convDataCons dataTypeCon0 dataCons ] + pure $ do + ctxt <- noLoc <$> do + if NM.name dtype `NM.member` LF.moduleInterfaces (envMod env) then do + -- We add the DamlInterface context so LFConversion + -- picks this up as an interface + interface <- mkGhcType env "DamlInterface" + pure [noLoc interface] + else + pure [] + cons <- convDataCons dataTypeCon0 dataCons + mkDataDecl env thisModule ctxt occName dataParams cons valueDecls :: [Gen (LHsDecl GhcPs)] valueDecls = do @@ -583,6 +596,38 @@ generateSrcFromLf env = noLoc mod | otherwise = pure emptyBag + interfaceDecls :: [Gen (LHsDecl GhcPs)] + interfaceDecls = do + interface <- NM.toList $ LF.moduleInterfaces $ envMod env + [interfaceName] <- [LF.unTypeConName $ LF.intName interface] + let interfaceType = HsTyVar noExt NotPromoted $ mkRdrName interfaceName + meth <- NM.toList $ LF.intMethods interface + pure $ do + methodType <- convType env reexportedClasses $ LF.ifmType meth + cls <- mkDesugarType env "HasMethod" + let methodNameSymbol = HsTyLit noExt $ HsStrTy NoSourceText $ fsFromText $ LF.unMethodName $ LF.ifmName meth + args = + [ interfaceType + , methodNameSymbol + , methodType + ] + sig :: LHsSigType GhcPs + sig = + HsIB noExt $ noLoc $ + foldl' + (HsAppTy noExt . noLoc) + cls + (map noLoc args) + pure $ noLoc . InstD noExt . ClsInstD noExt $ ClsInstDecl + { cid_ext = noExt + , cid_poly_ty = sig + , cid_binds = emptyBag + , cid_sigs = [] + , cid_tyfam_insts = [] + , cid_datafam_insts = [] + , cid_overlap_mode = Nothing + } + hiddenRefMap :: HMS.HashMap Ref Bool hiddenRefMap = envHiddenRefMap env @@ -642,8 +687,7 @@ generateSrcFromLf env = noLoc mod | conName <- cons ] - -- TODO https://github.com/digital-asset/daml/issues/12051 - LF.DataInterface -> error "interfaces are not implemented" + LF.DataInterface -> pure [] where occName = mkOccName varName (T.unpack dataTypeCon0) occNameFor (LF.VariantConName c) = mkOccName varName (T.unpack c) @@ -716,8 +760,8 @@ mkConRdr env thisModule | envQualifyThisModule env = mkOrig thisModule | otherwise = mkRdrUnqual -mkDataDecl :: Env -> Module -> OccName -> [(LF.TypeVarName, LF.Kind)] -> [LConDecl GhcPs] -> Gen (LHsDecl GhcPs) -mkDataDecl env thisModule occName tyVars cons = do +mkDataDecl :: Env -> Module -> LHsContext GhcPs -> OccName -> [(LF.TypeVarName, LF.Kind)] -> [LConDecl GhcPs] -> Gen (LHsDecl GhcPs) +mkDataDecl env thisModule ctxt occName tyVars cons = do tyVars' <- mapM (convTyVarBinder env) tyVars pure . noLoc . TyClD noExt $ DataDecl { tcdDExt = noExt @@ -728,7 +772,7 @@ mkDataDecl env thisModule occName tyVars cons = do HsDataDefn { dd_ext = noExt , dd_ND = DataType - , dd_ctxt = noLoc [] + , dd_ctxt = ctxt , dd_cType = Nothing , dd_kindSig = Nothing , dd_cons = cons @@ -1036,6 +1080,10 @@ mkLfInternalType :: Env -> String -> Gen (HsType GhcPs) mkLfInternalType env = mkStableType env damlStdlib $ LF.ModuleName ["DA", "Internal", "LF"] +mkDesugarType :: Env -> String -> Gen (HsType GhcPs) +mkDesugarType env = mkStableType env primUnitId $ + LF.ModuleName ["DA", "Internal", "Desugar"] + mkLfInternalPrelude :: Env -> String -> Gen (HsType GhcPs) mkLfInternalPrelude env = mkStableType env damlStdlib $ LF.ModuleName ["DA", "Internal", "Prelude"] @@ -1071,6 +1119,7 @@ generateSrcPkgFromLf envConfig pkg = do , "{-# LANGUAGE UndecidableInstances #-}" , "{-# LANGUAGE AllowAmbiguousTypes #-}" , "{-# LANGUAGE MagicHash #-}" + , "{-# LANGUAGE DatatypeContexts #-}" , "{-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-methods -Wno-deprecations #-}" ] @@ -1164,8 +1213,7 @@ refsFromDataCons = \case LF.DataRecord fields -> foldMap (refsFromType . snd) fields LF.DataVariant cons -> foldMap (refsFromType . snd) cons LF.DataEnum _ -> mempty - -- TODO https://github.com/digital-asset/daml/issues/12051 - LF.DataInterface -> error "interfaces are not implemented" + LF.DataInterface -> mempty rootRefs :: Config -> LF.World -> DL.DList Ref rootRefs config world = fold diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs index 075b8dfb3e8f..de556fa8507a 100644 --- a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs +++ b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs @@ -1091,6 +1091,7 @@ convertBind env (name, x) = pure [] -- HasMethod instances are only used for desugaring. + -- In data-dependencies, they are reconstructed from the interface definition. | DFunId _ <- idDetails name , TypeCon hasMethodCls _ <- varType name , NameIn DA_Internal_Desugar "HasMethod" <- hasMethodCls diff --git a/compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs b/compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs index 7cd2e38eb2d7..bf518939a69a 100644 --- a/compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs +++ b/compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs @@ -380,6 +380,7 @@ baseImports = , "DA.Internal.Template.Functions" , "DA.Internal.LF" , "DA.Internal.Prelude" + , "DA.Internal.Desugar" , "DA.Internal.Down" , "DA.NonEmpty.Types" , "DA.Semigroup.Types" diff --git a/compiler/damlc/tests/BUILD.bazel b/compiler/damlc/tests/BUILD.bazel index e06dd9b994c0..a7cca6ff945b 100644 --- a/compiler/damlc/tests/BUILD.bazel +++ b/compiler/damlc/tests/BUILD.bazel @@ -4,7 +4,7 @@ load("//bazel_tools:haskell.bzl", "da_haskell_binary", "da_haskell_library", "da_haskell_test") load("@os_info//:os_info.bzl", "is_windows") load(":util.bzl", "damlc_compile_test") -load("//rules_daml:daml.bzl", "daml_compile", "daml_compile_with_dalf") +load("//rules_daml:daml.bzl", "daml_build_test", "daml_compile", "daml_compile_with_dalf", "daml_test") load("@build_environment//:configuration.bzl", "sdk_version") load("//daml-lf/language:daml-lf.bzl", "COMPILER_LF_VERSIONS", "lf_version_configuration") load("//compiler/damlc:util.bzl", "ghc_pkg") diff --git a/compiler/damlc/tests/src/DA/Test/DataDependencies.hs b/compiler/damlc/tests/src/DA/Test/DataDependencies.hs index df83e718c2b1..9517ffc5a1e3 100644 --- a/compiler/damlc/tests/src/DA/Test/DataDependencies.hs +++ b/compiler/damlc/tests/src/DA/Test/DataDependencies.hs @@ -12,7 +12,7 @@ import DA.Daml.StablePackages (numStablePackagesForVersion) import DA.Test.Process import DA.Test.Util import qualified Data.ByteString.Lazy as BSL -import Data.List (sort, (\\)) +import Data.List (intercalate, sort, (\\)) import qualified Data.NameMap as NM import Module (unitIdString) import System.Directory.Extra @@ -1401,6 +1401,247 @@ tests tools@Tools{damlc,validate,oldProjDar} = testGroup "Data Dependencies" $ , "x = e" ] + , dataDependenciesTestOptions "implement interface from data-dependency" + [ "--target=1.dev" ] + [ (,) "Lib.daml" + [ "module Lib where" + + , "interface Token where" + , " getOwner : Party -- ^ A method comment." + , " getAmount : Int" + , " setAmount : Int -> Token" + + , " splitImpl : Int -> Update (ContractId Token, ContractId Token)" + , " transferImpl : Party -> Update (ContractId Token)" + , " noopImpl : () -> Update ()" + + , " ensure (getAmount this >= 0)" + + , " choice Split : (ContractId Token, ContractId Token) -- ^ An interface choice comment." + , " with" + , " splitAmount : Int -- ^ A choice field comment." + , " controller getOwner this" + , " do" + , " splitImpl this splitAmount" + + , " choice Transfer : ContractId Token" + , " with" + , " newOwner : Party" + , " controller getOwner this, newOwner" + , " do" + , " transferImpl this newOwner" + + , " nonconsuming choice Noop : ()" + , " with" + , " nothing : ()" + , " controller getOwner this" + , " do" + , " noopImpl this nothing" + + , " choice GetRich : ContractId Token" + , " with" + , " byHowMuch : Int" + , " controller getOwner this" + , " do" + , " assert (byHowMuch > 0)" + , " create $ setAmount this (getAmount this + byHowMuch)" + ] + ] + [ + (,) "Main.daml" + [ "module Main where" + , "import Lib" + , "import DA.Assert" + + , "template Asset" + , " with" + , " issuer : Party" + , " owner : Party" + , " amount : Int" + , " where" + , " signatory issuer, owner" + , " implements Token where" + , " let getOwner = owner" + , " let getAmount = amount" + , " let setAmount = \\x -> toInterface @Token (this with amount = x)" + + , " let splitImpl = \\splitAmount -> do" + , " assert (splitAmount < amount)" + , " cid1 <- create this with amount = splitAmount" + , " cid2 <- create this with amount = amount - splitAmount" + , " pure (toInterfaceContractId @Token cid1, toInterfaceContractId @Token cid2)" + + , " let transferImpl = \\newOwner -> do" + , " cid <- create this with owner = newOwner" + , " pure (toInterfaceContractId @Token cid)" + + , " let noopImpl = \\nothing -> do" + , " [1] === [1] -- make sure `mkMethod` calls are properly erased in the presence of polymorphism." + , " pure ()" + + , "main = scenario do" + , " p <- getParty \"Alice\"" + , " p `submitMustFail` do" + , " create Asset with" + , " issuer = p" + , " owner = p" + , " amount = -1" + , " p `submit` do" + , " cidAsset1 <- create Asset with" + , " issuer = p" + , " owner = p" + , " amount = 15" + , " let cidToken1 = toInterfaceContractId @Token cidAsset1" + , " _ <- exercise cidToken1 (Noop ())" + , " (cidToken2, cidToken3) <- exercise cidToken1 (Split 10)" + , " token2 <- fetch cidToken2" + , " -- Party is duplicated because p is both observer & issuer" + , " signatory token2 === [p, p]" + , " getAmount token2 === 10" + , " case fromInterface token2 of" + , " None -> abort \"expected Asset\"" + , " Some Asset {amount} ->" + , " amount === 10" + , " token3 <- fetch cidToken3" + , " getAmount token3 === 5" + , " case fromInterface token3 of" + , " None -> abort \"expected Asset\"" + , " Some Asset {amount} ->" + , " amount === 5" + + , " cidToken4 <- exercise cidToken3 (GetRich 20)" + , " token4 <- fetch cidToken4" + , " getAmount token4 === 25" + , " case fromInterface token4 of" + , " None -> abort \"expected Asset\"" + , " Some Asset {amount} ->" + , " amount === 25" + + , " pure ()" + ] + ] + + , dataDependenciesTestOptions "use interface from data-dependency" + [ "--target=1.dev" ] + [ (,) "Lib.daml" + [ "module Lib where" + , "import DA.Assert" + + , "interface Token where" + , " getOwner : Party -- ^ A method comment." + , " getAmount : Int" + , " setAmount : Int -> Token" + + , " splitImpl : Int -> Update (ContractId Token, ContractId Token)" + , " transferImpl : Party -> Update (ContractId Token)" + , " noopImpl : () -> Update ()" + + , " ensure (getAmount this >= 0)" + + , " choice Split : (ContractId Token, ContractId Token) -- ^ An interface choice comment." + , " with" + , " splitAmount : Int -- ^ A choice field comment." + , " controller getOwner this" + , " do" + , " splitImpl this splitAmount" + + , " choice Transfer : ContractId Token" + , " with" + , " newOwner : Party" + , " controller getOwner this, newOwner" + , " do" + , " transferImpl this newOwner" + + , " nonconsuming choice Noop : ()" + , " with" + , " nothing : ()" + , " controller getOwner this" + , " do" + , " noopImpl this nothing" + + , " choice GetRich : ContractId Token" + , " with" + , " byHowMuch : Int" + , " controller getOwner this" + , " do" + , " assert (byHowMuch > 0)" + , " create $ setAmount this (getAmount this + byHowMuch)" + + , "template Asset" + , " with" + , " issuer : Party" + , " owner : Party" + , " amount : Int" + , " where" + , " signatory issuer, owner" + , " implements Token where" + , " let getOwner = owner" + , " let getAmount = amount" + , " let setAmount = \\x -> toInterface @Token (this with amount = x)" + + , " let splitImpl = \\splitAmount -> do" + , " assert (splitAmount < amount)" + , " cid1 <- create this with amount = splitAmount" + , " cid2 <- create this with amount = amount - splitAmount" + , " pure (toInterfaceContractId @Token cid1, toInterfaceContractId @Token cid2)" + + , " let transferImpl = \\newOwner -> do" + , " cid <- create this with owner = newOwner" + , " pure (toInterfaceContractId @Token cid)" + + , " let noopImpl = \\nothing -> do" + , " [1] === [1] -- make sure `mkMethod` calls are properly erased in the presence of polymorphism." + , " pure ()" + ] + ] + [ + (,) "Main.daml" + [ "module Main where" + , "import Lib" + , "import DA.Assert" + + , "main = scenario do" + , " p <- getParty \"Alice\"" + , " p `submitMustFail` do" + , " create Asset with" + , " issuer = p" + , " owner = p" + , " amount = -1" + , " p `submit` do" + , " cidAsset1 <- create Asset with" + , " issuer = p" + , " owner = p" + , " amount = 15" + , " let cidToken1 = toInterfaceContractId @Token cidAsset1" + , " _ <- exercise cidToken1 (Noop ())" + , " (cidToken2, cidToken3) <- exercise cidToken1 (Split 10)" + , " token2 <- fetch cidToken2" + , " -- Party is duplicated because p is both observer & issuer" + , " signatory token2 === [p, p]" + , " getAmount token2 === 10" + , " case fromInterface token2 of" + , " None -> abort \"expected Asset\"" + , " Some Asset {amount} ->" + , " amount === 10" + , " token3 <- fetch cidToken3" + , " getAmount token3 === 5" + , " case fromInterface token3 of" + , " None -> abort \"expected Asset\"" + , " Some Asset {amount} ->" + , " amount === 5" + + , " cidToken4 <- exercise cidToken3 (GetRich 20)" + , " token4 <- fetch cidToken4" + , " getAmount token4 === 25" + , " case fromInterface token4 of" + , " None -> abort \"expected Asset\"" + , " Some Asset {amount} ->" + , " amount === 25" + + , " pure ()" + ] + ] + , testCaseSteps "User-defined exceptions" $ \step -> withTempDir $ \tmpDir -> do step "building project to be imported via data-dependencies" createDirectoryIfMissing True (tmpDir "lib") @@ -1583,13 +1824,17 @@ tests tools@Tools{damlc,validate,oldProjDar} = testGroup "Data Dependencies" $ dataDependenciesTest title [("Lib.daml", lib)] [("Main.daml", main)] dataDependenciesTest :: String -> [(FilePath, [String])] -> [(FilePath, [String])] -> TestTree - dataDependenciesTest title libModules mainModules = + dataDependenciesTest title = dataDependenciesTestOptions title [] + + dataDependenciesTestOptions :: String -> [String] -> [(FilePath, [String])] -> [(FilePath, [String])] -> TestTree + dataDependenciesTestOptions title buildOptions libModules mainModules = testCaseSteps title $ \step -> withTempDir $ \tmpDir -> do step "building project to be imported via data-dependencies" createDirectoryIfMissing True (tmpDir "lib") writeFileUTF8 (tmpDir "lib" "daml.yaml") $ unlines [ "sdk-version: " <> sdkVersion , "name: lib" + , "build-options: [" <> intercalate ", " buildOptions <> "]" , "source: ." , "version: 0.1.0" , "dependencies: [daml-prim, daml-stdlib]" @@ -1607,6 +1852,7 @@ tests tools@Tools{damlc,validate,oldProjDar} = testGroup "Data Dependencies" $ writeFileUTF8 (tmpDir "main" "daml.yaml") $ unlines [ "sdk-version: " <> sdkVersion , "name: main" + , "build-options: [" <> intercalate ", " buildOptions <> "]" , "source: ." , "version: 0.1.0" , "dependencies: [daml-prim, daml-stdlib]"