digital-asset/daml
1
1
Fork 0
mirror of https://github.com/digital-asset/daml.git synced 2024-09-19 08:48:21 +03:00
Code Issues Projects Releases Wiki Activity

Haskell SdkVersion inversion (#18066)

Browse Source 
* Remove //:sdk-version-hs-lib

* Add //sdk-version/hs:sdk-version-{class-,}lib

* Use //sdk-version/hs:sdk-version-{class-,}lib instead of //:sdk-version-hs-lib

* Fix //daml-assistant/daml-helper:test-deployment

* Fix da-hs-base.cabal

* Fix daml-project-config.cabal

* Move DA.Service.Logger.Impl.GCP out of da-hs-base

This means that da-hs-base no longer depends on sdk-version-class-lib, so users of the cabal file don't need to make any changes

* Move version data types out of daml-project-config

* Now //sdk-version/hs:sdk-version-class-lib depends on //libs-haskell/da-version-types

* back to the past (fmt.sh)

* yarn.lock changes to appease fmt.sh
This commit is contained in:
Moisés Ackerman 2024-01-09 10:24:31 +01:00 committed by GitHub
parent a483cabf16
commit 89cdb8d8a0
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
75 changed files with 774 additions and 546 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.hlint.yaml
View File

@ -143,7 +143,7 @@
- {name: unsafeInterleaveIO, within: []}
- {name: unsafeDupablePerformIO, within: []}
- {name: setCurrentDirectory, within: [DA.Daml.Assistant.Tests, Main]}
- {name: unsafeCoerce, within: []}
- {name: unsafeCoerce, within: [SdkVersion.Class]}
# Add custom hints for this project
#

42
BUILD
View File

@ -98,48 +98,6 @@ genrule(
cmd = "echo -n {mvn} > $@".format(mvn = mvn_version),
)
genrule(
name = "sdk-version-hs",
srcs = [],
outs = ["SdkVersion.hs"],
cmd = """
cat > $@ <<EOF
module SdkVersion where
import Module (stringToUnitId, UnitId)
sdkVersion :: String
sdkVersion = "{sdk}"
mvnVersion :: String
mvnVersion = "{mvn}"
-- | SDK version with non numeric subversions removed. Used for daml-script and daml-triggers versions
sdkPackageVersion :: String
sdkPackageVersion = "{ghc}"
damlStdlib :: UnitId
damlStdlib = stringToUnitId ("daml-stdlib-" ++ "{ghc}")
EOF
""".format(
ghc = ghc_version,
mvn = mvn_version,
sdk = sdk_version,
),
)
da_haskell_library(
name = "sdk-version-hs-lib",
srcs = [":sdk-version-hs"],
hackage_deps = [
"base",
"extra",
"ghc-lib-parser",
"split",
],
visibility = ["//visibility:public"],
)
genrule(
name = "sdk-version-scala",
srcs = [],

4
compiler/damlc/BUILD.bazel
View File

@ -106,6 +106,7 @@ da_haskell_binary(
visibility = ["//visibility:public"],
deps = [
":damlc-lib",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -225,7 +226,6 @@ da_haskell_library(
src_strip_prefix = "lib",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-dar-reader",
"//compiler/daml-lf-ast",
"//compiler/daml-lf-proto",
@ -250,7 +250,9 @@ da_haskell_library(
"//daml-assistant/daml-helper:daml-helper-lib",
"//daml-lf/archive:daml_lf_dev_archive_haskell_proto",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-gcp-logger",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-class-lib",
],
)

2
compiler/damlc/daml-compiler/BUILD.bazel
View File

@ -47,7 +47,6 @@ da_haskell_library(
src_strip_prefix = "src",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-dar-reader",
"//compiler/daml-lf-ast",
"//compiler/daml-lf-proto",
@ -69,5 +68,6 @@ da_haskell_library(
"//daml-assistant:daml-project-config",
"//language-support/hs/bindings:hs-ledger",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-class-lib",
],
)

5
compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Dar.hs
View File

@ -71,6 +71,8 @@ import DA.Daml.Project.Types (UnresolvedReleaseVersion(..))
import qualified "zip-archive" Codec.Archive.Zip as ZipArchive
import SdkVersion.Class (SdkVersioned)
-- | Create a DAR file by running a ZipArchive action.
createDarFile :: Logger.Handle IO -> FilePath -> Zip.ZipArchive () -> IO ()
createDarFile loggerH fp dar = do
@ -109,7 +111,8 @@ newtype FromDalf = FromDalf
}
buildDar ::
IdeState
SdkVersioned
=> IdeState
-> PackageConfigFields
-> NormalizedFilePath
-> FromDalf

21
compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DataDependencies.hs
View File

@ -61,7 +61,7 @@ import DA.Daml.Options
import DA.Daml.StablePackages (stablePackageByModuleName)
import DA.Daml.UtilGHC (fsFromText)
import SdkVersion
import SdkVersion.Class (SdkVersioned, damlStdlib)
panicOnError :: HasCallStack => Either LF.Error a -> a
panicOnError (Left e) =
@ -288,7 +288,8 @@ freshTypeName env = mkRdrName . (prefix <>) . T.pack . show <$> freshInt
-- | Extract all data definitions from a daml-lf module and generate
-- a haskell source file from it.
generateSrcFromLf ::
Env
SdkVersioned
=> Env
-> ParsedSource
generateSrcFromLf env = noLoc mod
where
@ -890,7 +891,7 @@ mkErrorCall env msg = do
let errorMsg = noLoc $ HsLit noExt (HsString (SourceText $ show msg) $ mkFastString msg) :: LHsExpr GhcPs
pure $ noLoc $ HsPar noExt $ noLoc $ HsApp noExt errorFun (noLoc $ HsPar noExt $ noLoc $ HsApp noExt fromStringFun errorMsg)
mkConDeclField :: Env -> LF.FieldName -> LF.Type -> Gen (LConDeclField GhcPs)
mkConDeclField :: SdkVersioned => Env -> LF.FieldName -> LF.Type -> Gen (LConDeclField GhcPs)
mkConDeclField env fieldName fieldTy = do
fieldTy' <- convType env MS.empty fieldTy
pure . noLoc $ ConDeclField
@ -957,7 +958,7 @@ rewriteClassReexport env reexported syn@LF.Qualified{..}
| otherwise = syn
convType :: Env -> MS.Map LF.TypeSynName LF.PackageId -> LF.Type -> Gen (HsType GhcPs)
convType :: SdkVersioned => Env -> MS.Map LF.TypeSynName LF.PackageId -> LF.Type -> Gen (HsType GhcPs)
convType env reexported =
\case
LF.TVar tyVarName -> pure $
@ -1029,7 +1030,7 @@ convType env reexported =
-- otherwise GHC will expand them out as regular constraints.
-- See issues https://github.com/digital-asset/daml/issues/9663,
-- https://github.com/digital-asset/daml/issues/11455
convTypeLiftingConstraintTuples :: Env -> MS.Map LF.TypeSynName LF.PackageId -> LF.Type -> Gen (HsType GhcPs)
convTypeLiftingConstraintTuples :: SdkVersioned => Env -> MS.Map LF.TypeSynName LF.PackageId -> LF.Type -> Gen (HsType GhcPs)
convTypeLiftingConstraintTuples env reexported = go where
go = \case
ty@(LF.TStruct fls) | isConstraint ty -> do
@ -1055,7 +1056,7 @@ convTypeLiftingConstraintTuples env reexported = go where
ty ->
convType env reexported ty
convBuiltInTy :: Env -> LF.BuiltinType -> Gen (HsType GhcPs)
convBuiltInTy :: SdkVersioned => Env -> LF.BuiltinType -> Gen (HsType GhcPs)
convBuiltInTy env =
\case
LF.BTInt64 -> mkGhcType env "Int"
@ -1134,7 +1135,7 @@ mkGhcType :: Env -> String -> Gen (HsType GhcPs)
mkGhcType env = mkStableType env primUnitId $
LF.ModuleName ["GHC", "Types"]
mkLfInternalType :: Env -> String -> Gen (HsType GhcPs)
mkLfInternalType :: SdkVersioned => Env -> String -> Gen (HsType GhcPs)
mkLfInternalType env = mkStableType env damlStdlib $
LF.ModuleName ["DA", "Internal", "LF"]
@ -1142,7 +1143,7 @@ mkDesugarType :: Env -> String -> Gen (HsType GhcPs)
mkDesugarType env = mkStableType env primUnitId $
LF.ModuleName ["DA", "Internal", "Desugar"]
mkLfInternalPrelude :: Env -> String -> Gen (HsType GhcPs)
mkLfInternalPrelude :: SdkVersioned => Env -> String -> Gen (HsType GhcPs)
mkLfInternalPrelude env = mkStableType env damlStdlib $
LF.ModuleName ["DA", "Internal", "Prelude"]
@ -1151,7 +1152,7 @@ mkTyConTypeUnqual tyCon = HsTyVar noExt NotPromoted . noLoc $ mkRdrUnqual (occNa
where name = getName tyCon
-- | Generate the full source for a daml-lf package.
generateSrcPkgFromLf :: Config -> LF.Package -> [(NormalizedFilePath, String)]
generateSrcPkgFromLf :: SdkVersioned => Config -> LF.Package -> [(NormalizedFilePath, String)]
generateSrcPkgFromLf envConfig pkg = do
mod <- NM.toList $ LF.packageModules pkg
let fp =
@ -1490,7 +1491,7 @@ isDFunName :: LF.ExprValName -> Bool
isDFunName (LF.ExprValName t) = any (`T.isPrefixOf` t) ["$f", "$d"]
-- | Convert dictionary function signature into a Daml type.
convDFunSig :: Env -> MS.Map LF.TypeSynName LF.PackageId -> DFunSig -> Gen (HsType GhcPs)
convDFunSig :: SdkVersioned => Env -> MS.Map LF.TypeSynName LF.PackageId -> DFunSig -> Gen (HsType GhcPs)
convDFunSig env reexported DFunSig{..} = do
binders <- mapM (convTyVarBinder env) dfsBinders
context <- mapM (convTypeLiftingConstraintTuples env reexported) dfsContext

7
compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Repl.hs
View File

@ -80,6 +80,8 @@ import System.IO.Extra
import TcEvidence (idHsWrapper)
import Type (splitTyConApp)
import SdkVersion.Class (SdkVersioned)
data Error
= ParseError MsgDoc
| UnsupportedStatement String -- ^ E.g., pattern on the LHS
@ -364,8 +366,9 @@ newReplLogger = do
(const f)
pure ReplLogger{replEventLogger = NotificationHandler replEventLogger,..}
runRepl
:: [(LF.PackageName, Maybe LF.PackageVersion)]
runRepl ::
SdkVersioned
=> [(LF.PackageName, Maybe LF.PackageVersion)]
-> Options
-> ReplClient.Handle
-> ReplLogger

2
compiler/damlc/daml-desugar/BUILD.bazel
View File

@ -20,6 +20,7 @@ da_haskell_library(
"//compiler/damlc/daml-compiler",
"//compiler/damlc/daml-ide-core",
"//compiler/damlc/daml-opts:daml-opts-types",
"//sdk-version/hs:sdk-version-class-lib",
],
)
@ -49,5 +50,6 @@ da_haskell_library(
"//compiler/damlc/daml-opts:daml-opts-types",
"//libs-haskell/da-hs-base",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-class-lib",
],
)

4
compiler/damlc/daml-desugar/src/DA/Daml/Desugar.hs
View File

@ -22,7 +22,9 @@ import "ghc-lib-parser" HscTypes (hsc_dflags)
import qualified "ghc-lib-parser" Outputable as GHC
desugar :: Options -> FilePath -> IO Text
import SdkVersion.Class (SdkVersioned)
desugar :: SdkVersioned => Options -> FilePath -> IO Text
desugar opts inputFile = do
loggerH <- getLogger opts "daml-desugar"
inputFile <- pure $ toNormalizedFilePath' inputFile

8
compiler/damlc/daml-desugar/test/DA/Daml/Desugar/Tests.hs
View File

@ -19,7 +19,9 @@ import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text.Encoding as TE
import qualified Test.Tasty.Extended as Tasty
mkTestTree :: FilePath -> IO Tasty.TestTree
import SdkVersion.Class (SdkVersioned)
mkTestTree :: SdkVersioned => FilePath -> IO Tasty.TestTree
mkTestTree testDir = do
let isExpectationFile filePath =
".EXPECTED" == takeExtensions (dropExtension filePath)
@ -30,7 +32,7 @@ mkTestTree testDir = do
pure $ Tasty.testGroup "DA.Daml.Desugar" $ concat goldenTests
runDamlDesugar :: FilePath -> IO Text
runDamlDesugar :: SdkVersioned => FilePath -> IO Text
runDamlDesugar input = desugar opts input
where
opts = (defaultOptions Nothing)
@ -41,7 +43,7 @@ runDamlDesugar input = desugar opts input
-- | For the given file <name>.daml (assumed), this test checks if
-- <name>.EXPECTED.desugared-daml exists, and produces output accordingly.
fileTest :: FilePath -> IO [Tasty.TestTree]
fileTest :: SdkVersioned => FilePath -> IO [Tasty.TestTree]
fileTest damlFile = do
damlFileAbs <- makeAbsolute damlFile

3
compiler/damlc/daml-doc/BUILD.bazel
View File

@ -48,6 +48,7 @@ da_haskell_library(
"//compiler/damlc/daml-rule-types",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-class-lib",
],
)
@ -79,7 +80,6 @@ da_haskell_library(
],
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-lf-ast",
"//compiler/damlc/daml-compiler",
"//compiler/damlc/daml-doc",
@ -89,6 +89,7 @@ da_haskell_library(
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-class-lib",
],
)

6
compiler/damlc/daml-doc/src/DA/Daml/Doc/Driver.hs
View File

@ -43,6 +43,8 @@ import qualified Data.HashMap.Strict as HMS
import qualified Data.Text.Encoding as T
import qualified Data.Text.Extended as T
import SdkVersion.Class (SdkVersioned)
data DamldocOptions = DamldocOptions
{ do_inputFormat :: InputFormat
, do_compileOptions :: Options
@ -81,13 +83,13 @@ data ExternalAnchorPath
deriving (Eq, Show, Read)
-- | Run damldocs!
runDamlDoc :: DamldocOptions -> IO ()
runDamlDoc :: SdkVersioned => DamldocOptions -> IO ()
runDamlDoc options@DamldocOptions{..} = do
docData <- inputDocData options
renderDocData options (applyTransform do_transformOptions docData)
-- | Load doc data, either via the Daml typechecker or via JSON files.
inputDocData :: DamldocOptions -> IO [ModuleDoc]
inputDocData :: SdkVersioned => DamldocOptions -> IO [ModuleDoc]
inputDocData DamldocOptions{..} = do
let printAndExit errMsg = do

8
compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract.hs
View File

@ -55,9 +55,12 @@ import qualified Data.Map.Strict as MS
import qualified Data.Set as Set
import qualified Data.Text as T
import SdkVersion.Class (SdkVersioned)
-- | Extract documentation in a dependency graph of modules.
extractDocs ::
ExtractOptions
SdkVersioned
=> ExtractOptions
-> Service.NotificationHandler
-> Options
-> [NormalizedFilePath]
@ -176,7 +179,8 @@ buildDocCtx dc_extractOptions tcmod =
--
-- Not using the cached file store, as it is expected to run stand-alone
-- invoked by a CLI tool.
haddockParse :: Service.NotificationHandler ->
haddockParse :: SdkVersioned =>
Service.NotificationHandler ->
Options ->
[NormalizedFilePath] ->
MaybeT IO [Service.TcModuleResult]

20
compiler/damlc/daml-doc/test/DA/Daml/Doc/Tests.hs
View File

@ -39,9 +39,10 @@ import qualified Test.Tasty.Extended as Tasty
import Test.Tasty.Golden
import Test.Tasty.HUnit
import Data.Maybe
import SdkVersion (sdkPackageVersion)
mkTestTree :: AnchorMap -> ScriptPackageData -> IO Tasty.TestTree
import SdkVersion.Class (SdkVersioned, sdkPackageVersion)
mkTestTree :: SdkVersioned => AnchorMap -> ScriptPackageData -> IO Tasty.TestTree
mkTestTree externalAnchors scriptPackageData = do
testDir <- locateRunfiles $ mainWorkspace </> "compiler/damlc/tests/daml-test-files"
@ -55,7 +56,7 @@ mkTestTree externalAnchors scriptPackageData = do
pure $ Tasty.testGroup "DA.Daml.Doc" $ unitTests <> concat goldenTests
unitTests :: [Tasty.TestTree]
unitTests :: SdkVersioned => [Tasty.TestTree]
unitTests =
[ damldocExpect
Nothing
@ -387,7 +388,7 @@ emptyDocs name =
-- | Compiles the given input string (in a tmp file) and checks generated doc.s
-- using the predicate provided.
damldocExpect :: Maybe FilePath -> String -> [T.Text] -> (ModuleDoc -> Assertion) -> Tasty.TestTree
damldocExpect :: SdkVersioned => Maybe FilePath -> String -> [T.Text] -> (ModuleDoc -> Assertion) -> Tasty.TestTree
damldocExpect importPathM testname input check =
testCase testname $
withTempDir $ \dir -> do
@ -399,7 +400,8 @@ damldocExpect importPathM testname input check =
check doc
damldocExpectMany ::
Maybe FilePath
SdkVersioned
=> Maybe FilePath
-> String
-> [(String, [T.Text])]
-> (Map Modulename ModuleDoc -> Assertion)
@ -415,21 +417,21 @@ damldocExpectMany importPathM testname input check =
check docs
-- | Generate the docs for a given input file and optional import directory.
runDamldoc :: FilePath -> Maybe FilePath -> Maybe ScriptPackageData -> IO ModuleDoc
runDamldoc :: SdkVersioned => FilePath -> Maybe FilePath -> Maybe ScriptPackageData -> IO ModuleDoc
runDamldoc testfile importPathM mScriptPackageData = do
-- The first module is the one we're testing
(\(names, modMap) -> modMap Map.! head names)
<$> runDamldocMany' [testfile] importPathM mScriptPackageData
-- | Generate the docs for a given list of input files and optional import directory.
runDamldocMany :: [FilePath] -> Maybe FilePath -> Maybe ScriptPackageData -> IO (Map Modulename ModuleDoc)
runDamldocMany :: SdkVersioned => [FilePath] -> Maybe FilePath -> Maybe ScriptPackageData -> IO (Map Modulename ModuleDoc)
runDamldocMany testfiles importPathM mScriptPackageData =
snd <$> runDamldocMany' testfiles importPathM mScriptPackageData
-- | Generate the docs for a given list of input files and optional import directory.
-- The fst of the result has the names of Modulenames for each file path in the input.
-- The snd has a map from all the modules (including imported ones) to their docs.
runDamldocMany' :: [FilePath] -> Maybe FilePath -> Maybe ScriptPackageData -> IO ([Modulename], Map Modulename ModuleDoc)
runDamldocMany' :: SdkVersioned => [FilePath] -> Maybe FilePath -> Maybe ScriptPackageData -> IO ([Modulename], Map Modulename ModuleDoc)
runDamldocMany' testfiles importPathM mScriptPackageData = do
let opts = (defaultOptions Nothing)
{ optHaddock = Haddock True
@ -465,7 +467,7 @@ runDamldocMany' testfiles importPathM mScriptPackageData = do
-- | For the given file <name>.daml (assumed), this test checks if any
-- <name>.EXPECTED.<suffix> exists, and produces output according to <suffix>
-- for all files found.
fileTest :: AnchorMap -> ScriptPackageData -> FilePath -> IO [Tasty.TestTree]
fileTest :: SdkVersioned => AnchorMap -> ScriptPackageData -> FilePath -> IO [Tasty.TestTree]
fileTest externalAnchors scriptPackageData damlFile = do
damlFileAbs <- makeAbsolute damlFile

3
compiler/damlc/daml-ide-core/BUILD.bazel
View File

@ -51,7 +51,6 @@ da_haskell_library(
src_strip_prefix = "src",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-lf-ast",
"//compiler/daml-lf-proto",
"//compiler/daml-lf-proto-decode",
@ -67,6 +66,7 @@ da_haskell_library(
"//compiler/scenario-service/client",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-class-lib",
],
)
@ -108,5 +108,6 @@ da_haskell_library(
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-class-lib",
],
)

11
compiler/damlc/daml-ide-core/src/Development/IDE/Core/IdeState/Daml.hs
View File

@ -22,9 +22,11 @@ import Development.IDE.Plugin.Completions as Completions
import Development.IDE.Plugin.CodeAction as CodeAction
import qualified Development.IDE.Types.Logger as IdeLogger
import qualified Language.LSP.Types as LSP
import SdkVersion.Class (SdkVersioned)
getDamlIdeState
:: Options
getDamlIdeState ::
SdkVersioned
=> Options
-> StudioAutorunAllScenarios
-> Maybe Scenario.Handle
-> Logger.Handle IO
@ -44,8 +46,9 @@ enabledPlugins = Completions.plugin <> CodeAction.plugin
-- will be started automatically (if enabled)
-- and we use the builtin VFSHandle. We always disable
-- the debouncer here since this is not used in the IDE.
withDamlIdeState
:: Options
withDamlIdeState ::
SdkVersioned
=> Options
-> Logger.Handle IO
-> NotificationHandler
-> (IdeState -> IO a)

18
compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs
View File

@ -104,7 +104,7 @@ import qualified DA.Daml.LF.TypeChecker as LF
import DA.Daml.UtilLF
import qualified DA.Pretty as Pretty
import DA.Pretty (PrettyLevel)
import SdkVersion (damlStdlib)
import SdkVersion.Class (SdkVersioned, damlStdlib)
import Language.Haskell.HLint4
@ -222,7 +222,7 @@ getUnstableDalfDependencies files = do
pkgMap <- Map.unions . map getPackageMap <$> usesE' GeneratePackageMap files
pure $ Map.restrictKeys pkgMap (Set.fromList $ map (DefiniteUnitId . DefUnitId) unitIds)
getDalfDependencies :: [NormalizedFilePath] -> MaybeT Action (Map.Map UnitId LF.DalfPackage)
getDalfDependencies :: SdkVersioned => [NormalizedFilePath] -> MaybeT Action (Map.Map UnitId LF.DalfPackage)
getDalfDependencies files = do
actualDeps <- getUnstableDalfDependencies files
-- For now, we unconditionally include all stable packages.
@ -254,7 +254,7 @@ priorityGenerateDalf = priorityGenerateCore
-- Generates the DALF for a module without adding serializability information
-- or type checking it.
generateRawDalfRule :: Rules ()
generateRawDalfRule :: SdkVersioned => Rules ()
generateRawDalfRule =
define $ \GenerateRawDalf file -> do
lfVersion <- getDamlLfVersion
@ -388,7 +388,7 @@ packageMetadataFromOptions options = LF.PackageMetadata
-- We use the ABI hash of the .hi files to detect if we need to recompile dependent files. Note that this is more aggressive
-- than just looking at the file hash. E.g., consider module A depending on module B. If B changes but its ABI hash stays the same
-- we do not need to recompile A.
generateSerializedDalfRule :: Options -> Rules ()
generateSerializedDalfRule :: SdkVersioned => Options -> Rules ()
generateSerializedDalfRule options =
defineOnDisk $ \GenerateSerializedDalf file ->
OnDiskRule
@ -561,7 +561,7 @@ generatePackageMapRule opts = do
let hash = BS.concat $ map (T.encodeUtf8 . LF.unPackageId . LF.dalfPackageId) $ Map.elems res
return (Just hash, ([], Just (PackageMap res)))
damlGhcSessionRule :: Options -> Rules ()
damlGhcSessionRule :: SdkVersioned => Options -> Rules ()
damlGhcSessionRule opts@Options{..} = do
-- The file path here is optional so we go for defineNoFile
-- (or the equivalent thereof for rules with cut off).
@ -593,7 +593,7 @@ damlGhcSessionRule opts@Options{..} = do
-- incremental builds we need an early cutoff.
pure (Just "", ([], Just hscEnv))
generateStablePackages :: LF.Version -> FilePath -> IO ([FileDiagnostic], Map.Map (UnitId, LF.ModuleName) LF.DalfPackage)
generateStablePackages :: SdkVersioned => LF.Version -> FilePath -> IO ([FileDiagnostic], Map.Map (UnitId, LF.ModuleName) LF.DalfPackage)
generateStablePackages lfVersion fp = do
(diags, pkgs) <- fmap partitionEithers $ do
let prefix = fp </> ("lf-v" <> renderMajorVersion (versionMajor lfVersion))
@ -665,7 +665,7 @@ locateStablePackages = locateResource Resource
, runfilesPathPrefix = mainWorkspace </> "compiler" </> "damlc"
}
generateStablePackagesRule :: Options -> Rules ()
generateStablePackagesRule :: SdkVersioned => Options -> Rules ()
generateStablePackagesRule opts =
defineEarlyCutoff $ \GenerateStablePackages _file -> assert (null $ fromNormalizedFilePath _file) $ do
lfVersion <- getDamlLfVersion
@ -1518,7 +1518,7 @@ internalModules = map FPP.normalise
]
damlRule :: Options -> Rules ()
damlRule :: SdkVersioned => Options -> Rules ()
damlRule opts = do
generateRawDalfRule
generateDalfRule
@ -1547,7 +1547,7 @@ damlRule opts = do
damlGhcSessionRule opts
when (optEnableOfInterestRule opts) ofInterestRule
mainRule :: Options -> Rules ()
mainRule :: SdkVersioned => Options -> Rules ()
mainRule options = do
IDE.mainRule
damlRule options

6
compiler/damlc/daml-ide-core/test/Development/IDE/Core/API/Testing.hs
View File

@ -88,6 +88,8 @@ import Data.List.Extra
import Text.Regex.TDFA
import Text.Regex.TDFA.Text ()
import SdkVersion.Class (SdkVersioned)
-- | Short-circuiting errors that may occur during a test.
data ShakeTestError
= ExpectedRelativePath FilePath
@ -137,11 +139,11 @@ pattern EventVirtualResourceNoteSet vr note <-
-- | Run shake test on freshly initialised shake service.
runShakeTest :: Maybe SS.Handle -> ShakeTest () -> IO (Either ShakeTestError ShakeTestResults)
runShakeTest :: SdkVersioned => Maybe SS.Handle -> ShakeTest () -> IO (Either ShakeTestError ShakeTestResults)
runShakeTest = runShakeTestOpts id
-- | Run shake test on freshly initialised shake service, with custom options.
runShakeTestOpts :: (Daml.Options -> Daml.Options) -> Maybe SS.Handle -> ShakeTest () -> IO (Either ShakeTestError ShakeTestResults)
runShakeTestOpts :: SdkVersioned => (Daml.Options -> Daml.Options) -> Maybe SS.Handle -> ShakeTest () -> IO (Either ShakeTestError ShakeTestResults)
runShakeTestOpts fOpts mbScenarioService (ShakeTest m) = do
let options = fOpts (defaultOptions Nothing)
{ optDlintUsage = DlintEnabled DlintOptions

2
compiler/damlc/daml-lf-conversion/BUILD.bazel
View File

@ -34,7 +34,6 @@ da_haskell_library(
src_strip_prefix = "src",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-lf-ast",
"//compiler/daml-lf-proto",
"//compiler/daml-lf-tools",
@ -43,6 +42,7 @@ da_haskell_library(
"//compiler/damlc/daml-opts:daml-opts-types",
"//compiler/damlc/daml-preprocessor",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-class-lib",
],
)

50
compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
View File

@ -128,7 +128,7 @@ import qualified "ghc-lib-parser" Name
import qualified "ghc-lib-parser" Avail as GHC
import qualified "ghc-lib-parser" BooleanFormula as BF
import Safe.Exact (zipExact, zipExactMay)
import SdkVersion
import SdkVersion.Class (SdkVersioned, damlStdlib)
---------------------------------------------------------------------
-- FUNCTIONS ON THE ENVIRONMENT
@ -659,13 +659,13 @@ convertInterfaceTyCon = convertDamlTyCon hasDamlInterfaceCtx "interface type"
convertTemplateTyCon :: Env -> (GHC.TyCon -> String) -> GHC.TyCon -> ConvertM (LF.Qualified LF.TypeConName)
convertTemplateTyCon = convertDamlTyCon hasDamlTemplateCtx "template type"
convertInterfaces :: Env -> ModuleContents -> ConvertM [Definition]
convertInterfaces :: SdkVersioned => Env -> ModuleContents -> ConvertM [Definition]
convertInterfaces env mc =
concatMapM
(\(name, binds) -> convertInterface env mc name binds)
(MS.toList (mcInterfaceBinds mc))
convertInterface :: Env -> ModuleContents -> LF.TypeConName -> InterfaceBinds -> ConvertM [Definition]
convertInterface :: SdkVersioned => Env -> ModuleContents -> LF.TypeConName -> InterfaceBinds -> ConvertM [Definition]
convertInterface env mc intName ib =
withRange intLocation do
unless (envLfVersion env `supports` featureSimpleInterfaces) do
@ -751,7 +751,8 @@ convertConsuming consumingTy = case consumingTy of
_ -> unhandled "choice consumption type" (show consumingTy)
convertModule
:: LF.Version
:: SdkVersioned
=> LF.Version
-> EnableScenarios
-> AllowLargeTuples
-> MS.Map UnitId DalfPackage
@ -771,7 +772,7 @@ convertModule lfVersion enableScenarios allowLargeTuples pkgMap stablePackages f
where
flags = LF.daml12FeatureFlags
convertModuleContents :: Env -> ModuleContents -> ConvertM [Definition]
convertModuleContents :: SdkVersioned => Env -> ModuleContents -> ConvertM [Definition]
convertModuleContents env mc = do
definitions <- convertBinds env mc
types <- convertTypeDefs env mc
@ -1083,13 +1084,13 @@ self = mkVar "self"
arg = mkVar "arg"
res = mkVar "res"
convertTemplateDefs :: Env -> ModuleContents -> ConvertM [Definition]
convertTemplateDefs :: SdkVersioned => Env -> ModuleContents -> ConvertM [Definition]
convertTemplateDefs env mc =
forM (MS.toList (mcTemplateBinds mc)) $ \(tname, tbinds) -> do
resetFreshVarCounters
DTemplate <$> convertTemplate env mc tname tbinds
convertTemplate :: Env -> ModuleContents -> LF.TypeConName -> TemplateBinds -> ConvertM Template
convertTemplate :: SdkVersioned => Env -> ModuleContents -> LF.TypeConName -> TemplateBinds -> ConvertM Template
convertTemplate env mc tplTypeCon tbinds@TemplateBinds{..}
| Just tplTyCon <- tbTyCon
, Just fSignatory <- tbSignatory
@ -1137,7 +1138,7 @@ convertTemplate env mc tplTypeCon tbinds@TemplateBinds{..}
= b
convertTemplateKey :: Env -> LF.TypeConName -> TemplateBinds -> ConvertM (Maybe TemplateKey)
convertTemplateKey :: SdkVersioned => Env -> LF.TypeConName -> TemplateBinds -> ConvertM (Maybe TemplateKey)
convertTemplateKey env tname TemplateBinds{..}
| Just keyTy <- tbKeyType
, Just fKey <- tbKey
@ -1153,13 +1154,13 @@ convertTemplateKey env tname TemplateBinds{..}
| otherwise
= pure Nothing
convertExceptionDefs :: Env -> ModuleContents -> ConvertM [Definition]
convertExceptionDefs :: SdkVersioned => Env -> ModuleContents -> ConvertM [Definition]
convertExceptionDefs env mc =
forM (MS.toList (mcExceptionBinds mc)) $ \(ename, ebinds) -> do
resetFreshVarCounters
DException <$> convertDefException env ename ebinds
convertDefException :: Env -> LF.TypeConName -> ExceptionBinds -> ConvertM DefException
convertDefException :: SdkVersioned => Env -> LF.TypeConName -> ExceptionBinds -> ConvertM DefException
convertDefException env exnName ExceptionBinds{..} = do
let exnLocation = convNameLoc (GHC.tyConName ebTyCon)
withRange exnLocation $ do
@ -1169,14 +1170,14 @@ convertDefException env exnName ExceptionBinds{..} = do
-- | Convert the method from a single method type class dictionary
-- (such as those used in template desugaring), and then fmap over it
-- (usually to apply some arguments).
useSingleMethodDict :: Env -> GHC.Expr Var -> (LF.Expr -> t) -> ConvertM t
useSingleMethodDict :: SdkVersioned => Env -> GHC.Expr Var -> (LF.Expr -> t) -> ConvertM t
useSingleMethodDict env (Cast ghcExpr _) f = do
lfExpr <- convertExpr env ghcExpr
pure (f lfExpr)
useSingleMethodDict env x _ =
unhandled "useSingleMethodDict: not a single method type class dictionary" x
convertImplements :: Env -> ModuleContents -> LF.TypeConName -> ConvertM (NM.NameMap TemplateImplements)
convertImplements :: SdkVersioned => Env -> ModuleContents -> LF.TypeConName -> ConvertM (NM.NameMap TemplateImplements)
convertImplements env mc tpl = NM.fromList <$>
mapM convertImplements1
(maybe [] interfaceInstanceGroupBinds (MS.lookup tpl (mcInterfaceInstanceBinds mc)))
@ -1189,7 +1190,8 @@ convertImplements env mc tpl = NM.fromList <$>
env
convertInterfaceInstance ::
TemplateOrInterface' TypeConName
SdkVersioned
=> TemplateOrInterface' TypeConName
-> (Qualified TypeConName -> Qualified TypeConName -> InterfaceInstanceBody -> Maybe SourceLoc -> r)
-> Env
-> InterfaceInstanceBinds
@ -1253,12 +1255,12 @@ convertInterfaceInstance parent mkR env iib = withRange (iibLoc iib) do
, s
]
convertChoices :: Env -> ModuleContents -> LF.TypeConName -> TemplateBinds -> ConvertM (NM.NameMap TemplateChoice)
convertChoices :: SdkVersioned => Env -> ModuleContents -> LF.TypeConName -> TemplateBinds -> ConvertM (NM.NameMap TemplateChoice)
convertChoices env mc tplTypeCon tbinds =
NM.fromList <$> traverse (convertChoice env tbinds)
(MS.findWithDefault [] tplTypeCon (mcChoiceData mc))
convertChoice :: Env -> TemplateBinds -> ChoiceData -> ConvertM TemplateChoice
convertChoice :: SdkVersioned => Env -> TemplateBinds -> ChoiceData -> ConvertM TemplateChoice
convertChoice env tbinds (ChoiceData ty expr) = do
-- The desuaged representation of a Daml Choice is a five tuple.
-- Constructed by mkChoiceDecls in RdrHsSyn.hs in the ghc repo.
@ -1326,11 +1328,11 @@ convertChoice env tbinds (ChoiceData ty expr) = do
where
applyThisAndArg func = func `ETmApp` EVar this `ETmApp` EVar arg
convertBinds :: Env -> ModuleContents -> ConvertM [Definition]
convertBinds :: SdkVersioned => Env -> ModuleContents -> ConvertM [Definition]
convertBinds env mc =
concatMapM (\bind -> resetFreshVarCounters >> topLevelWarnings bind >> convertBind env mc bind) (mcBinds mc)
convertBind :: Env -> ModuleContents -> (Var, GHC.Expr Var) -> ConvertM [Definition]
convertBind :: SdkVersioned => Env -> ModuleContents -> (Var, GHC.Expr Var) -> ConvertM [Definition]
convertBind env mc (name, x)
-- This is inlined in the choice in the template so we can just drop this.
| "_choice$_" `T.isPrefixOf` getOccText name
@ -1568,7 +1570,7 @@ internalFunctions = listToUFM $ map (bimap mkModuleNameFS mkUniqSet)
])
]
convertExpr :: Env -> GHC.Expr Var -> ConvertM LF.Expr
convertExpr :: SdkVersioned => Env -> GHC.Expr Var -> ConvertM LF.Expr
convertExpr env0 e = do
(e, args) <- go env0 e []
let appArg e (mbSrcSpan, arg) =
@ -2110,7 +2112,7 @@ splitConArgs_maybe con args = do
-- NOTE(MH): Handle data constructors. Fully applied record
-- constructors are inlined. This is required for contract keys to
-- work. Constructor workers are not handled (yet).
convertDataCon :: Env -> GHC.Module -> DataCon -> [LArg Var] -> ConvertM (LF.Expr, [LArg Var])
convertDataCon :: SdkVersioned => Env -> GHC.Module -> DataCon -> [LArg Var] -> ConvertM (LF.Expr, [LArg Var])
convertDataCon env m con args
| AllowLargeTuples False <- envAllowLargeTuples env
, envUserWrittenTuple env
@ -2180,7 +2182,7 @@ convertDataCon env m con args
, T.dropWhile (== ',') xs == ")" = qDA_Types env $ f $ "Tuple" <> T.pack (show $ T.length xs + 1)
| IgnoreWorkerPrefix t' <- t = qualify env m $ f t'
convertArg :: Env -> GHC.Arg Var -> ConvertM LF.Arg
convertArg :: SdkVersioned => Env -> GHC.Arg Var -> ConvertM LF.Arg
convertArg env = \case
Type t -> TyArg <$> convertType env t
e -> TmArg <$> convertExpr env e
@ -2203,7 +2205,7 @@ withTyArg env k args cont = do
(x, args) <- cont env' (TVar v) args
pure (ETyLam (v, k) x, args)
withTmArg :: Env -> LF.Type -> [LArg Var] -> (LF.Expr-> [LArg Var] -> ConvertM (LF.Expr, [LArg Var])) -> ConvertM (LF.Expr, [LArg Var])
withTmArg :: SdkVersioned => Env -> LF.Type -> [LArg Var] -> (LF.Expr-> [LArg Var] -> ConvertM (LF.Expr, [LArg Var])) -> ConvertM (LF.Expr, [LArg Var])
withTmArg env _ (LExpr x:args) cont = do
x <- convertExpr env x
cont x args
@ -2212,7 +2214,7 @@ withTmArg env t args cont = do
(x, args) <- cont (EVar v) args
pure (ETmLam (v, t) x, args)
convertLet :: Env -> Var -> GHC.Expr Var -> (Env -> ConvertM LF.Expr) -> ConvertM LF.Expr
convertLet :: SdkVersioned => Env -> Var -> GHC.Expr Var -> (Env -> ConvertM LF.Expr) -> ConvertM LF.Expr
convertLet env binder bound mkBody = do
bound <- convertExpr env bound
case bound of
@ -2231,7 +2233,7 @@ convertUnitId _thisUnitId pkgMap unitId = case unitId of
Just DalfPackage{..} -> pure $ LF.PRImport dalfPackageId
Nothing -> unknown unitId pkgMap
convertAlt :: Env -> LF.Type -> Alt Var -> ConvertM GeneralisedCaseAlternative
convertAlt :: SdkVersioned => Env -> LF.Type -> Alt Var -> ConvertM GeneralisedCaseAlternative
convertAlt env ty (DEFAULT, [], x) = GCA (GCPNormal CPDefault) <$> convertExpr env x
convertAlt env ty (DataAlt con, [], x)
| NameIn GHC_Types "True" <- con = GCA (GCPNormal (CPBool True)) <$> convertExpr env x
@ -2731,7 +2733,7 @@ convVal = mkVal . varPrettyPrint
convValWithType :: Env -> Var -> ConvertM (ExprValName, LF.Type)
convValWithType env v = (convVal v,) <$> convertType env (varType v)
mkPure :: Env -> GHC.Type -> GHC.Expr Var -> LF.Type -> LF.Expr -> ConvertM LF.Expr
mkPure :: SdkVersioned => Env -> GHC.Type -> GHC.Expr Var -> LF.Type -> LF.Expr -> ConvertM LF.Expr
mkPure env monad dict t x = do
monad' <- convertType env monad
case monad' of

2
compiler/damlc/daml-opts/BUILD.bazel
View File

@ -59,7 +59,6 @@ da_haskell_library(
visibility = ["//visibility:public"],
deps = [
":daml-opts-types",
"//:sdk-version-hs-lib",
"//compiler/daml-lf-ast",
"//compiler/daml-lf-proto",
"//compiler/daml-lf-reader",
@ -68,5 +67,6 @@ da_haskell_library(
"//daml-assistant:daml-project-config",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-class-lib",
],
)

4
compiler/damlc/daml-opts/daml-opts/DA/Daml/Options.hs
View File

@ -61,7 +61,7 @@ import DA.Daml.Preprocessor
import Development.IDE.GHC.Util
import qualified DA.Service.Logger as Logger
import qualified Development.IDE.Types.Options as Ghcide
import SdkVersion (damlStdlib)
import SdkVersion.Class (SdkVersioned, damlStdlib)
-- | Convert to ghcide’s IdeOptions type.
toCompileOpts :: Options -> Ghcide.IdeOptions
@ -582,7 +582,7 @@ expandSdkPackages logger lfVersion dars = do
mkPackageFlag :: UnitId -> PackageFlag
mkPackageFlag unitId = ExposePackage ("--package " <> unitIdString unitId) (UnitIdArg unitId) (ModRenaming True [])
mkBaseUnits :: Maybe UnitId -> [UnitId]
mkBaseUnits :: SdkVersioned => Maybe UnitId -> [UnitId]
mkBaseUnits optMbPackageName
| optMbPackageName == Just (stringToUnitId "daml-prim") =
[]

2
compiler/damlc/daml-package-config/BUILD.bazel
View File

@ -28,9 +28,9 @@ da_haskell_library(
src_strip_prefix = "src",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-lf-ast",
"//daml-assistant:daml-project-config",
"//sdk-version/hs:sdk-version-class-lib",
],
)

2
compiler/damlc/daml-preprocessor/BUILD.bazel
View File

@ -32,7 +32,6 @@ da_haskell_library(
src_strip_prefix = "src",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-lf-ast",
"//compiler/daml-lf-proto",
"//compiler/daml-lf-tools",
@ -40,5 +39,6 @@ da_haskell_library(
"//compiler/damlc/stable-packages:stable-packages-lib",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-class-lib",
],
)

2
compiler/damlc/daml-rule-types/BUILD.bazel
View File

@ -48,7 +48,6 @@ da_haskell_library(
src_strip_prefix = "src",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-lf-ast",
"//compiler/daml-lf-proto",
"//compiler/daml-lf-reader",
@ -59,5 +58,6 @@ da_haskell_library(
"//compiler/scenario-service/client",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-class-lib",
],
)

9
compiler/damlc/exe/Main.hs
View File

@ -1,6 +1,11 @@
-- Copyright (c) 2023 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
module Main (module DA.Cli.Damlc) where
module Main (main) where
import DA.Cli.Damlc
import SdkVersion (withSdkVersions)
import qualified DA.Cli.Damlc
main :: IO ()
main = withSdkVersions DA.Cli.Damlc.main

85
compiler/damlc/lib/DA/Cli/Damlc.hs
View File

@ -86,7 +86,6 @@ import DA.Daml.Compiler.Dar (FromDalf(..),
import DA.Daml.Compiler.Output (diagnosticsLogger, writeOutput, writeOutputBSL)
import DA.Daml.Project.Types
( UnresolvedReleaseVersion(..),
unresolvedBuiltinSdkVersion,
unresolvedReleaseVersionToString,
parseUnresolvedVersion,
isHeadVersion,
@ -276,7 +275,7 @@ import "ghc-lib-parser" HsDumpAst
import "ghc-lib" HscStats
import "ghc-lib-parser" HscTypes
import qualified "ghc-lib-parser" Outputable as GHC
import qualified SdkVersion
import qualified SdkVersion.Class
import "ghc-lib-parser" Util (looksLikePackageName)
import Text.Regex.TDFA
@ -315,7 +314,7 @@ data CommandName =
deriving (Ord, Show, Eq)
data Command = Command CommandName (Maybe ProjectOpts) (IO ())
cmdIde :: Int -> Mod CommandFields Command
cmdIde :: SdkVersion.Class.SdkVersioned => Int -> Mod CommandFields Command
cmdIde numProcessors =
command "ide" $ info (helper <*> cmd) $
progDesc
@ -340,7 +339,7 @@ cmdLicense =
"License information for open-source projects included in Daml."
<> fullDesc
cmdCompile :: Int -> Mod CommandFields Command
cmdCompile :: SdkVersion.Class.SdkVersioned => Int -> Mod CommandFields Command
cmdCompile numProcessors =
command "compile" $ info (helper <*> cmd) $
progDesc "Compile the Daml program into a Core/Daml-LF archive."
@ -363,7 +362,7 @@ cmdCompile numProcessors =
help "Produce interface files. This is used for building the package db for daml-prim and daml-stdib" <>
long "write-iface"
cmdDesugar :: Int -> Mod CommandFields Command
cmdDesugar :: SdkVersion.Class.SdkVersioned => Int -> Mod CommandFields Command
cmdDesugar numProcessors =
command "desugar" $ info (helper <*> cmd) $
progDesc "Show the desugared Daml program"
@ -378,7 +377,7 @@ cmdDesugar numProcessors =
optPackageName
disabledDlintUsageParser
cmdDebugIdeSpanInfo :: Int -> Mod CommandFields Command
cmdDebugIdeSpanInfo :: SdkVersion.Class.SdkVersioned => Int -> Mod CommandFields Command
cmdDebugIdeSpanInfo numProcessors =
command "debug-ide-span-info" $ info (helper <*> cmd) $
progDesc "Show the IDE span infos for the Daml program"
@ -393,7 +392,7 @@ cmdDebugIdeSpanInfo numProcessors =
optPackageName
disabledDlintUsageParser
cmdLint :: Int -> Mod CommandFields Command
cmdLint :: SdkVersion.Class.SdkVersioned => Int -> Mod CommandFields Command
cmdLint numProcessors =
command "lint" $ info (helper <*> cmd) $
progDesc "Lint the Daml program."
@ -407,7 +406,7 @@ cmdLint numProcessors =
optPackageName
enabledDlintUsageParser
cmdTest :: Int -> Mod CommandFields Command
cmdTest :: SdkVersion.Class.SdkVersioned => Int -> Mod CommandFields Command
cmdTest numProcessors =
command "test" $ info (helper <*> cmd) $
progDesc progDoc
@ -454,7 +453,8 @@ cmdTest numProcessors =
long "coverage-ignore-choice" <> help "Remove choices matching a regex from the coverage report. The full name of a local choice takes the format '<module>:<template name>:<choice name>', preceded by '<package id>:' for nonlocal packages."
runTestsInProjectOrFiles ::
ProjectOpts
SdkVersion.Class.SdkVersioned
=> ProjectOpts
-> Maybe [FilePath]
-> RunAllTests
-> LoadCoverageOnly
@ -506,13 +506,13 @@ cmdInspect =
jsonOpt = switch $ long "json" <> help "Output the raw Protocol Buffer structures as JSON"
cmd = execInspect <$> inputFileOptWithExt ".dalf or .dar" <*> outputFileOpt <*> jsonOpt <*> cliOptDetailLevel
cmdBuild :: Int -> Mod CommandFields Command
cmdBuild :: SdkVersion.Class.SdkVersioned => Int -> Mod CommandFields Command
cmdBuild numProcessors =
command "build" $
info (helper <*> cmdBuildParser numProcessors) $
progDesc "Initialize, build and package the Daml project" <> fullDesc
cmdBuildParser :: Int -> Parser Command
cmdBuildParser :: SdkVersion.Class.SdkVersioned => Int -> Parser Command
cmdBuildParser numProcessors =
execBuild
<$> projectOpts "daml build"
@ -529,7 +529,7 @@ cmdBuildParser numProcessors =
<*> multiPackageNoCacheOpt
<*> multiPackageLocationOpt
cmdRepl :: Int -> Mod CommandFields Command
cmdRepl :: SdkVersion.Class.SdkVersioned => Int -> Mod CommandFields Command
cmdRepl numProcessors =
command "repl" $ info (helper <*> cmd) $
progDesc "Launch the Daml REPL." <>
@ -639,7 +639,7 @@ cmdClean =
<*> multiPackageLocationOpt
<*> multiPackageCleanAllOpt
cmdInit :: Int -> Mod CommandFields Command
cmdInit :: SdkVersion.Class.SdkVersioned => Int -> Mod CommandFields Command
cmdInit numProcessors =
command "init" $
info (helper <*> cmd) $ progDesc "Initialize a Daml project" <> fullDesc
@ -652,7 +652,7 @@ cmdInit numProcessors =
disabledDlintUsageParser
<*> projectOpts "daml damlc init"
cmdPackage :: Int -> Mod CommandFields Command
cmdPackage :: SdkVersion.Class.SdkVersioned => Int -> Mod CommandFields Command
cmdPackage numProcessors =
command "package" $ info (helper <*> cmd) $
progDesc "Compile the Daml program into a DAR (deprecated)"
@ -702,7 +702,7 @@ cmdMergeDars =
where
cmd = execMergeDars <$> inputDarOpt <*> inputDarOpt <*> targetFileNameOpt
cmdDocTest :: Int -> Mod CommandFields Command
cmdDocTest :: SdkVersion.Class.SdkVersioned => Int -> Mod CommandFields Command
cmdDocTest numProcessors =
command "doctest" $
info (helper <*> cmd) $
@ -734,7 +734,8 @@ execLicense =
licenseData :: B.ByteString
licenseData = $(embedFile "NOTICES")
execIde :: Telemetry
execIde :: SdkVersion.Class.SdkVersioned
=> Telemetry
-> Debug
-> EnableScenarioService
-> StudioAutorunAllScenarios
@ -799,7 +800,7 @@ execIde telemetry (Debug debug) enableScenarioService autorunAllScenarios option
-- | Whether we should write interface files during `damlc compile`.
newtype WriteInterface = WriteInterface Bool
execCompile :: FilePath -> FilePath -> Options -> WriteInterface -> Maybe FilePath -> Command
execCompile :: SdkVersion.Class.SdkVersioned => FilePath -> FilePath -> Options -> WriteInterface -> Maybe FilePath -> Command
execCompile inputFile outputFile opts (WriteInterface writeInterface) mbIfaceDir =
Command Compile (Just projectOpts) effect
where
@ -833,7 +834,7 @@ execCompile inputFile outputFile opts (WriteInterface writeInterface) mbIfaceDir
createDirectoryIfMissing True $ takeDirectory outputFile
B.writeFile outputFile $ Archive.encodeArchive bs
execDesugar :: FilePath -> FilePath -> Options -> Command
execDesugar :: SdkVersion.Class.SdkVersioned => FilePath -> FilePath -> Options -> Command
execDesugar inputFile outputFile opts = Command Desugar (Just projectOpts) effect
where
projectOpts = ProjectOpts Nothing (ProjectCheck "" False)
@ -845,7 +846,7 @@ execDesugar inputFile outputFile opts = Command Desugar (Just projectOpts) effec
createDirectoryIfMissing True $ takeDirectory outputFile
T.writeFile outputFile s
execDebugIdeSpanInfo :: FilePath -> FilePath -> Options -> Command
execDebugIdeSpanInfo :: SdkVersion.Class.SdkVersioned => FilePath -> FilePath -> Options -> Command
execDebugIdeSpanInfo inputFile outputFile opts =
Command DebugIdeSpanInfo (Just projectOpts) effect
where
@ -866,7 +867,7 @@ execDebugIdeSpanInfo inputFile outputFile opts =
createDirectoryIfMissing True $ takeDirectory outputFile
TL.writeFile outputFile s
execLint :: [FilePath] -> Options -> Command
execLint :: SdkVersion.Class.SdkVersioned => [FilePath] -> Options -> Command
execLint inputFiles opts =
Command Lint (Just projectOpts) effect
where
@ -896,7 +897,7 @@ defaultProjectPath = ProjectPath "."
-- | If we're in a daml project, read the daml.yaml field, install the dependencies and create the
-- project local package database. Otherwise do nothing.
execInit :: Options -> ProjectOpts -> Command
execInit :: SdkVersion.Class.SdkVersioned => Options -> ProjectOpts -> Command
execInit opts projectOpts =
Command Init (Just projectOpts) effect
where effect = withProjectRoot' projectOpts $ \_relativize ->
@ -904,7 +905,7 @@ execInit opts projectOpts =
opts
(InitPkgDb True)
installDepsAndInitPackageDb :: Options -> InitPkgDb -> IO ()
installDepsAndInitPackageDb :: SdkVersion.Class.SdkVersioned => Options -> InitPkgDb -> IO ()
installDepsAndInitPackageDb opts (InitPkgDb shouldInit) =
when shouldInit $ do
-- Rather than just checking that there is a daml.yaml file we check that it has a project configuration.
@ -942,7 +943,8 @@ getMultiPackagePath multiPackageLocation =
pure $ Just $ ProjectPath path
execBuild
:: ProjectOpts
:: SdkVersion.Class.SdkVersioned
=> ProjectOpts
-> Options
-> Maybe FilePath
-> IncrementalBuild
@ -1037,7 +1039,7 @@ withMaybeConfig withConfig handler = do
) (withConfig $ pure . Just)
handler mConfig
buildEffect :: (FilePath -> IO FilePath) -> PackageConfigFields -> Options -> Maybe FilePath -> IncrementalBuild -> InitPkgDb -> IO (Maybe LF.PackageId)
buildEffect :: SdkVersion.Class.SdkVersioned => (FilePath -> IO FilePath) -> PackageConfigFields -> Options -> Maybe FilePath -> IncrementalBuild -> InitPkgDb -> IO (Maybe LF.PackageId)
buildEffect relativize pkgConfig@PackageConfigFields{..} opts mbOutFile incrementalBuild initPkgDb = do
installDepsAndInitPackageDb opts initPkgDb
loggerH <- getLogger opts "build"
@ -1103,7 +1105,8 @@ buildEffect relativize pkgConfig@PackageConfigFields{..} opts mbOutFile incremen
We currently rely on shake to find cycles, how its errors includes too much information about internals, so we'll need to implement our own cycle detection.
-}
multiPackageBuildEffect
:: (FilePath -> IO FilePath)
:: SdkVersion.Class.SdkVersioned
=> (FilePath -> IO FilePath)
-> Maybe PackageConfigFields -- Nothing signifies build all
-> MultiPackageConfigFields
-> ProjectOpts
@ -1333,7 +1336,8 @@ buildMultiRule assistantRunner buildableDataDeps (MultiPackageNoCache noCache) m
pure $ makeReturn ownPid True
execRepl
:: [FilePath]
:: SdkVersion.Class.SdkVersioned
=> [FilePath]
-> [(LF.PackageName, Maybe LF.PackageVersion)]
-> Maybe (String, String)
-> Maybe FilePath
@ -1382,7 +1386,7 @@ execRepl dars importPkgs mbLedgerConfig mbAuthToken mbAppId mbSslConf mbMaxInbou
ReplClient.withReplClient replClientOptions $ \replHandle ->
withTempDir $ \dir ->
withCurrentDirectory dir $ do
sdkVer <- fromMaybe SdkVersion.sdkVersion <$> lookupEnv sdkVersionEnvVar
sdkVer <- fromMaybe SdkVersion.Class.sdkVersion <$> lookupEnv sdkVersionEnvVar
writeFileUTF8 "daml.yaml" $ unlines $
[ "sdk-version: " <> sdkVer
, "name: repl"
@ -1437,7 +1441,8 @@ singleCleanEffect projectOpts =
putStrLn "Removed build artifacts."
execPackage :: ProjectOpts
execPackage :: SdkVersion.Class.SdkVersioned
=> ProjectOpts
-> FilePath -- ^ input file
-> Options
-> Maybe FilePath
@ -1472,7 +1477,7 @@ execPackage projectOpts filePath opts mbOutFile dalfInput =
, pVersion = optMbPackageVersion opts
, pDependencies = []
, pDataDependencies = []
, pSdkVersion = unresolvedBuiltinSdkVersion
, pSdkVersion = SdkVersion.Class.unresolvedBuiltinSdkVersion
, pModulePrefixes = Map.empty
, pUpgradedPackagePath = Nothing
, pTypecheckUpgrades = False
@ -1584,7 +1589,7 @@ execMergeDars darFp1 darFp2 mbOutFp =
-- | Should source files for doc test be imported into the test project (default yes)
newtype ImportSource = ImportSource Bool
execDocTest :: Options -> FilePath -> ImportSource -> [FilePath] -> Command
execDocTest :: SdkVersion.Class.SdkVersioned => Options -> FilePath -> ImportSource -> [FilePath] -> Command
execDocTest opts scriptDar (ImportSource importSource) files =
Command DocTest Nothing effect
where
@ -1592,8 +1597,8 @@ execDocTest opts scriptDar (ImportSource importSource) files =
let files' = map toNormalizedFilePath' files
packageFlag =
ExposePackage
("--package daml-script-" <> SdkVersion.sdkPackageVersion)
(UnitIdArg $ stringToUnitId $ "daml-script-" <> SdkVersion.sdkPackageVersion)
("--package daml-script-" <> SdkVersion.Class.sdkPackageVersion)
(UnitIdArg $ stringToUnitId $ "daml-script-" <> SdkVersion.Class.sdkPackageVersion)
(ModRenaming True [])
logger <- getLogger opts "doctest"
@ -1608,8 +1613,8 @@ execDocTest opts scriptDar (ImportSource importSource) files =
then do
damlPath <- getDamlPath
damlEnv <- getDamlEnv damlPath (LookForProjectPath False)
resolveReleaseVersion (envUseCache damlEnv) unresolvedBuiltinSdkVersion
else pure (unsafeResolveReleaseVersion unresolvedBuiltinSdkVersion)
resolveReleaseVersion (envUseCache damlEnv) SdkVersion.Class.unresolvedBuiltinSdkVersion
else pure (unsafeResolveReleaseVersion SdkVersion.Class.unresolvedBuiltinSdkVersion)
installDependencies "." opts releaseVersion [scriptDar] []
createProjectPackageDb "." opts mempty
@ -1643,7 +1648,7 @@ execDocTest opts scriptDar (ImportSource importSource) files =
-- main
--------------------------------------------------------------------------------
options :: Int -> Parser Command
options :: SdkVersion.Class.SdkVersioned => Int -> Parser Command
options numProcessors =
subparser
( cmdIde numProcessors
@ -1670,7 +1675,7 @@ options numProcessors =
<> cmdClean
)
parserInfo :: Int -> Bool -> ParserInfo Command
parserInfo :: SdkVersion.Class.SdkVersioned => Int -> Bool -> ParserInfo Command
parserInfo numProcessors addBuildArgsBackupParser =
info (backupParserWithBuildArgs addBuildArgsBackupParser $ helper <*> options numProcessors)
( fullDesc
@ -1683,7 +1688,7 @@ parserInfo numProcessors addBuildArgsBackupParser =
-- | Add the build parser as a backup for when we're adding the CLI args from daml.yaml, incase whatever command
-- we're running doesn't recognise all of the `build-options:` e.g. `daml test` cannot use `--output`
backupParserWithBuildArgs :: Bool -> Parser Command -> Parser Command
backupParserWithBuildArgs :: SdkVersion.Class.SdkVersioned => Bool -> Parser Command -> Parser Command
backupParserWithBuildArgs shouldBackup parser = if shouldBackup then parser <* cmdBuildParser 1 else parser
-- | Attempts to find the --output flag in the given build-options for a package
@ -1773,7 +1778,7 @@ cliArgsFromDamlYaml =
Left _ -> []
Right xs -> xs
fullParseArgs :: Int -> [String] -> IO Command
fullParseArgs :: SdkVersion.Class.SdkVersioned => Int -> [String] -> IO Command
fullParseArgs numProcessors cliArgs = do
let parse :: [String] -> Maybe [String] -> ([String], ParserResult Command)
parse args mBuildOptions =
@ -1798,7 +1803,7 @@ fullParseArgs numProcessors cliArgs = do
pure cmd
main :: IO ()
main :: SdkVersion.Class.SdkVersioned => IO ()
main = do
-- We need this to ensure that logs are flushed on SIGTERM.
installSignalHandlers

4
compiler/damlc/lib/DA/Cli/Damlc/BuildInfo.hs
View File

@ -7,7 +7,7 @@ module DA.Cli.Damlc.BuildInfo
) where
import qualified Text.PrettyPrint.ANSI.Leijen as PP
import SdkVersion
import SdkVersion.Class (SdkVersioned, sdkVersion)
buildInfo :: PP.Doc
buildInfo :: SdkVersioned => PP.Doc
buildInfo = "SDK Version: " <> PP.text sdkVersion

4
compiler/damlc/lib/DA/Cli/Damlc/Command/Damldoc.hs
View File

@ -19,6 +19,8 @@ import Data.List.Extra
import qualified Data.Text as T
import qualified Data.Set as Set
import SdkVersion.Class (SdkVersioned)
------------------------------------------------------------
cmd :: Int -> (CmdArgs -> a) -> Mod CommandFields a
@ -296,7 +298,7 @@ data CmdArgs = Damldoc
, cMainFiles :: [FilePath]
}
exec :: CmdArgs -> IO ()
exec :: SdkVersioned => CmdArgs -> IO ()
exec Damldoc{..} = do
when (cOutputFormat == OutputDocs Markdown && cGlobalInternalExt /= "md") $
putStrLn $

12
compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs
View File

@ -64,7 +64,7 @@ import qualified DA.Pretty
import qualified DA.Service.Logger as Logger
import Development.IDE.Core.IdeState.Daml
import Development.IDE.Core.RuleTypes.Daml
import SdkVersion
import SdkVersion.Class (SdkVersioned, damlStdlib)
-- | Create the project package database containing the given dar packages.
--
@ -80,7 +80,7 @@ import SdkVersion
-- ledger. Based on the Daml-LF we generate dummy interface files
-- and then remap references to those dummy packages to the original Daml-LF
-- package id.
createProjectPackageDb :: NormalizedFilePath -> Options -> MS.Map UnitId GHC.ModuleName -> IO ()
createProjectPackageDb :: SdkVersioned => NormalizedFilePath -> Options -> MS.Map UnitId GHC.ModuleName -> IO ()
createProjectPackageDb projectRoot (disableScenarioService -> opts) modulePrefixes
= do
(needsReinitalization, depsFingerprint) <- dbNeedsReinitialization projectRoot depsDir
@ -259,7 +259,7 @@ data InstallDataDepArgs = InstallDataDepArgs
, dalfPackage :: LF.DalfPackage
}
installDataDep :: InstallDataDepArgs -> IO ()
installDataDep :: SdkVersioned => InstallDataDepArgs -> IO ()
installDataDep InstallDataDepArgs {..} = do
exposedModules <- getExposedModules opts projectRoot
@ -342,7 +342,7 @@ data GenerateAndInstallIfaceFilesArgs = GenerateAndInstallIfaceFilesArgs
}
-- | Generate interface files and install them in the package database
generateAndInstallIfaceFiles :: GenerateAndInstallIfaceFilesArgs -> IO ()
generateAndInstallIfaceFiles :: SdkVersioned => GenerateAndInstallIfaceFilesArgs -> IO ()
generateAndInstallIfaceFiles GenerateAndInstallIfaceFilesArgs {..} = do
let pkgContext = T.pack (unitIdString (pkgNameVersion pkgName mbPkgVersion)) <> " (" <> LF.unPackageId pkgId <> ")"
loggerH <- getLogger opts $ "data-dependencies " <> pkgContext
@ -462,7 +462,7 @@ recachePkgDb dbPath = do
]
-- TODO We should generate the list of stable packages automatically here.
baseImports :: [PackageFlag]
baseImports :: SdkVersioned => [PackageFlag]
baseImports =
[ exposePackage
(GHC.stringToUnitId "daml-prim")
@ -857,7 +857,7 @@ checkForUnitIdConflicts dalfs builtinDependencies
]
]
getExposedModules :: Options -> NormalizedFilePath -> IO (MS.Map UnitId (UniqSet GHC.ModuleName))
getExposedModules :: SdkVersioned => Options -> NormalizedFilePath -> IO (MS.Map UnitId (UniqSet GHC.ModuleName))
getExposedModules opts projectRoot = do
logger <- getLogger opts "list exposed modules"
-- We need to avoid inference of package flags. Otherwise, we will

4
compiler/damlc/lib/DA/Cli/Damlc/Test.hs
View File

@ -61,6 +61,8 @@ import qualified Text.Blaze.Html.Renderer.Text as Blaze
import qualified Text.Blaze.Html4.Strict as Blaze
import Text.Regex.TDFA
import SdkVersion.Class (SdkVersioned)
newtype UseColor = UseColor {getUseColor :: Bool}
newtype ShowCoverage = ShowCoverage {getShowCoverage :: Bool}
newtype CoverageFilter = CoverageFilter {getCoverageFilter :: Regex}
@ -74,7 +76,7 @@ data CoveragePaths = CoveragePaths
newtype LoadCoverageOnly = LoadCoverageOnly {getLoadCoverageOnly :: Bool}
-- | Test a Daml file.
execTest :: [NormalizedFilePath] -> RunAllTests -> ShowCoverage -> UseColor -> Maybe FilePath -> Options -> TableOutputPath -> TransactionsOutputPath -> CoveragePaths -> [CoverageFilter] -> IO ()
execTest :: SdkVersioned => [NormalizedFilePath] -> RunAllTests -> ShowCoverage -> UseColor -> Maybe FilePath -> Options -> TableOutputPath -> TransactionsOutputPath -> CoveragePaths -> [CoverageFilter] -> IO ()
execTest inFiles runAllTests coverage color mbJUnitOutput opts tableOutputPath transactionsOutputPath resultsIO coverageFilters = do
loggerH <- getLogger opts "test"
withDamlIdeState opts loggerH diagnosticsLogger $ \h -> do

31
compiler/damlc/tests/BUILD.bazel
View File

@ -29,6 +29,7 @@ da_haskell_test(
deps = [
"//compiler/damlc:damlc-lib",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -74,12 +75,12 @@ da_haskell_test(
src_strip_prefix = "tests",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/damlc:damlc-lib",
"//compiler/damlc/daml-opts:daml-opts-types",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -104,10 +105,10 @@ da_haskell_test(
src_strip_prefix = "tests",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/damlc:damlc-lib",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -150,7 +151,6 @@ da_haskell_library(
],
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-lf-ast",
"//compiler/daml-lf-proto-encode",
"//compiler/damlc:damlc-lib",
@ -167,6 +167,7 @@ da_haskell_library(
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -273,6 +274,7 @@ da_haskell_test(
"//compiler/damlc/daml-doc:daml-doc-testing",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -309,6 +311,7 @@ da_haskell_test(
"//compiler/damlc/daml-opts",
"//compiler/damlc/daml-opts:daml-opts-types",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -372,6 +375,7 @@ da_haskell_test(
"//compiler/scenario-service/client",
"//libs-haskell/da-hs-base",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -399,10 +403,10 @@ da_haskell_test(
src_strip_prefix = "src",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-lf-ast",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -428,10 +432,10 @@ da_haskell_test(
src_strip_prefix = "src",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/damlc/daml-opts:daml-opts-types",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -460,11 +464,11 @@ da_haskell_test(
src_strip_prefix = "src",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-lf-ast",
"//compiler/damlc/daml-opts:daml-opts-types",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -493,9 +497,9 @@ da_haskell_test(
src_strip_prefix = "src",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -527,7 +531,6 @@ da_haskell_test(
src_strip_prefix = "src",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-lf-ast",
"//compiler/daml-lf-proto",
"//compiler/daml-lf-reader",
@ -535,6 +538,7 @@ da_haskell_test(
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -588,7 +592,6 @@ daml_compile(
] + extra_tags,
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-lf-ast",
"//compiler/daml-lf-proto",
"//compiler/daml-lf-reader",
@ -596,6 +599,7 @@ daml_compile(
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-lib",
],
)
for (suffix, extra_tags, test_args) in [
@ -841,7 +845,6 @@ da_haskell_test(
tags = ["cpu:4"],
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-lf-ast",
"//compiler/damlc:damlc-lib",
"//compiler/damlc/daml-compiler",
@ -853,6 +856,7 @@ da_haskell_test(
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -1074,7 +1078,6 @@ da_haskell_test(
],
main_function = "DA.Test.ScriptService.main",
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-lf-ast",
"//compiler/damlc:damlc-lib",
"//compiler/damlc/daml-ide-core",
@ -1086,6 +1089,7 @@ da_haskell_test(
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -1117,7 +1121,6 @@ da_haskell_test(
],
main_function = "DA.Test.ScriptService.main",
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-lf-ast",
"//compiler/damlc:damlc-lib",
"//compiler/damlc/daml-ide-core",
@ -1128,6 +1131,7 @@ da_haskell_test(
"//daml-assistant:daml-project-config",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -1157,13 +1161,13 @@ da_haskell_test(
tags = ["cpu:4"],
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-dar-reader",
"//compiler/daml-lf-ast",
"//daml-assistant/daml-helper:daml-helper-lib",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -1250,6 +1254,7 @@ da_haskell_test(
"//compiler/damlc/daml-desugar:daml-desugar-testing",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-lib",
],
)

12
compiler/damlc/tests/src/CliParser.hs
View File

@ -20,12 +20,14 @@ import System.IO.Silently (hCapture)
import Test.Tasty
import Test.Tasty.HUnit
import SdkVersion (SdkVersioned, withSdkVersions)
main :: IO ()
main = do
main = withSdkVersions $ do
setEnv "TASTY_NUM_THREADS" "1" True
defaultMain tests
tests :: TestTree
tests :: SdkVersioned => TestTree
tests = testGroup
"Cli arguments"
[ testCase "No flags in strict mode" $ parseSucceeds ["ide"]
@ -56,7 +58,7 @@ withCurrentTempDir = withTempDir . flip withCurrentDirectory
-- Runs the damlc parser with a set of command line flags/options, and a set of daml.yaml flags/options
-- Takes a maybe expected error infix
assertDamlcParser :: [String] -> [String] -> Maybe String -> Assertion
assertDamlcParser :: SdkVersioned => [String] -> [String] -> Maybe String -> Assertion
assertDamlcParser cliArgs damlYamlArgs mExpectedError = withCurrentTempDir $ do
(err, res) <- runDamlcParser cliArgs damlYamlArgs
case (isRight res, mExpectedError) of
@ -76,7 +78,7 @@ withDamlProject f = do
-- Run the damlc parser with a set of command line flags/options, and a set of daml.yaml flags/options
-- Run the resulting computation and assert a given string is part of stdout+stderr
assertDamlcParserRunIO :: [String] -> [String] -> String -> Assertion
assertDamlcParserRunIO :: SdkVersioned => [String] -> [String] -> String -> Assertion
assertDamlcParserRunIO cliArgs damlYamlArgs expectedOutput = withCurrentTempDir $ do
(err, res) <- runDamlcParser cliArgs damlYamlArgs
case res of
@ -87,7 +89,7 @@ assertDamlcParserRunIO cliArgs damlYamlArgs expectedOutput = withCurrentTempDir
assertBool ("Expected " <> expectedOutput <> " in stdout/stderr, but didn't find") $ expectedOutput `isInfixOf` out
Left _ -> assertFailure $ "Expected parse to succeed but got " <> err
runDamlcParser :: [String] -> [String] -> IO (String, Either SomeException Command)
runDamlcParser :: SdkVersioned => [String] -> [String] -> IO (String, Either SomeException Command)
runDamlcParser cliArgs damlYamlArgs = do
T.writeFileUtf8 "./daml.yaml" $ T.unlines $
[ "sdk-version: 0.0.0" -- Fixed version as the parser doesn't care for its value.

6
compiler/damlc/tests/src/DA/Test/DamlDesugar.hs
View File

@ -12,13 +12,15 @@ import System.FilePath ((</>))
import qualified Test.Tasty.Extended as Tasty
import SdkVersion (SdkVersioned, withSdkVersions)
main :: IO ()
main = do
main = withSdkVersions $ do
setEnv "TASTY_NUM_THREADS" "1" True
testDir <- locateRunfiles $ mainWorkspace </> "compiler/damlc/tests/daml-test-files"
Tasty.deterministicMain =<< allTests testDir
allTests :: FilePath -> IO Tasty.TestTree
allTests :: SdkVersioned => FilePath -> IO Tasty.TestTree
allTests testDir = Tasty.testGroup "All Daml GHC tests using Tasty" <$> sequence
[ mkTestTree testDir
]

6
compiler/damlc/tests/src/DA/Test/DamlDoc.hs
View File

@ -13,13 +13,15 @@ import qualified Test.Tasty.Extended as Tasty
import DA.Test.DamlcIntegration (ScriptPackageData, withDamlScriptDep)
import System.Environment.Blank
import SdkVersion (SdkVersioned, withSdkVersions)
main :: IO ()
main = do
main = withSdkVersions $ do
setEnv "TASTY_NUM_THREADS" "1" True
anchors <- loadExternalAnchors DefaultExternalAnchorPath
withDamlScriptDep Nothing $ Tasty.deterministicMain <=< allTests anchors
allTests :: AnchorMap -> ScriptPackageData -> IO Tasty.TestTree
allTests :: SdkVersioned => AnchorMap -> ScriptPackageData -> IO Tasty.TestTree
allTests externalAnchors scriptPackageData = Tasty.testGroup "All Daml GHC tests using Tasty" <$> sequence
[ Damldoc.mkTestTree externalAnchors scriptPackageData
, Render.mkTestTree externalAnchors

6
compiler/damlc/tests/src/DA/Test/DamlDocTest.hs
View File

@ -19,8 +19,10 @@ import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Location
import System.Environment.Blank (setEnv)
import SdkVersion (SdkVersioned, withSdkVersions)
main :: IO ()
main =
main = withSdkVersions $ do
-- Install Daml.Script once at the start of the suite, rather than for each case
withDamlScriptDep Nothing $ \scriptPackageData -> do
-- Must run serially
@ -31,7 +33,7 @@ main =
-- These test names are converted to module names by removing spaces
-- Do not use any characters that wouldn't be accepted as a haskell module name (e.g. '-', '.', etc.)
generateTests :: ScriptPackageData -> TestTree
generateTests :: SdkVersioned => ScriptPackageData -> TestTree
generateTests scriptPackageData = testGroup "generate doctest module"
[ shouldGenerateCase "empty module" [] []
, shouldGenerateCase "example in doc comment"

14
compiler/damlc/tests/src/DA/Test/DamlcIntegration.hs
View File

@ -94,7 +94,7 @@ import Test.Tasty.Runners (Result(..))
import DA.Cli.Damlc.DependencyDb (installDependencies)
import DA.Cli.Damlc.Packaging (createProjectPackageDb)
import Module (stringToUnitId)
import SdkVersion (sdkVersion, sdkPackageVersion)
import SdkVersion (SdkVersioned, withSdkVersions, sdkVersion, sdkPackageVersion)
-- Newtype to avoid mixing up the loging function and the one for registering TODOs.
newtype TODO = TODO String
@ -124,17 +124,17 @@ instance IsOption IsScriptV2Opt where
type ScriptPackageData = (FilePath, [PackageFlag])
-- | Creates a temp directory with daml script v1 installed, gives the database db path and package flag
withDamlScriptDep :: Maybe Version -> (ScriptPackageData -> IO a) -> IO a
withDamlScriptDep :: SdkVersioned => Maybe Version -> (ScriptPackageData -> IO a) -> IO a
withDamlScriptDep mLfVer =
let
lfVerStr = maybe "" (\lfVer -> "-" <> renderVersion lfVer) mLfVer
darPath = "daml-script" </> "daml" </> "daml-script" <> lfVerStr <> ".dar"
in withVersionedDamlScriptDep ("daml-script-" <> sdkPackageVersion) darPath mLfVer []
withDamlScriptV2Dep :: Maybe Version -> (ScriptPackageData -> IO a) -> IO a
withDamlScriptV2Dep :: SdkVersioned => Maybe Version -> (ScriptPackageData -> IO a) -> IO a
withDamlScriptV2Dep mLfVer = withDamlScriptV2Dep' mLfVer []
withDamlScriptV2Dep' :: Maybe Version -> [(String, String)] -> (ScriptPackageData -> IO a) -> IO a
withDamlScriptV2Dep' :: SdkVersioned => Maybe Version -> [(String, String)] -> (ScriptPackageData -> IO a) -> IO a
withDamlScriptV2Dep' mLfVer extraPackages =
let
lfVerStr = maybe "" (\lfVer -> "-" <> renderVersion lfVer) mLfVer
@ -155,7 +155,7 @@ scriptV2ExternalPackages =
-- | Takes the bazel namespace, dar suffix (used for lf versions in v1) and lf version, installs relevant daml script and gives
-- database db path and package flag
withVersionedDamlScriptDep :: String -> String -> Maybe Version -> [(String, String)] -> (ScriptPackageData -> IO a) -> IO a
withVersionedDamlScriptDep :: SdkVersioned => String -> String -> Maybe Version -> [(String, String)] -> (ScriptPackageData -> IO a) -> IO a
withVersionedDamlScriptDep packageFlagName darPath mLfVer extraPackages cont = do
withTempDir $ \dir -> do
withCurrentDirectory dir $ do
@ -184,7 +184,7 @@ withVersionedDamlScriptDep packageFlagName darPath mLfVer extraPackages cont = d
cont (dir </> projectPackageDatabase, packageFlags)
main :: IO ()
main = do
main = withSdkVersions $ do
-- This is a bit hacky, we want the LF version before we hand over to
-- tasty. To achieve that we first pass with optparse-applicative ignoring
-- everything apart from the LF version.
@ -298,7 +298,7 @@ getCantSkipPreprocessorTestFiles = do
}
]
getIntegrationTests :: (TODO -> IO ()) -> SS.Handle -> ScriptPackageData -> IO TestTree
getIntegrationTests :: SdkVersioned => (TODO -> IO ()) -> SS.Handle -> ScriptPackageData -> IO TestTree
getIntegrationTests registerTODO scenarioService (packageDbPath, packageFlags) = do
putStrLn $ "rtsSupportsBoundThreads: " ++ show rtsSupportsBoundThreads
do n <- getNumCapabilities; putStrLn $ "getNumCapabilities: " ++ show n

6
compiler/damlc/tests/src/DA/Test/DamlcMultiPackage.hs
View File

@ -14,7 +14,7 @@ import Data.Maybe (fromMaybe, fromJust)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.Time.Clock (UTCTime)
import SdkVersion (sdkVersion)
import SdkVersion (SdkVersioned, sdkVersion, withSdkVersions)
import System.Directory.Extra (canonicalizePath, createDirectoryIfMissing, doesFileExist, getModificationTime, removeFile, withCurrentDirectory)
import System.Environment.Blank (setEnv)
import System.Exit (ExitCode (..))
@ -70,7 +70,7 @@ instance Show PackageIdentifier where
-}
main :: IO ()
main = do
main = withSdkVersions $ do
damlAssistant <- locateRunfiles (mainWorkspace </> "daml-assistant" </> exe "daml")
release <- locateRunfiles (mainWorkspace </> "release" </> "sdk-release-tarball-ce.tar.gz")
withTempDir $ \damlHome -> do
@ -84,7 +84,7 @@ main = do
void $ readCreateProcess (proc damlAssistant ["install", release, "--install-with-custom-version", "10.0.0"]) ""
defaultMain $ tests damlAssistant
tests :: FilePath -> TestTree
tests :: SdkVersioned => FilePath -> TestTree
tests damlAssistant =
testGroup
"Multi-Package build"

6
compiler/damlc/tests/src/DA/Test/DamlcUpgrades.hs
View File

@ -14,18 +14,18 @@ import System.IO.Extra
import DA.Test.Process
import Test.Tasty
import Test.Tasty.HUnit
import SdkVersion
import SdkVersion (SdkVersioned, sdkVersion, withSdkVersions)
import DA.Daml.LF.Ast.Version
import Text.Regex.TDFA
import qualified Data.Text as T
import Data.Maybe (fromMaybe)
main :: IO ()
main = do
main = withSdkVersions $ do
damlc <- locateRunfiles (mainWorkspace </> "compiler" </> "damlc" </> exe "damlc")
defaultMain $ tests damlc
tests :: FilePath -> TestTree
tests :: SdkVersioned => FilePath -> TestTree
tests damlc =
testGroup
"Upgrade"

6
compiler/damlc/tests/src/DA/Test/DataDependencies.hs
View File

@ -26,10 +26,10 @@ import System.IO.Extra
import Test.Tasty
import Test.Tasty.HUnit
import SdkVersion
import SdkVersion (SdkVersioned, damlStdlib, sdkVersion, withSdkVersions)
main :: IO ()
main = do
main = withSdkVersions $ do
setEnv "TASTY_NUM_THREADS" "3" True
damlc <- locateRunfiles (mainWorkspace </> "compiler" </> "damlc" </> exe "damlc")
damlcLegacy <- locateRunfiles ("damlc_legacy" </> exe "damlc_legacy")
@ -113,7 +113,7 @@ lfVersionTestPairsV2 =
where
hasMajorVersion major v = LF.versionMajor v == major
tests :: TestArgs -> TestTree
tests :: SdkVersioned => TestArgs -> TestTree
tests TestArgs{..} =
testGroup (LF.renderVersion targetDevVersion) $
[ testCaseSteps ("Cross Daml-LF version: " <> LF.renderVersion depLfVer <> " -> " <> LF.renderVersion targetLfVer) $ \step -> withTempDir $ \tmpDir -> do

6
compiler/damlc/tests/src/DA/Test/IncrementalBuilds.hs
View File

@ -17,10 +17,10 @@ import System.IO.Extra
import DA.Test.Process
import Test.Tasty
import Test.Tasty.HUnit
import SdkVersion
import SdkVersion (SdkVersioned, sdkVersion, withSdkVersions)
main :: IO ()
main = do
main = withSdkVersions $ do
damlc <- locateRunfiles (mainWorkspace </> "compiler" </> "damlc" </> exe "damlc")
damlScript <- locateRunfiles (mainWorkspace </> "daml-script" </> "runner" </> exe "daml-script-binary")
v1TestArgs <- do
@ -41,7 +41,7 @@ data TestArgs = TestArgs
, lfVersion :: LF.Version
}
tests :: TestArgs -> TestTree
tests :: SdkVersioned => TestArgs -> TestTree
tests TestArgs{..} = testGroup ("LF " <> LF.renderVersion lfVersion)
[ test "No changes"
[ ("daml/A.daml", unlines

6
compiler/damlc/tests/src/DA/Test/IncrementalPackageDb.hs
View File

@ -16,16 +16,16 @@ import Test.Tasty
import Test.Tasty.HUnit
import DA.Daml.Options.Packaging.Metadata (metadataFile)
import Development.IDE.Types.Location
import SdkVersion
import SdkVersion (SdkVersioned, sdkVersion, withSdkVersions)
newtype ExpectReinitialization = ExpectReinitialization Bool
main :: IO ()
main = do
main = withSdkVersions $ do
damlc <- locateRunfiles (mainWorkspace </> "compiler" </> "damlc" </> exe "damlc")
defaultMain $ tests damlc
tests :: FilePath -> TestTree
tests :: SdkVersioned => FilePath -> TestTree
tests damlc =
testGroup
"Incremental package db initialization"

8
compiler/damlc/tests/src/DA/Test/Packaging.hs
View File

@ -34,10 +34,10 @@ import Test.Tasty.QuickCheck
import "ghc-lib-parser" Module (stringToUnitId)
import SdkVersion
import SdkVersion (SdkVersioned, sdkVersion, withSdkVersions)
main :: IO ()
main = do
main = withSdkVersions $ do
setEnv "TASTY_NUM_THREADS" "1" True
damlc <- locateRunfiles (mainWorkspace </> "compiler" </> "damlc" </> exe "damlc")
defaultMain $ tests Tools{..}
@ -46,7 +46,7 @@ data Tools = Tools -- and places
{ damlc :: FilePath
}
tests :: Tools -> TestTree
tests :: SdkVersioned => Tools -> TestTree
tests Tools{damlc} = testGroup "Packaging" $
[ testCaseSteps "Build package with dependency" $ \step -> withTempDir $ \tmpDir -> do
let projectA = tmpDir </> "a"
@ -1120,7 +1120,7 @@ tests Tools{damlc} = testGroup "Packaging" $
exitFailure
-- | Test that a package build with --target=targetVersion never has a dependency on a package with version > targetVersion
lfVersionTests :: FilePath -> TestTree
lfVersionTests :: SdkVersioned => FilePath -> TestTree
lfVersionTests damlc = testGroup "LF version dependencies"
[ testCase ("Package in " <> LF.renderVersion version) $ withTempDir $ \projDir -> do
writeFileUTF8 (projDir </> "daml.yaml") $ unlines

11
compiler/damlc/tests/src/DA/Test/Repl/FuncTests.hs
View File

@ -25,7 +25,7 @@ import Development.IDE.Types.Location
import qualified DA.Service.Logger as Logger
import qualified DA.Service.Logger.Impl.IO as Logger
import GHC.IO.Handle
import SdkVersion
import SdkVersion (SdkVersioned, sdkVersion, withSdkVersions)
import System.Directory
import System.FilePath
import System.IO.Extra
@ -46,7 +46,7 @@ import Text.Regex.TDFA
-- stderr.
main :: IO ()
main =
main = withSdkVersions $
hspec $
describe "repl func tests" $
[minBound @LF.MajorVersion .. maxBound] `forM_` \major ->
@ -57,7 +57,7 @@ main =
type InteractionTester = [Step] -> Expectation
withInteractionTester :: LF.MajorVersion -> ActionWith InteractionTester -> IO ()
withInteractionTester :: SdkVersioned => LF.MajorVersion -> ActionWith InteractionTester -> IO ()
withInteractionTester major action = do
let prettyMajor = LF.renderMajorVersion major
let lfVersion = LF.defaultOrLatestStable major
@ -126,7 +126,7 @@ withInteractionTester major action = do
-- We need to kill the process to avoid getting stuck in hGetLine on Windows.
ReplClient.hTerminate replHandle
initPackageConfig :: Options -> FilePath -> [FilePath] -> IO ()
initPackageConfig :: SdkVersioned => Options -> FilePath -> [FilePath] -> IO ()
initPackageConfig options scriptDar dars = do
writeFileUTF8 "daml.yaml" $ unlines $
[ "sdk-version: " <> sdkVersion
@ -419,7 +419,8 @@ functionalTests =
it testName $ \test -> (test steps :: Expectation)
testInteraction
:: ReplClient.Handle
:: SdkVersioned
=> ReplClient.Handle
-> ReplLogger
-> Chan String
-> Options

10
compiler/damlc/tests/src/DA/Test/ScriptService.hs
View File

@ -35,7 +35,7 @@ import Development.IDE.Core.Service (getDiagnostics, runActionSync, shutdown)
import Development.IDE.Core.Shake (ShakeLspEnv(..), NotificationHandler(..), use)
import Development.IDE.Types.Diagnostics (showDiagnostics)
import Development.IDE.Types.Location (toNormalizedFilePath')
import SdkVersion
import SdkVersion (SdkVersioned, sdkVersion, withSdkVersions)
import System.Directory.Extra
import System.Environment.Blank
import System.FilePath
@ -45,7 +45,7 @@ import Test.Tasty.HUnit
import Text.Regex.TDFA
main :: IO ()
main = do
main = withSdkVersions $ do
setEnv "TASTY_NUM_THREADS" "1" True
defaultMain $
testGroup
@ -54,7 +54,7 @@ main = do
| lfVersion <- map LF.defaultOrLatestStable [minBound @LF.MajorVersion .. maxBound]
]
withScriptService :: LF.Version -> (SS.Handle -> IO ()) -> IO ()
withScriptService :: SdkVersioned => LF.Version -> (SS.Handle -> IO ()) -> IO ()
withScriptService lfVersion action =
withTempDir $ \dir -> do
withCurrentDirectory dir $ do
@ -95,7 +95,7 @@ withScriptService lfVersion action =
where
scenarioConfig = SS.defaultScenarioServiceConfig {SS.cnfJvmOptions = ["-Xmx200M"]}
testScriptService :: LF.Version -> IO SS.Handle -> TestTree
testScriptService :: SdkVersioned => LF.Version -> IO SS.Handle -> TestTree
testScriptService lfVersion getScriptService =
testGroup
("LF " <> LF.renderVersion lfVersion)
@ -1229,7 +1229,7 @@ expectScriptFailure xs vr pred = case find ((vr ==) . fst) xs of
options :: LF.Version -> Options
options lfVersion = defaultOptions (Just lfVersion)
runScripts :: IO SS.Handle -> LF.Version -> [T.Text] -> IO [(VirtualResource, Either T.Text T.Text)]
runScripts :: SdkVersioned => IO SS.Handle -> LF.Version -> [T.Text] -> IO [(VirtualResource, Either T.Text T.Text)]
runScripts getService lfVersion fileContent = bracket getIdeState shutdown $ \ideState -> do
setBufferModified ideState file $ Just $ T.unlines fileContent
setFilesOfInterest ideState (HashSet.singleton file)

6
compiler/damlc/tests/src/DA/Test/ScriptService_1_15.hs
View File

@ -34,7 +34,7 @@ import Development.IDE.Core.Service (getDiagnostics, runActionSync, shutdown)
import Development.IDE.Core.Shake (ShakeLspEnv(..), NotificationHandler(..), use)
import Development.IDE.Types.Diagnostics (showDiagnostics)
import Development.IDE.Types.Location (toNormalizedFilePath')
import SdkVersion
import SdkVersion (SdkVersioned, withSdkVersions, sdkVersion)
import System.Directory.Extra
import System.Environment.Blank
import System.FilePath
@ -47,7 +47,7 @@ lfVersion :: LF.Version
lfVersion = LF.version1_15
main :: IO ()
main =
main = withSdkVersions $ do
withTempDir $ \dir -> do
withCurrentDirectory dir $ do
setEnv "TASTY_NUM_THREADS" "1" True
@ -237,7 +237,7 @@ options :: Options
options = defaultOptions (Just lfVersion)
runScripts :: SS.Handle -> [T.Text] -> IO [(VirtualResource, Either T.Text T.Text)]
runScripts :: SdkVersioned => SS.Handle -> [T.Text] -> IO [(VirtualResource, Either T.Text T.Text)]
runScripts service fileContent = bracket getIdeState shutdown $ \ideState -> do
setBufferModified ideState file $ Just $ T.unlines fileContent
setFilesOfInterest ideState (HashSet.singleton file)

24
compiler/damlc/tests/src/DA/Test/ShakeIdeClient.hs
View File

@ -35,8 +35,10 @@ import Development.IDE.Core.Service.Daml(VirtualResource(..))
import DA.Test.DamlcIntegration (ScriptPackageData, withDamlScriptDep, withDamlScriptV2Dep)
import SdkVersion (SdkVersioned, withSdkVersions)
main :: IO ()
main = do
main = withSdkVersions $ do
scenarioLogger <- Logger.newStderrLogger Logger.Warning "scenario"
-- The scenario services are shared resources so running tests in parallel doesn’t work properly.
setEnv "TASTY_NUM_THREADS" "1" True
@ -47,7 +49,7 @@ main = do
| lfVersion <- map LF.defaultOrLatestStable [minBound @LF.MajorVersion .. maxBound]
]
test :: LF.Version -> Logger.Handle IO -> Tasty.TestTree
test :: SdkVersioned => LF.Version -> Logger.Handle IO -> Tasty.TestTree
test lfVersion scenarioLogger = do
-- The startup of each scenario service is fairly expensive so instead of launching a separate
-- service for each test, we launch a single service that is shared across all tests on the same LF version.
@ -62,7 +64,7 @@ test lfVersion scenarioLogger = do
LF.V1 -> withDamlScriptDep
LF.V2 -> withDamlScriptV2Dep
ideTests :: LF.Version -> Maybe (IO SS.Handle) -> IO ScriptPackageData -> Tasty.TestTree
ideTests :: SdkVersioned => LF.Version -> Maybe (IO SS.Handle) -> IO ScriptPackageData -> Tasty.TestTree
ideTests lfVersion mbGetScenarioService getScriptPackageData =
Tasty.testGroup ("LF " <> LF.renderVersion lfVersion)
[ -- Add categories of tests here
@ -82,7 +84,7 @@ addScriptOpts lfVersion = maybe id $ \(packageDbPath, packageFlags) opts -> opts
}
-- | Tasty test case from a ShakeTest.
testCase :: LF.Version -> Maybe (IO SS.Handle) -> Maybe (IO ScriptPackageData) -> Tasty.TestName -> ShakeTest () -> Tasty.TestTree
testCase :: SdkVersioned => LF.Version -> Maybe (IO SS.Handle) -> Maybe (IO ScriptPackageData) -> Tasty.TestName -> ShakeTest () -> Tasty.TestTree
testCase lfVersion mbGetScenarioService mbGetScriptPackageData testName test =
Tasty.testCase testName $ do
mbScenarioService <- sequence mbGetScenarioService
@ -92,7 +94,7 @@ testCase lfVersion mbGetScenarioService mbGetScriptPackageData testName test =
-- | Test case that is expected to fail, because it's an open issue. Includes an infix string to assert, so we can detect error changes
-- Annotate these with a JIRA ticket number.
testCaseFails :: LF.Version -> String -> Maybe (IO SS.Handle) -> Maybe (IO ScriptPackageData) -> Tasty.TestName -> ShakeTest () -> Tasty.TestTree
testCaseFails :: SdkVersioned => LF.Version -> String -> Maybe (IO SS.Handle) -> Maybe (IO ScriptPackageData) -> Tasty.TestName -> ShakeTest () -> Tasty.TestTree
testCaseFails lfVersion expectedErrorInfix mbGetScenarioService mbGetScriptPackageData testName test =
Tasty.testCase ("FAILING " ++ testName) $ do
mbScenarioService <- sequence mbGetScenarioService
@ -106,7 +108,7 @@ testCaseFails lfVersion expectedErrorInfix mbGetScenarioService mbGetScriptPacka
$ expectedErrorInfix `isInfixOf` errStr
-- | Basic API functionality tests.
basicTests :: LF.Version -> Maybe (IO SS.Handle) -> IO ScriptPackageData -> Tasty.TestTree
basicTests :: SdkVersioned => LF.Version -> Maybe (IO SS.Handle) -> IO ScriptPackageData -> Tasty.TestTree
basicTests lfVersion mbScenarioService scriptPackageData = Tasty.testGroup "Basic tests"
[ testCase' "Set files of interest and expect no errors" example
@ -343,7 +345,7 @@ basicTests lfVersion mbScenarioService scriptPackageData = Tasty.testGroup "Basi
testCase' = testCase lfVersion mbScenarioService (Just scriptPackageData)
testCaseFails' msg = testCaseFails lfVersion msg mbScenarioService (Just scriptPackageData)
dlintSmokeTests :: LF.Version -> Maybe (IO SS.Handle) -> Tasty.TestTree
dlintSmokeTests :: SdkVersioned => LF.Version -> Maybe (IO SS.Handle) -> Tasty.TestTree
dlintSmokeTests lfVersion mbScenarioService = Tasty.testGroup "Dlint smoke tests"
[ testCase' "Imports can be simplified" $ do
foo <- makeFile "Foo.daml" $ T.unlines
@ -592,7 +594,7 @@ dlintSmokeTests lfVersion mbScenarioService = Tasty.testGroup "Dlint smoke tests
where
testCase' = testCase lfVersion mbScenarioService Nothing
minimalRebuildTests :: LF.Version -> Maybe (IO SS.Handle) -> Tasty.TestTree
minimalRebuildTests :: SdkVersioned => LF.Version -> Maybe (IO SS.Handle) -> Tasty.TestTree
minimalRebuildTests lfVersion mbScenarioService = Tasty.testGroup "Minimal rebuild tests"
[ testCase' "Minimal rebuild" $ do
a <- makeFile "A.daml" "module A where\nimport B"
@ -616,7 +618,7 @@ minimalRebuildTests lfVersion mbScenarioService = Tasty.testGroup "Minimal rebui
-- | "Go to definition" tests.
goToDefinitionTests :: LF.Version -> Maybe (IO SS.Handle) -> IO ScriptPackageData -> Tasty.TestTree
goToDefinitionTests :: SdkVersioned => LF.Version -> Maybe (IO SS.Handle) -> IO ScriptPackageData -> Tasty.TestTree
goToDefinitionTests lfVersion mbScenarioService scriptPackageData = Tasty.testGroup "Go to definition tests"
[ testCase' "Go to definition in same module" $ do
foo <- makeFile "Foo.daml" $ T.unlines
@ -833,7 +835,7 @@ goToDefinitionTests lfVersion mbScenarioService scriptPackageData = Tasty.testGr
testCase' = testCase lfVersion mbScenarioService (Just scriptPackageData)
testCaseFails' msg = testCaseFails lfVersion msg mbScenarioService (Just scriptPackageData)
onHoverTests :: LF.Version -> Maybe (IO SS.Handle) -> IO ScriptPackageData -> Tasty.TestTree
onHoverTests :: SdkVersioned => LF.Version -> Maybe (IO SS.Handle) -> IO ScriptPackageData -> Tasty.TestTree
onHoverTests lfVersion mbScenarioService scriptPackageData = Tasty.testGroup "On hover tests"
[ testCase' "Type for uses but not for definitions" $ do
f <- makeFile "F.daml" $ T.unlines
@ -952,7 +954,7 @@ onHoverTests lfVersion mbScenarioService scriptPackageData = Tasty.testGroup "On
testCase' = testCase lfVersion mbScenarioService (Just scriptPackageData)
testCaseFails' msg = testCaseFails lfVersion msg mbScenarioService (Just scriptPackageData)
scriptTests :: LF.Version -> Maybe (IO SS.Handle) -> IO ScriptPackageData -> Tasty.TestTree
scriptTests :: SdkVersioned => LF.Version -> Maybe (IO SS.Handle) -> IO ScriptPackageData -> Tasty.TestTree
scriptTests lfVersion mbScenarioService scriptPackageData = Tasty.testGroup "Script tests"
[ testCase' "Run an empty script" $ do
let fooContent = T.unlines

8
compiler/damlc/tests/src/DamlcLint.hs
View File

@ -18,20 +18,20 @@ import Test.Tasty.HUnit
import qualified Data.Text.Extended as T
import DA.Bazel.Runfiles
import SdkVersion
import SdkVersion (SdkVersioned, sdkVersion, withSdkVersions)
main :: IO ()
main = do
main = withSdkVersions $ do
setEnv "TASTY_NUM_THREADS" "1" True
damlc <- locateRunfiles (mainWorkspace </> "compiler" </> "damlc" </> exe "damlc")
defaultMain (tests damlc)
tests :: FilePath -> TestTree
tests :: SdkVersioned => FilePath -> TestTree
tests damlc = testGroup "damlc" $ map (\f -> f damlc)
[ testsForDamlcLint
]
testsForDamlcLint :: FilePath -> TestTree
testsForDamlcLint :: SdkVersioned => FilePath -> TestTree
testsForDamlcLint damlc = testGroup "damlc test"
[ testCase "Lint all project files" $ do
withTempDir $ \dir -> do

8
compiler/damlc/tests/src/DamlcPkgManager.hs
View File

@ -16,7 +16,7 @@ import Data.List
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text.Extended as T
import SdkVersion
import SdkVersion (SdkVersioned, sdkVersion, withSdkVersions)
import System.Directory
import System.Environment.Blank
import System.Exit
@ -27,7 +27,7 @@ import Test.Tasty
import Test.Tasty.HUnit
main :: IO ()
main = do
main = withSdkVersions $ do
setEnv "TASTY_NUM_THREADS" "1" True
damlc <- locateRunfiles (mainWorkspace </> "compiler" </> "damlc" </> exe "damlc")
dar <-
@ -35,11 +35,11 @@ main = do
(mainWorkspace </> "compiler" </> "damlc" </> "tests" </> "pkg-manager-test.dar")
defaultMain (tests damlc dar)
tests :: FilePath -> FilePath -> TestTree
tests :: SdkVersioned => FilePath -> FilePath -> TestTree
tests damlc dar =
testGroup "damlc package manager" $ map (\f -> f damlc dar) [testsForRemoteDataDependencies]
testsForRemoteDataDependencies :: FilePath -> FilePath -> TestTree
testsForRemoteDataDependencies :: SdkVersioned => FilePath -> FilePath -> TestTree
testsForRemoteDataDependencies damlc dar =
testGroup "Remote dependencies"
[ withCantonSandbox defaultSandboxConf {dars = [dar]} $ \getSandboxPort -> do

10
compiler/damlc/tests/src/DamlcTest.hs
View File

@ -23,10 +23,10 @@ import qualified Data.Text.Extended as T
import DA.Bazel.Runfiles
import DA.Test.Process
import DA.Test.Util
import SdkVersion
import SdkVersion (SdkVersioned, sdkVersion, withSdkVersions)
main :: IO ()
main = do
main = withSdkVersions $ do
setEnv "TASTY_NUM_THREADS" "1" True
damlc <- locateRunfiles (mainWorkspace </> "compiler" </> "damlc" </> exe "damlc")
scriptDar <- locateRunfiles (mainWorkspace </> "daml-script" </> "daml" </> "daml-script.dar")
@ -40,13 +40,13 @@ main = do
-- TODO https://github.com/digital-asset/daml/issues/12051
-- Remove script1DevDar arg once Daml-LF 1.15 is the default compiler output
tests :: FilePath -> FilePath -> FilePath -> TestTree
tests :: SdkVersioned => FilePath -> FilePath -> FilePath -> TestTree
tests damlc scriptDar script1DevDar = testGroup "damlc"
[ testsForDamlcValidate damlc
, testsForDamlcTest damlc scriptDar script1DevDar
]
testsForDamlcValidate :: FilePath -> TestTree
testsForDamlcValidate :: SdkVersioned => FilePath -> TestTree
testsForDamlcValidate damlc = testGroup "damlc validate-dar"
[ testCase "Non-existent file" $ do
(exitCode, stdout, stderr) <- readProcessWithExitCode damlc ["validate-dar", "does-not-exist.dar"] ""
@ -267,7 +267,7 @@ testsForDamlcValidate damlc = testGroup "damlc validate-dar"
-- TODO https://github.com/digital-asset/daml/issues/12051
-- Remove script1DevDar arg once Daml-LF 1.15 is the default compiler output
testsForDamlcTest :: FilePath -> FilePath -> FilePath -> TestTree
testsForDamlcTest :: SdkVersioned => FilePath -> FilePath -> FilePath -> TestTree
testsForDamlcTest damlc scriptDar _ = testGroup "damlc test" $
[ testCase "Non-existent file" $ do
(exitCode, stdout, stderr) <- readProcessWithExitCode damlc ["test", "--files", "foobar"] ""

2
compiler/lsp-tests/BUILD.bazel
View File

@ -37,10 +37,10 @@ da_haskell_test(
],
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/damlc/daml-ide-core",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-lib",
"@ghcide_ghc_lib//:testing",
],
)

8
compiler/lsp-tests/src/Main.hs
View File

@ -25,7 +25,7 @@ import Language.LSP.Types hiding (SemanticTokenAbsolute (..), SemanticTokenRelat
import Language.LSP.Types.Capabilities
import Language.LSP.Types.Lens hiding (id, to)
import Network.URI
import SdkVersion
import SdkVersion (SdkVersioned, sdkVersion, withSdkVersions)
import System.Directory
import System.Environment.Blank
import System.FilePath
@ -44,7 +44,7 @@ fullCaps' :: ClientCapabilities
fullCaps' = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }
main :: IO ()
main = do
main = withSdkVersions $ do
setEnv "TASTY_NUM_THREADS" "1" True
damlcPath <- locateRunfiles $
mainWorkspace </> "compiler" </> "damlc" </> exe "damlc"
@ -1043,7 +1043,7 @@ mkKeywordCompletion label =
defaultCompletion label &
kind ?~ CiKeyword
includePathTests :: FilePath -> FilePath -> TestTree
includePathTests :: SdkVersioned => FilePath -> FilePath -> TestTree
includePathTests damlc scriptDarPath = testGroup "include-path"
[ testCase "IDE in root directory" $ withTempDir $ \dir -> do
createDirectory (dir </> "src1")
@ -1089,7 +1089,7 @@ includePathTests damlc scriptDarPath = testGroup "include-path"
expectDiagnostics [ ("src1/Root.daml", [(DsError, (4,0), "Assertion failed")]) ]
]
multiPackageTests :: FilePath -> FilePath -> TestTree
multiPackageTests :: SdkVersioned => FilePath -> FilePath -> TestTree
multiPackageTests damlc scriptDarPath
| isWindows = testGroup "multi-package (skipped)" [] -- see issue #4904
| otherwise = testGroup "multi-package"

6
daml-assistant/BUILD.bazel
View File

@ -24,7 +24,9 @@ da_haskell_library(
],
src_strip_prefix = "daml-project-config",
visibility = ["//visibility:public"],
deps = ["//:sdk-version-hs-lib"],
deps = [
"//libs-haskell/da-version-types",
],
)
da_haskell_library(
@ -98,7 +100,9 @@ da_haskell_binary(
deps = [
":daml-lib",
":daml-project-config",
"//libs-haskell/da-gcp-logger",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-lib",
],
)

5
daml-assistant/daml-helper/BUILD.bazel
View File

@ -49,7 +49,6 @@ da_haskell_library(
src_strip_prefix = "src",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//canton:ledger-api-haskellpb",
"//compiler/daml-lf-ast",
"//compiler/daml-lf-proto",
@ -58,6 +57,7 @@ da_haskell_library(
"//daml-assistant:daml-project-config",
"//language-support/hs/bindings:hs-ledger",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-class-lib",
],
)
@ -84,6 +84,7 @@ da_haskell_binary(
"//language-support/hs/bindings:hs-ledger",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -150,12 +151,12 @@ da_haskell_test(
tags = ["cpu:4"],
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//compiler/daml-lf-ast",
"//compiler/daml-lf-proto",
"//compiler/daml-lf-reader",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-lib",
],
)

7
daml-assistant/daml-helper/src/DA/Daml/Helper/Ledger.hs
View File

@ -80,7 +80,8 @@ import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Time.Calendar (Day(..))
import DA.Ledger.Services.MeteringReportService(MeteringRequestByDay(..))
import qualified Data.Aeson as Aeson
import DA.Daml.Project.Types (unresolvedBuiltinSdkVersion)
import SdkVersion.Class (SdkVersioned, unresolvedBuiltinSdkVersion)
data LedgerApi
= Grpc
@ -279,7 +280,7 @@ runLedgerListParties flags (JsonFlag json) = do
mapM_ print xs
-- | Fetch the packages reachable from a main package-id, and reconstruct a DAR file.
runLedgerFetchDar :: LedgerFlags -> String -> FilePath -> IO ()
runLedgerFetchDar :: SdkVersioned => LedgerFlags -> String -> FilePath -> IO ()
runLedgerFetchDar flags pidString saveAs = do
args <- getDefaultArgs flags
let pid = LF.PackageId $ T.pack pidString
@ -291,7 +292,7 @@ runLedgerFetchDar flags pidString saveAs = do
putStrLn $ "DAR fetch succeeded; contains " <> show n <> " packages."
-- | Reconstruct a DAR file by downloading packages from a ledger. Returns how many packages fetched.
fetchDar :: LedgerArgs -> LF.PackageId -> FilePath -> IO Int
fetchDar :: SdkVersioned => LedgerArgs -> LF.PackageId -> FilePath -> IO Int
fetchDar args rootPid saveAs = do
loggerH <- Logger.newStderrLogger Logger.Info "fetch-dar"
pkgs <- downloadAllReachablePackages (downloadPackage args) [rootPid] []

4
daml-assistant/daml-helper/src/DA/Daml/Helper/Main.hs
View File

@ -30,6 +30,8 @@ import DA.Ledger.Types (ApplicationId(..))
import Data.Text.Lazy (pack)
import Data.Time.Calendar (Day(..))
import SdkVersion (withSdkVersions)
main :: IO ()
main = do
-- Save the runfiles environment to work around
@ -527,7 +529,7 @@ runCommand = \case
PackagesList {..} -> runLedgerListPackages0 flags
LedgerAllocateParties {..} -> runLedgerAllocateParties flags parties
LedgerUploadDar {..} -> runLedgerUploadDar flags darPathM
LedgerFetchDar {..} -> runLedgerFetchDar flags pid saveAs
LedgerFetchDar {..} -> withSdkVersions $ runLedgerFetchDar flags pid saveAs
LedgerReset {..} -> runLedgerReset flags
LedgerExport {..} -> runLedgerExport flags remainingArguments
Codegen {..} -> runCodegen lang remainingArguments

12
daml-assistant/daml-helper/test/DA/Daml/Helper/Test/Deployment.hs
View File

@ -24,7 +24,7 @@ import DA.Daml.LF.Reader (Dalfs(..),readDalfs)
import DA.Test.Process (callProcessSilent)
import DA.Test.Sandbox (mbSharedSecret, withCantonSandbox, defaultSandboxConf, makeSignedJwt)
import DA.Test.Util
import SdkVersion (sdkVersion)
import SdkVersion (SdkVersioned, withSdkVersions, sdkVersion)
import qualified DA.Daml.LF.Ast as LF
import qualified DA.Daml.LF.Proto3.Archive as LFArchive
@ -37,7 +37,7 @@ data Tools = Tools { damlc :: FilePath, damlHelper :: FilePath }
-- compatibility workspace.
main :: IO ()
main = do
main = withSdkVersions $ do
-- We manipulate global state via the working directory
-- so running tests in parallel will cause trouble.
setEnv "TASTY_NUM_THREADS" "1" True
@ -50,7 +50,7 @@ main = do
]
-- | Test `daml ledger list-parties --access-token-file`
authenticationTests :: Tools -> TestTree
authenticationTests :: SdkVersioned => Tools -> TestTree
authenticationTests Tools{..} =
withCantonSandbox defaultSandboxConf { mbSharedSecret = Just sharedSecret } $ \getSandboxPort ->
testGroup "authentication"
@ -102,7 +102,7 @@ authenticationTests Tools{..} =
where
sharedSecret = "TheSharedSecret"
unauthenticatedTests :: Tools -> TestTree
unauthenticatedTests :: SdkVersioned => Tools -> TestTree
unauthenticatedTests tools = do
withCantonSandbox defaultSandboxConf $ \getSandboxPort ->
testGroup "unauthenticated"
@ -129,7 +129,7 @@ timeoutTest Tools{..} getSandboxPort = do
exit @?= ExitFailure 1
-- | Test `daml ledger fetch-dar`
fetchTest :: Tools -> IO Int -> TestTree
fetchTest :: SdkVersioned => Tools -> IO Int -> TestTree
fetchTest Tools{..} getSandboxPort = do
testCaseSteps "fetchTest" $ \step -> do
port <- getSandboxPort
@ -166,7 +166,7 @@ getMainPidOfDar fp = do
return $ T.unpack $ LF.unPackageId pkgId
-- | Write `daml.yaml` and `Main.daml` files in the current directory.
writeMinimalProject :: IO ()
writeMinimalProject :: SdkVersioned => IO ()
writeMinimalProject = do
writeFileUTF8 "daml.yaml" $ unlines
[ "sdk-version: " <> sdkVersion

2
daml-assistant/daml-project-config.cabal
View File

@ -23,6 +23,8 @@ library
aeson,
-- @stackage//:base
base,
-- //libs-haskell/da-version-types:da-version-types
da-version-types,
-- @stackage//:directory
directory,
-- @stackage//:extra

150
daml-assistant/daml-project-config/DA/Daml/Project/Types.hs
View File

@ -4,8 +4,11 @@
module DA.Daml.Project.Types
( module DA.Daml.Project.Types
, module DA.Daml.Version.Types
) where
import DA.Daml.Version.Types
import qualified Data.Yaml as Y
import qualified Data.Text as T
import qualified Data.SemVer as V
@ -15,10 +18,6 @@ import Data.Maybe
import System.FilePath
import Control.Monad
import Control.Exception.Safe
import Data.Either.Extra (eitherToMaybe)
import Data.Function (on)
import qualified SdkVersion
import qualified Control.Exception as Unsafe
data ConfigError
= ConfigFileInvalid Text Y.ParseException
@ -52,149 +51,6 @@ newtype MultiPackageConfig = MultiPackageConfig
{ unwrapMultiPackageConfig :: Y.Value
} deriving (Eq, Show, Y.FromJSON)
newtype UnresolvedReleaseVersion = UnresolvedReleaseVersion
{ unwrapUnresolvedReleaseVersion :: V.Version
} deriving (Eq, Ord, Show)
data ReleaseVersion
= SplitReleaseVersion
{ releaseReleaseVersion :: V.Version
, releaseSdkVersion :: V.Version
}
| OldReleaseVersion
{ bothVersion :: V.Version
}
deriving (Eq, Show)
instance Ord ReleaseVersion where
compare = compare `on` releaseVersionFromReleaseVersion
sdkVersionFromReleaseVersion :: ReleaseVersion -> SdkVersion
sdkVersionFromReleaseVersion (SplitReleaseVersion _ sdkVersion) = SdkVersion sdkVersion
sdkVersionFromReleaseVersion (OldReleaseVersion bothVersion) = SdkVersion bothVersion
releaseVersionFromReleaseVersion :: ReleaseVersion -> V.Version
releaseVersionFromReleaseVersion (SplitReleaseVersion releaseVersion _) = releaseVersion
releaseVersionFromReleaseVersion (OldReleaseVersion bothVersion) = bothVersion
mkReleaseVersion :: UnresolvedReleaseVersion -> SdkVersion -> ReleaseVersion
mkReleaseVersion release sdk =
let unwrappedRelease = unwrapUnresolvedReleaseVersion release
unwrappedSdk = unwrapSdkVersion sdk
in
if unwrappedSdk == unwrappedRelease
then OldReleaseVersion unwrappedSdk
else SplitReleaseVersion unwrappedRelease unwrappedSdk
newtype SdkVersion = SdkVersion
{ unwrapSdkVersion :: V.Version
} deriving (Eq, Ord, Show)
newtype DamlAssistantSdkVersion = DamlAssistantSdkVersion
{ unwrapDamlAssistantSdkVersion :: ReleaseVersion
} deriving (Eq, Ord, Show)
instance Y.FromJSON UnresolvedReleaseVersion where
parseJSON y = do
verE <- V.fromText <$> Y.parseJSON y
case verE of
Left e -> fail ("Invalid release version: " <> e)
Right v -> pure (UnresolvedReleaseVersion v)
instance Y.FromJSON SdkVersion where
parseJSON y = do
verE <- V.fromText <$> Y.parseJSON y
case verE of
Left e -> fail ("Invalid SDK version: " <> e)
Right v -> pure (SdkVersion v)
versionToString :: ReleaseVersion -> String
versionToString (OldReleaseVersion bothVersion) = V.toString bothVersion
versionToString (SplitReleaseVersion releaseVersion _) = V.toString releaseVersion
versionToText :: ReleaseVersion -> Text
versionToText (OldReleaseVersion bothVersion) = V.toText bothVersion
versionToText (SplitReleaseVersion releaseVersion _) = V.toText releaseVersion
rawVersionToTextWithV :: V.Version -> Text
rawVersionToTextWithV v = "v" <> V.toText v
sdkVersionToText :: SdkVersion -> Text
sdkVersionToText = V.toText . unwrapSdkVersion
unresolvedReleaseVersionToString :: UnresolvedReleaseVersion -> String
unresolvedReleaseVersionToString = V.toString . unwrapUnresolvedReleaseVersion
class IsVersion a where
isHeadVersion :: a -> Bool
instance IsVersion ReleaseVersion where
isHeadVersion v = isHeadVersion (releaseVersionFromReleaseVersion v)
instance IsVersion UnresolvedReleaseVersion where
isHeadVersion v = isHeadVersion (unwrapUnresolvedReleaseVersion v)
instance IsVersion SdkVersion where
isHeadVersion v = isHeadVersion (unwrapSdkVersion v)
instance IsVersion V.Version where
isHeadVersion v = V.initial == L.set V.release [] (L.set V.metadata [] v)
headReleaseVersion :: ReleaseVersion
headReleaseVersion = OldReleaseVersion V.initial
data InvalidVersion = InvalidVersion
{ ivSource :: !Text -- ^ invalid version
, ivMessage :: !String -- ^ error message
} deriving (Show, Eq)
instance Exception InvalidVersion where
displayException (InvalidVersion bad msg) =
"Invalid SDK version " <> show bad <> ": " <> msg
parseVersion :: Text -> Either InvalidVersion UnresolvedReleaseVersion
parseVersion = parseUnresolvedVersion
parseUnresolvedVersion :: Text -> Either InvalidVersion UnresolvedReleaseVersion
parseUnresolvedVersion src =
case V.fromText src of
Left msg -> Left (InvalidVersion src msg)
Right v -> Right (UnresolvedReleaseVersion v)
parseSdkVersion :: Text -> Either InvalidVersion SdkVersion
parseSdkVersion src =
case V.fromText src of
Left msg -> Left (InvalidVersion src msg)
Right v -> Right (SdkVersion v)
-- This is unsafe because it converts a version straight into an
-- OldReleaseVersion without checking that release and sdk version are actually
-- the same for this release.
unsafeParseOldReleaseVersion :: Text -> Either InvalidVersion ReleaseVersion
unsafeParseOldReleaseVersion src = do
case V.fromText src of
Left msg -> Left (InvalidVersion src msg)
Right v -> Right (OldReleaseVersion v)
releaseVersionToCacheString :: ReleaseVersion -> String
releaseVersionToCacheString (SplitReleaseVersion release sdk) = V.toString release <> " " <> V.toString sdk
releaseVersionToCacheString (OldReleaseVersion both) = V.toString both
releaseVersionFromCacheString :: String -> Maybe ReleaseVersion
releaseVersionFromCacheString src =
let parseVersionM = eitherToMaybe . V.fromText . pack
in
case words src of
[both] -> OldReleaseVersion <$> parseVersionM both
[release, sdk] -> SplitReleaseVersion <$> parseVersionM release <*> parseVersionM sdk
_ -> Nothing
unresolvedBuiltinSdkVersion :: UnresolvedReleaseVersion
unresolvedBuiltinSdkVersion = either Unsafe.throw id $ parseUnresolvedVersion (T.pack SdkVersion.sdkVersion)
unsafeResolveReleaseVersion :: UnresolvedReleaseVersion -> ReleaseVersion
unsafeResolveReleaseVersion (UnresolvedReleaseVersion v) = OldReleaseVersion v
-- | File path of daml installation root (by default ~/.daml on unix, %APPDATA%/daml on windows).
newtype DamlPath = DamlPath
{ unwrapDamlPath :: FilePath

6
daml-assistant/exe/DA/Daml/Assistant.hs
View File

@ -38,6 +38,8 @@ import qualified Data.Text as T
import Control.Monad.Extra
import Safe
import SdkVersion (SdkVersioned, withSdkVersions)
-- | Run the assistant and exit.
main :: IO ()
-- Note that we do not close on stdin here.
@ -51,7 +53,7 @@ main :: IO ()
-- but as Ben Gamari noticed, this is horribly unreliable
-- https://gitlab.haskell.org/ghc/ghc/issues/17777
-- so we are likely to make things worse rather than better.
main = do
main = withSdkVersions $ do
damlPath <- handleErrors L.makeNopHandle getDamlPath
withLogger damlPath $ \logger -> handleErrors logger $ do
installSignalHandlers
@ -313,7 +315,7 @@ handleErrors logger m = m `catches`
]
exitFailure
withLogger :: DamlPath -> (L.Handle IO -> IO ()) -> IO ()
withLogger :: SdkVersioned => DamlPath -> (L.Handle IO -> IO ()) -> IO ()
withLogger (DamlPath damlPath) k = do
cache <- getCachePath
let cachePath = unwrapCachePath cache

4
daml-assistant/integration-tests/BUILD.bazel
View File

@ -143,13 +143,13 @@ da_haskell_test(
visibility = ["//visibility:public"],
deps = [
":integration-test-utils",
"//:sdk-version-hs-lib",
"//daml-assistant/daml-helper:daml-helper-lib",
"//language-support/hs/bindings:hs-ledger",
"//language-support/ts/codegen/tests:daml2js-test-helpers",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-lib",
],
)
@ -186,13 +186,13 @@ da_haskell_test(
visibility = ["//visibility:public"],
deps = [
":integration-test-utils",
"//:sdk-version-hs-lib",
"//daml-assistant/daml-helper:daml-helper-lib",
"//language-support/hs/bindings:hs-ledger",
"//language-support/ts/codegen/tests:daml2js-test-helpers",
"//libs-haskell/bazel-runfiles",
"//libs-haskell/da-hs-base",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-class-lib",
],
)

14
daml-assistant/integration-tests/src/DA/Daml/Assistant/IntegrationTests.hs
View File

@ -37,10 +37,10 @@ import DA.Test.Daml2jsUtils
import DA.Test.Process (callCommandSilent, callCommandSilentIn, subprocessEnv)
import DA.Test.Util
import DA.PortFile
import SdkVersion
import SdkVersion (SdkVersioned, sdkVersion, withSdkVersions)
main :: IO ()
main = do
main = withSdkVersions $ do
yarn : args <- getArgs
withTempDir $ \tmpDir -> do
oldPath <- getSearchPath
@ -97,7 +97,7 @@ data DamlStartResource = DamlStartResource
, jsonApiPort :: PortNumber
}
damlStart :: FilePath -> IO DamlStartResource
damlStart :: SdkVersioned => FilePath -> IO DamlStartResource
damlStart tmpDir = do
let projDir = tmpDir </> "assistant-integration-tests"
createDirectoryIfMissing True (projDir </> "daml")
@ -176,7 +176,7 @@ damlStart tmpDir = do
, stdoutChan = outChan
}
tests :: FilePath -> TestTree
tests :: SdkVersioned => FilePath -> TestTree
tests tmpDir =
withSdkResource $ \_ ->
testGroup
@ -203,7 +203,7 @@ tests tmpDir =
-- Most of the packaging tests are in the a separate test suite in
-- //compiler/damlc/tests:packaging. This only has a couple of
-- integration tests.
packagingTests :: FilePath -> TestTree
packagingTests :: SdkVersioned => FilePath -> TestTree
packagingTests tmpDir =
testGroup
"packaging"
@ -326,7 +326,7 @@ damlToolTests =
]
-- We are trying to run as many tests with the same `daml start` process as possible to safe time.
damlStartTests :: IO DamlStartResource -> TestTree
damlStartTests :: SdkVersioned => IO DamlStartResource -> TestTree
damlStartTests getDamlStart =
-- We use testCaseSteps to make sure each of these tests runs in sequence, not in parallel.
testCaseSteps "daml start" $ \step -> do
@ -508,7 +508,7 @@ damlStartTests getDamlStart =
copyFile (projDir </> "daml.yaml.back") (projDir </> "daml.yaml")
-- | daml start tests that don't use the shared server
damlStartNotSharedTest :: TestTree
damlStartNotSharedTest :: SdkVersioned => TestTree
damlStartNotSharedTest = testCase "daml start --sandbox-port=0" $
withTempDir $ \tmpDir -> do
writeFileUTF8 (tmpDir </> "daml.yaml") $

55
libs-haskell/da-gcp-logger/BUILD.bazel Normal file
View File

@ -0,0 +1,55 @@
# Copyright (c) 2023 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
# SPDX-License-Identifier: Apache-2.0
load("//bazel_tools:haskell.bzl", "da_haskell_library", "da_haskell_test", "generate_and_track_cabal")
load("@os_info//:os_info.bzl", "is_windows")
da_haskell_library(
name = "da-gcp-logger",
srcs = glob(["src/**/*.hs"]),
hackage_deps = [
"aeson",
"async",
"base",
"bytestring",
"directory",
"extra",
"filepath",
"http-conduit",
"monad-loops",
"random",
"safe-exceptions",
"stm",
"time",
"uuid",
] + ([] if is_windows else ["unix"]),
src_strip_prefix = "src",
visibility = ["//visibility:public"],
deps = [
"//daml-assistant:daml-project-config",
"//libs-haskell/da-hs-base",
"//sdk-version/hs:sdk-version-class-lib",
],
)
da_haskell_test(
name = "da-gcp-logger-telemetry-tests",
srcs = glob(["tests/Telemetry.hs"]),
hackage_deps = [
"aeson",
"extra",
"tasty",
"base",
"directory",
"tasty-hunit",
"text",
],
main_function = "Telemetry.main",
visibility = ["//visibility:public"],
deps = [
":da-gcp-logger",
"//daml-assistant:daml-project-config",
"//libs-haskell/da-hs-base",
"//libs-haskell/test-utils",
],
)

12
libs-haskell/da-hs-base/src/DA/Service/Logger/Impl/GCP.hs → libs-haskell/da-gcp-logger/src/DA/Service/Logger/Impl/GCP.hs
View File

@ -52,7 +52,7 @@ import System.Random
import System.IO.Extra
import qualified DA.Service.Logger as Lgr
import qualified DA.Service.Logger.Impl.Pure as Lgr.Pure
import DA.Daml.Project.Consts
import DA.Daml.Project.Consts (sdkVersionEnvVar)
import qualified Data.Text.Extended as T
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString as BS
@ -65,7 +65,7 @@ import Control.Concurrent.Extra
import Control.Concurrent.STM
import Control.Exception.Safe
import Network.HTTP.Simple
import SdkVersion
import SdkVersion.Class (SdkVersioned, sdkVersion)
-- Type definitions
@ -249,12 +249,12 @@ data MetaData = MetaData
} deriving Generic
instance ToJSON MetaData
logMetaData :: GCPState -> IO ()
logMetaData :: SdkVersioned => GCPState -> IO ()
logMetaData gcpState = do
metadata <- getMetaData gcpState
logGCP gcpState Lgr.Info metadata (pure ())
getMetaData :: GCPState -> IO MetaData
getMetaData :: SdkVersioned => GCPState -> IO MetaData
getMetaData gcp = do
machineID <- fetchMachineID gcp
v <- lookupEnv sdkVersionEnvVar
@ -391,7 +391,7 @@ isOptedOut :: FilePath -> IO Bool
isOptedOut cache = doesPathExist $ cache </> ".opted_out"
-- | If it hasn't already been done log that the user has opted out of telemetry.
logOptOut :: GCPState -> IO ()
logOptOut :: SdkVersioned => GCPState -> IO ()
logOptOut gcp = do
let fpOut = optedOutFile gcp
fpIn = optedInFile gcp
@ -411,7 +411,7 @@ disabledMessage metadata msg =
toJSON $ Aeson.insert "machineID" (toJSON $ machineID metadata) $ toJsonObject (toJSON msg)
-- Log that the user clicked away the telemetry popup without making a choice.
logIgnored :: GCPState -> IO ()
logIgnored :: SdkVersioned => GCPState -> IO ()
logIgnored gcp = do
metadata <- getMetaData gcp
let val = disabledMessage metadata "No telemetry choice"

0
libs-haskell/da-hs-base/tests/Telemetry.hs → libs-haskell/da-gcp-logger/tests/Telemetry.hs
View File

50
libs-haskell/da-hs-base/BUILD.bazel
View File

@ -13,8 +13,6 @@ da_haskell_library(
"ansi-terminal",
"async",
"base",
"base16-bytestring",
"base64-bytestring",
"binary",
"blaze-html",
"bytestring",
@ -22,45 +20,27 @@ da_haskell_library(
"containers",
"deepseq",
"directory",
"dlist",
"extra",
"filepath",
"hashable",
"http-conduit",
"http-types",
"lens",
"monad-loops",
"mtl",
"network",
"optparse-applicative",
"pretty-show",
"pretty",
"process",
"random",
"safe",
"safe-exceptions",
"stm",
"tar-conduit",
"tasty-hunit",
"tasty-quickcheck",
"tasty",
"template-haskell",
"text",
"time",
"transformers-base",
"transformers",
"unordered-containers",
"unix-compat",
"utf8-string",
"uuid",
"vector",
] + ([] if is_windows else ["unix"]),
src_strip_prefix = "src",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//daml-assistant:daml-project-config",
],
)
da_haskell_test(
@ -76,36 +56,8 @@ da_haskell_test(
visibility = ["//visibility:public"],
deps = [
":da-hs-base",
"//daml-assistant:daml-project-config",
"//libs-haskell/test-utils",
],
)
da_haskell_test(
name = "da-hs-base-telemetry-tests",
srcs = glob(["tests/Telemetry.hs"]),
hackage_deps = [
"aeson",
"extra",
"tasty",
"base",
"directory",
"tasty-hunit",
"text",
],
main_function = "Telemetry.main",
visibility = ["//visibility:public"],
deps = [
":da-hs-base",
"//daml-assistant:daml-project-config",
"//libs-haskell/test-utils",
],
)
generate_and_track_cabal(
"da-hs-base",
None,
None,
["daml-project-config"],
["DA.Service.Logger.Impl.GCP"],
)
generate_and_track_cabal("da-hs-base")

32
libs-haskell/da-hs-base/da-hs-base.cabal
View File

@ -29,10 +29,6 @@ library
async,
-- @stackage//:base
base,
-- @stackage//:base16-bytestring
base16-bytestring,
-- @stackage//:base64-bytestring
base64-bytestring,
-- @stackage//:binary
binary,
-- @stackage//:blaze-html
@ -47,70 +43,42 @@ library
deepseq,
-- @stackage//:directory
directory,
-- @stackage//:dlist
dlist,
-- @stackage//:extra
extra,
-- @stackage//:filepath
filepath,
-- @stackage//:hashable
hashable,
-- @stackage//:http-conduit
http-conduit,
-- @stackage//:http-types
http-types,
-- @stackage//:lens
lens,
-- @stackage//:monad-loops
monad-loops,
-- @stackage//:mtl
mtl,
-- @stackage//:network
network,
-- @stackage//:optparse-applicative
optparse-applicative,
-- @stackage//:pretty
pretty,
-- @stackage//:pretty-show
pretty-show,
-- @stackage//:process
process,
-- @stackage//:random
random,
-- @stackage//:safe
safe,
-- @stackage//:safe-exceptions
safe-exceptions,
-- @stackage//:stm
stm,
-- @stackage//:tar-conduit
tar-conduit,
-- @stackage//:tasty
tasty,
-- @stackage//:tasty-hunit
tasty-hunit,
-- @stackage//:tasty-quickcheck
tasty-quickcheck,
-- @stackage//:template-haskell
template-haskell,
-- @stackage//:text
text,
-- @stackage//:time
time,
-- @stackage//:transformers
transformers,
-- @stackage//:transformers-base
transformers-base,
-- @stackage//:unix
unix,
-- @stackage//:unix-compat
unix-compat,
-- @stackage//:unordered-containers
unordered-containers,
-- @stackage//:utf8-string
utf8-string,
-- @stackage//:uuid
uuid,
-- @stackage//:vector
vector,
exposed-modules:

23
libs-haskell/da-version-types/BUILD.bazel Normal file
View File

@ -0,0 +1,23 @@
# Copyright (c) 2023 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
# SPDX-License-Identifier: Apache-2.0
load("//bazel_tools:haskell.bzl", "da_haskell_library", "da_haskell_test", "generate_and_track_cabal")
load("@os_info//:os_info.bzl", "is_windows")
da_haskell_library(
name = "da-version-types",
srcs = glob(["src/**/*.hs"]),
hackage_deps = [
"base",
"extra",
"lens",
"safe-exceptions",
"semver",
"text",
"yaml",
],
src_strip_prefix = "src",
visibility = ["//visibility:public"],
)
generate_and_track_cabal("da-version-types")

57
libs-haskell/da-version-types/da-version-types.cabal Normal file
View File

@ -0,0 +1,57 @@
cabal-version: 2.4
-- This file was autogenerated
name: da-version-types
build-type: Simple
version: 0.1.15.0
synopsis: da-version-types
license: Apache-2.0
author: Digital Asset
maintainer: Digital Asset
copyright: Digital Asset 2023
homepage: https://github.com/digital-asset/daml#readme
bug-reports: https://github.com/digital-asset/daml/issues
source-repository head
type: git
location: https://github.com/digital-asset/daml.git
library
default-language: Haskell2010
hs-source-dirs: src
build-depends:
-- @stackage//:base
base,
-- @stackage//:extra
extra,
-- @stackage//:lens
lens,
-- @stackage//:safe-exceptions
safe-exceptions,
-- @stackage//:semver
semver,
-- @stackage//:text
text,
-- @stackage//:yaml
yaml,
exposed-modules:
DA.Daml.Version.Types
default-extensions:
BangPatterns
DeriveDataTypeable
DeriveFoldable
DeriveFunctor
DeriveGeneric
DeriveTraversable
FlexibleContexts
GeneralizedNewtypeDeriving
LambdaCase
NamedFieldPuns
NumericUnderscores
OverloadedStrings
PackageImports
RecordWildCards
ScopedTypeVariables
StandaloneDeriving
TupleSections
TypeApplications
ViewPatterns

155
libs-haskell/da-version-types/src/DA/Daml/Version/Types.hs Normal file
View File

@ -0,0 +1,155 @@
-- Copyright (c) 2023 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE FlexibleInstances #-}
module DA.Daml.Version.Types
( module DA.Daml.Version.Types
) where
import qualified Data.Yaml as Y
import qualified Data.SemVer as V
import qualified Control.Lens as L
import Data.Text (Text, pack)
import Control.Exception.Safe (Exception (..))
import Data.Either.Extra (eitherToMaybe)
import Data.Function (on)
newtype UnresolvedReleaseVersion = UnresolvedReleaseVersion
{ unwrapUnresolvedReleaseVersion :: V.Version
} deriving (Eq, Ord, Show)
data ReleaseVersion
= SplitReleaseVersion
{ releaseReleaseVersion :: V.Version
, releaseSdkVersion :: V.Version
}
| OldReleaseVersion
{ bothVersion :: V.Version
}
deriving (Eq, Show)
instance Ord ReleaseVersion where
compare = compare `on` releaseVersionFromReleaseVersion
sdkVersionFromReleaseVersion :: ReleaseVersion -> SdkVersion
sdkVersionFromReleaseVersion (SplitReleaseVersion _ sdkVersion) = SdkVersion sdkVersion
sdkVersionFromReleaseVersion (OldReleaseVersion bothVersion) = SdkVersion bothVersion
releaseVersionFromReleaseVersion :: ReleaseVersion -> V.Version
releaseVersionFromReleaseVersion (SplitReleaseVersion releaseVersion _) = releaseVersion
releaseVersionFromReleaseVersion (OldReleaseVersion bothVersion) = bothVersion
mkReleaseVersion :: UnresolvedReleaseVersion -> SdkVersion -> ReleaseVersion
mkReleaseVersion release sdk =
let unwrappedRelease = unwrapUnresolvedReleaseVersion release
unwrappedSdk = unwrapSdkVersion sdk
in
if unwrappedSdk == unwrappedRelease
then OldReleaseVersion unwrappedSdk
else SplitReleaseVersion unwrappedRelease unwrappedSdk
newtype SdkVersion = SdkVersion
{ unwrapSdkVersion :: V.Version
} deriving (Eq, Ord, Show)
newtype DamlAssistantSdkVersion = DamlAssistantSdkVersion
{ unwrapDamlAssistantSdkVersion :: ReleaseVersion
} deriving (Eq, Ord, Show)
instance Y.FromJSON UnresolvedReleaseVersion where
parseJSON y = do
verE <- V.fromText <$> Y.parseJSON y
case verE of
Left e -> fail ("Invalid release version: " <> e)
Right v -> pure (UnresolvedReleaseVersion v)
instance Y.FromJSON SdkVersion where
parseJSON y = do
verE <- V.fromText <$> Y.parseJSON y
case verE of
Left e -> fail ("Invalid SDK version: " <> e)
Right v -> pure (SdkVersion v)
versionToString :: ReleaseVersion -> String
versionToString (OldReleaseVersion bothVersion) = V.toString bothVersion
versionToString (SplitReleaseVersion releaseVersion _) = V.toString releaseVersion
versionToText :: ReleaseVersion -> Text
versionToText (OldReleaseVersion bothVersion) = V.toText bothVersion
versionToText (SplitReleaseVersion releaseVersion _) = V.toText releaseVersion
rawVersionToTextWithV :: V.Version -> Text
rawVersionToTextWithV v = "v" <> V.toText v
sdkVersionToText :: SdkVersion -> Text
sdkVersionToText = V.toText . unwrapSdkVersion
unresolvedReleaseVersionToString :: UnresolvedReleaseVersion -> String
unresolvedReleaseVersionToString = V.toString . unwrapUnresolvedReleaseVersion
class IsVersion a where
isHeadVersion :: a -> Bool
instance IsVersion ReleaseVersion where
isHeadVersion v = isHeadVersion (releaseVersionFromReleaseVersion v)
instance IsVersion UnresolvedReleaseVersion where
isHeadVersion v = isHeadVersion (unwrapUnresolvedReleaseVersion v)
instance IsVersion SdkVersion where
isHeadVersion v = isHeadVersion (unwrapSdkVersion v)
instance IsVersion V.Version where
isHeadVersion v = V.initial == L.set V.release [] (L.set V.metadata [] v)
headReleaseVersion :: ReleaseVersion
headReleaseVersion = OldReleaseVersion V.initial
data InvalidVersion = InvalidVersion
{ ivSource :: !Text -- ^ invalid version
, ivMessage :: !String -- ^ error message
} deriving (Show, Eq)
instance Exception InvalidVersion where
displayException (InvalidVersion bad msg) =
"Invalid SDK version " <> show bad <> ": " <> msg
parseVersion :: Text -> Either InvalidVersion UnresolvedReleaseVersion
parseVersion = parseUnresolvedVersion
parseUnresolvedVersion :: Text -> Either InvalidVersion UnresolvedReleaseVersion
parseUnresolvedVersion src =
case V.fromText src of
Left msg -> Left (InvalidVersion src msg)
Right v -> Right (UnresolvedReleaseVersion v)
parseSdkVersion :: Text -> Either InvalidVersion SdkVersion
parseSdkVersion src =
case V.fromText src of
Left msg -> Left (InvalidVersion src msg)
Right v -> Right (SdkVersion v)
-- This is unsafe because it converts a version straight into an
-- OldReleaseVersion without checking that release and sdk version are actually
-- the same for this release.
unsafeParseOldReleaseVersion :: Text -> Either InvalidVersion ReleaseVersion
unsafeParseOldReleaseVersion src = do
case V.fromText src of
Left msg -> Left (InvalidVersion src msg)
Right v -> Right (OldReleaseVersion v)
releaseVersionToCacheString :: ReleaseVersion -> String
releaseVersionToCacheString (SplitReleaseVersion release sdk) = V.toString release <> " " <> V.toString sdk
releaseVersionToCacheString (OldReleaseVersion both) = V.toString both
releaseVersionFromCacheString :: String -> Maybe ReleaseVersion
releaseVersionFromCacheString src =
let parseVersionM = eitherToMaybe . V.fromText . pack
in
case words src of
[both] -> OldReleaseVersion <$> parseVersionM both
[release, sdk] -> SplitReleaseVersion <$> parseVersionM release <*> parseVersionM sdk
_ -> Nothing
unsafeResolveReleaseVersion :: UnresolvedReleaseVersion -> ReleaseVersion
unsafeResolveReleaseVersion (UnresolvedReleaseVersion v) = OldReleaseVersion v

2
release/BUILD.bazel
View File

@ -59,8 +59,8 @@ da_haskell_binary(
src_strip_prefix = "src",
visibility = ["//visibility:public"],
deps = [
"//:sdk-version-hs-lib",
"//libs-haskell/test-utils",
"//sdk-version/hs:sdk-version-lib",
],
)

3
release/src/Main.hs
View File

@ -93,7 +93,8 @@ main = do
releaseDir <- parseAbsDir =<< liftIO (Dir.makeAbsolute optsReleaseDir)
liftIO $ createDirIfMissing True releaseDir
Right mvnVersion <- pure $ SemVer.fromText $ T.pack SdkVersion.mvnVersion
Right mvnVersion <- pure $ SemVer.fromText $ T.pack $
SdkVersion.withSdkVersions SdkVersion.mvnVersion
bazelLocations <- liftIO getBazelLocations
mvnArtifacts :: [Artifact (Maybe ArtifactLocation)] <- decodeFileThrow "release/artifacts.yaml"

61
sdk-version/hs/BUILD.bazel Normal file
View File

@ -0,0 +1,61 @@
# Copyright (c) 2023 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
# SPDX-License-Identifier: Apache-2.0
load("//bazel_tools:haskell.bzl", "da_haskell_library")
load("@build_environment//:configuration.bzl", "ghc_version", "mvn_version", "sdk_version")
da_haskell_library(
name = "sdk-version-class-lib",
srcs = [":src/SdkVersion/Class.hs"],
hackage_deps = [
"base",
"text",
"ghc-lib-parser",
],
visibility = ["//visibility:public"],
deps = [
"//libs-haskell/da-version-types",
],
)
genrule(
name = "sdk-version-lib-file",
srcs = [],
outs = ["SdkVersion.hs"],
cmd = """
cat > $@ <<EOF
{{-# LANGUAGE RankNTypes #-}}
module SdkVersion
( module SdkVersion.Class
, withSdkVersions
) where
import SdkVersion.Class
withSdkVersions :: (SdkVersioned => r) -> r
withSdkVersions = withSdkVersions' SdkVersions
{{ _sdkVersion = "{sdk}"
, _mvnVersion = "{mvn}"
, _sdkPackageVersion = "{ghc}"
}}
EOF
""".format(
ghc = ghc_version,
mvn = mvn_version,
sdk = sdk_version,
),
)
da_haskell_library(
name = "sdk-version-lib",
srcs = [":sdk-version-lib-file"],
hackage_deps = [
"base",
"ghc-lib-parser",
],
visibility = ["//visibility:public"],
deps = [
":sdk-version-class-lib",
],
)

68
sdk-version/hs/src/SdkVersion/Class.hs Normal file
View File

@ -0,0 +1,68 @@
-- Copyright (c) 2023 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module SdkVersion.Class
( SdkVersioned
, sdkVersion
, mvnVersion
, sdkPackageVersion
, damlStdlib
, SdkVersions (..)
, withSdkVersions'
, unresolvedBuiltinSdkVersion
) where
import Control.Exception (throw)
import DA.Daml.Version.Types (UnresolvedReleaseVersion, parseUnresolvedVersion)
import Module (UnitId, stringToUnitId)
import Unsafe.Coerce (unsafeCoerce)
import qualified Data.Text as T (pack)
data SdkVersions = SdkVersions
{ _sdkVersion :: String
, _mvnVersion :: String
, _sdkPackageVersion :: String
}
class SdkVersioned where
sdkVersions :: SdkVersions
newtype WithSdkVersions r = WithSdkVersions (SdkVersioned => r)
-- | Used to supply custom version values to a function with an `SdkVersioned` constraint.
withSdkVersions' :: forall r. SdkVersions -> (SdkVersioned => r) -> r
withSdkVersions' v k =
-- This mirrors `reflection:Data.Reflection.give`, replacing `Given a` with
-- `SdkVersioned` and `a` with `SdkVersions`.
-- Essentially, we're casting `k`
-- from: `SdkVersioned => r` (through newtype `WithSdkVersions r`)
-- to: `SdkVersions -> r`
-- This works because
-- 1. At runtime, constraint arrows and function arrows have the same representation, and
-- 2. SdkVersioned has a single method, so its dictionary has the same representation as the type of that method.
-- See: https://hackage.haskell.org/package/reflection/docs/Data-Reflection.html#v:give
unsafeCoerce
@(WithSdkVersions r)
@(SdkVersions -> r)
(WithSdkVersions k :: WithSdkVersions r)
v
{-# NOINLINE withSdkVersions' #-}
sdkVersion :: SdkVersioned => String
sdkVersion = _sdkVersion sdkVersions
mvnVersion :: SdkVersioned => String
mvnVersion = _mvnVersion sdkVersions
sdkPackageVersion :: SdkVersioned => String
sdkPackageVersion = _sdkPackageVersion sdkVersions
damlStdlib :: SdkVersioned => UnitId
damlStdlib = stringToUnitId ("daml-stdlib-" ++ sdkPackageVersion)
unresolvedBuiltinSdkVersion :: SdkVersioned => UnresolvedReleaseVersion
unresolvedBuiltinSdkVersion = either throw id $ parseUnresolvedVersion (T.pack sdkVersion)

38
yarn.lock
View File

@ -91,15 +91,17 @@
resolved "https://registry.yarnpkg.com/@protobufjs/utf8/-/utf8-1.1.0.tgz#a777360b5b39a1a2e5106f8e858f2fd2d060c570"
integrity sha512-Vvn3zZrhQZkkBE8LSuW3em98c0FwgO4nxzv6OdSxPKJIEKY2bGbHn+mhGIPerzI4twdxaP8/0+06HBpwf345Lw==
"@types/long@^4.0.0":
"@types/long@^4.0.1":
version "4.0.2"
resolved "https://registry.yarnpkg.com/@types/long/-/long-4.0.2.tgz#b74129719fc8d11c01868010082d483b7545591a"
integrity sha512-MqTGEo5bj5t157U6fA/BiDynNkn0YknVdh48CMPkTSpFTVmvao5UQmm7uEF6xBEo7qIMAlY/JSleYaE6VOdpaA==
"@types/node@^10.1.0":
version "10.17.60"
resolved "https://registry.yarnpkg.com/@types/node/-/node-10.17.60.tgz#35f3d6213daed95da7f0f73e75bcc6980e90597b"
integrity sha512-F0KIgDJfy2nA3zMLmWGKxcH2ZVEtCZXHHdOQs2gSaQ27+lNeEfGxzkIw90aXswATX7AZ33tahPbzy6KAfUreVw==
"@types/node@>=13.7.0":
version "20.10.7"
resolved "https://registry.yarnpkg.com/@types/node/-/node-20.10.7.tgz#40fe8faf25418a75de9fe68a8775546732a3a901"
integrity sha512-fRbIKb8C/Y2lXxB5eVMj4IU7xpdox0Lh8bUPEdtLysaylsml1hOOx1+STloRs/B9nf7C6kPRmmg/V7aQW7usNg==
dependencies:
undici-types "~5.26.4"
JSONStream@^0.10.0:
version "0.10.0"
@ -1312,14 +1314,7 @@ getobject@~1.0.0:
resolved "https://registry.yarnpkg.com/getobject/-/getobject-1.0.2.tgz#25ec87a50370f6dcc3c6ba7ef43c4c16215c4c89"
integrity sha512-2zblDBaFcb3rB4rF77XVnuINOE2h2k/OnqXAiy0IrTxUfV1iFp3la33oAQVY9pCpWU268WFYVt2t71hlMuLsOg==
glob-parent@^6.0.2:
version "6.0.2"
resolved "https://registry.yarnpkg.com/glob-parent/-/glob-parent-6.0.2.tgz#6d237d99083950c79290f24c7642a3de9a28f9e3"
integrity sha512-XxwI8EOhVQgWp6iDL+3b0r86f4d6AX6zSU55HfB4ydCEuXLXc5FcYeOu+nnGftS4TEju/11rt4KJPTMgbfmv4A==
dependencies:
is-glob "^4.0.3"
glob-parent@~5.1.2:
glob-parent@^5.1.2, glob-parent@^6.0.2, glob-parent@~5.1.2:
version "5.1.2"
resolved "https://registry.yarnpkg.com/glob-parent/-/glob-parent-5.1.2.tgz#869832c58034fe68a4093c17dc15e8340d8401c4"
integrity sha512-AOIgSQCepiJYwP3ARnGx+5VnTu2HBYdzbGP45eLw1vr3zB3vZLeyed1sC9hnbcOc9/SrMyM5RPQrkGz4aS9Zow==
@ -2499,10 +2494,10 @@ process@~0.11.0:
resolved "https://registry.yarnpkg.com/process/-/process-0.11.10.tgz#7332300e840161bda3e69a1d1d91a7d4bc16f182"
integrity sha512-cdGef/drWFoydD1JsMzuFf8100nZl+GT+yacc2bEced5f9Rjk4z+WtFUTBu9PhOi9j/jfmBPu0mMEY4wIdAF8A==
protobufjs@6.8.8:
version "6.8.8"
resolved "https://registry.yarnpkg.com/protobufjs/-/protobufjs-6.8.8.tgz#c8b4f1282fd7a90e6f5b109ed11c84af82908e7c"
integrity sha512-AAmHtD5pXgZfi7GMpllpO3q1Xw1OYldr+dMUlAnffGTAhqkg72WdmSY71uKBF/JuyiKs8psYbtKrhi0ASCD8qw==
protobufjs@6.8.8, protobufjs@^6.10.3:
version "6.11.4"
resolved "https://registry.yarnpkg.com/protobufjs/-/protobufjs-6.11.4.tgz#29a412c38bf70d89e537b6d02d904a6f448173aa"
integrity sha512-5kQWPaJHi1WoCpjTGszzQ32PG2F4+wRY6BmAT4Vfw56Q2FZ4YZzK20xUYQH4YkfehY1e6QSICrJquM6xXZNcrw==
dependencies:
"@protobufjs/aspromise" "^1.1.2"
"@protobufjs/base64" "^1.1.2"
@ -2514,8 +2509,8 @@ protobufjs@6.8.8:
"@protobufjs/path" "^1.1.2"
"@protobufjs/pool" "^1.1.0"
"@protobufjs/utf8" "^1.1.0"
"@types/long" "^4.0.0"
"@types/node" "^10.1.0"
"@types/long" "^4.0.1"
"@types/node" ">=13.7.0"
long "^4.0.0"
proxy-addr@~2.0.7:
@ -3162,6 +3157,11 @@ underscore.string@~3.3.5:
sprintf-js "^1.1.1"
util-deprecate "^1.0.2"
undici-types@~5.26.4:
version "5.26.5"
resolved "https://registry.yarnpkg.com/undici-types/-/undici-types-5.26.5.tgz#bcd539893d00b56e964fd2657a4866b221a65617"
integrity sha512-JlCMO+ehdEIKqlFxk6IfVoAUVmgz7cU7zD/h9XZ0qzeosSHmUJVOzSQvvYSYWXkFXC+IfLKSIffhv0sVZup6pA==
unique-stream@^2.3.1:
version "2.3.1"
resolved "https://registry.yarnpkg.com/unique-stream/-/unique-stream-2.3.1.tgz#c65d110e9a4adf9a6c5948b28053d9a8d04cbeac"