mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-19 08:48:21 +03:00
Check script output in damlc integration tests (#17380)
* Refactor damlc integration test input into datatype * Factor out 'withLog' helper function * Reduce scope of 'service' in 'testCase' * Use 'testPassed' helper for ignored test files * Reduce scope of 'TestCase' and 'log' in 'testCase' * Use guards instead of nested if-then-else in 'testCase' * Extract 'testSetup' from 'testCase' using 'withResource' * {testCase=>damlFileTestTree} now produces a test tree * Split jq queries into individual tests * whitespace * Add ledger expectation tests * Avoid double inversion-of-control
This commit is contained in:
parent
7d74dc0aa9
commit
84ca088b2c
@ -122,6 +122,7 @@
|
||||
- DA.Daml.Desugar.Tests
|
||||
- DA.Daml.Doc.Tests
|
||||
- DA.Test.DamlRenamer
|
||||
- DA.Test.DamlcIntegration
|
||||
- DA.Signals
|
||||
- Development.IDE.Core.Compile
|
||||
- Development.IDE.GHC.Compat
|
||||
|
@ -109,10 +109,14 @@ da_haskell_test(
|
||||
da_haskell_library(
|
||||
name = "integration-lib",
|
||||
srcs = ["src/DA/Test/DamlcIntegration.hs"],
|
||||
compiler_flags = [
|
||||
"-DPOSIX_DIFF=\"$(POSIX_DIFF)\"",
|
||||
],
|
||||
hackage_deps = [
|
||||
"aeson-pretty",
|
||||
"base",
|
||||
"bytestring",
|
||||
"containers",
|
||||
"data-default",
|
||||
"deepseq",
|
||||
"directory",
|
||||
@ -129,10 +133,15 @@ da_haskell_library(
|
||||
"shake",
|
||||
"tagged",
|
||||
"tasty",
|
||||
"tasty-golden",
|
||||
"tasty-hunit",
|
||||
"text",
|
||||
"time",
|
||||
"unordered-containers",
|
||||
"vector",
|
||||
],
|
||||
toolchains = [
|
||||
"@rules_sh//sh/posix:make_variables",
|
||||
],
|
||||
visibility = ["//visibility:public"],
|
||||
deps = [
|
||||
@ -146,6 +155,7 @@ da_haskell_library(
|
||||
"//compiler/damlc/daml-opts",
|
||||
"//compiler/damlc/daml-opts:daml-opts-types",
|
||||
"//compiler/damlc/daml-package-config",
|
||||
"//compiler/damlc/daml-rule-types",
|
||||
"//compiler/scenario-service/client",
|
||||
"//daml-assistant:daml-project-config",
|
||||
"//daml-lf/archive:daml_lf_dev_archive_haskell_proto",
|
||||
|
@ -0,0 +1,8 @@
|
||||
Script execution failed:
|
||||
Unhandled exception: DA.Exception.GeneralError:GeneralError with
|
||||
message = "ohno"
|
||||
|
||||
Ledger time: 1970-01-01T00:00:00Z
|
||||
|
||||
Trace:
|
||||
hello world
|
@ -0,0 +1,13 @@
|
||||
-- Copyright (c) 2023, Digital Asset (Switzerland) GmbH and/or its affiliates.
|
||||
-- All rights reserved.
|
||||
|
||||
module LedgerTestException where
|
||||
|
||||
import Daml.Script
|
||||
|
||||
-- @ERROR ohno
|
||||
-- @LEDGER test LedgerTestException.EXPECTED.ledger
|
||||
test : Script (Int, Bool)
|
||||
test = do
|
||||
debugRaw "hello world"
|
||||
error "ohno"
|
@ -0,0 +1,22 @@
|
||||
Transactions:
|
||||
TX 0 1970-01-01T00:00:00Z (LedgerTestOk:23:5)
|
||||
#0:0
|
||||
│ referenced by #1:0
|
||||
│ disclosed to (since): 'alice' (0)
|
||||
└─> 'alice' creates LedgerTestOk:T
|
||||
with
|
||||
p = 'alice'
|
||||
|
||||
TX 1 1970-01-01T00:00:00Z (LedgerTestOk:27:5)
|
||||
#1:0
|
||||
│ disclosed to (since): 'alice' (1)
|
||||
└─> 'alice' exercises Noop on #0:0 (LedgerTestOk:T)
|
||||
|
||||
Active contracts: #0:0
|
||||
|
||||
Return value:
|
||||
DA.Types:Tuple2 with
|
||||
_1 = 42; _2 = false
|
||||
|
||||
Trace:
|
||||
hello world
|
29
compiler/damlc/tests/daml-test-files/LedgerTestOk.daml
Normal file
29
compiler/damlc/tests/daml-test-files/LedgerTestOk.daml
Normal file
@ -0,0 +1,29 @@
|
||||
-- Copyright (c) 2023, Digital Asset (Switzerland) GmbH and/or its affiliates.
|
||||
-- All rights reserved.
|
||||
|
||||
module LedgerTestOk where
|
||||
|
||||
import Daml.Script
|
||||
|
||||
template T
|
||||
with
|
||||
p : Party
|
||||
where
|
||||
signatory p
|
||||
nonconsuming choice Noop : ()
|
||||
controller p
|
||||
do pure ()
|
||||
|
||||
-- @LEDGER test LedgerTestOk.EXPECTED.ledger
|
||||
test : Script (Int, Bool)
|
||||
test = do
|
||||
debugRaw "hello world"
|
||||
alice <- allocateParty "alice"
|
||||
cid <-
|
||||
alice `submit`
|
||||
createCmd T with
|
||||
p = alice
|
||||
() <-
|
||||
alice `submit`
|
||||
exerciseCmd cid Noop
|
||||
pure (42, False)
|
@ -1,6 +1,9 @@
|
||||
-- Copyright (c) 2023 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
-- | Test driver for Daml-GHC CompilerService.
|
||||
-- For each file, compile it with GHC, convert it,
|
||||
-- typecheck with LF, test it. Test annotations are documented as 'Ann'.
|
||||
@ -26,6 +29,7 @@ import Control.DeepSeq
|
||||
import Control.Exception.Extra
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import DA.Daml.LF.PrettyScenario (prettyScenarioError, prettyScenarioResult)
|
||||
import DA.Daml.LF.Proto3.EncodeV1
|
||||
import qualified DA.Daml.LF.Proto3.Archive.Encode as Archive
|
||||
import DA.Pretty hiding (first)
|
||||
@ -58,11 +62,16 @@ import System.IO
|
||||
import System.IO.Extra
|
||||
import System.Info.Extra (isWindows)
|
||||
import Text.Read
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import qualified Data.HashSet as HashSet
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import qualified Data.Vector as V
|
||||
import System.Time.Extra
|
||||
import Development.IDE.Core.API
|
||||
import Development.IDE.Core.Rules.Daml
|
||||
import Development.IDE.Core.RuleTypes.Daml (VirtualResource (..))
|
||||
import qualified Development.IDE.Types.Diagnostics as D
|
||||
import Development.IDE.GHC.Util
|
||||
import Data.Tagged (Tagged (..))
|
||||
@ -72,12 +81,12 @@ import Outputable (ppr, showSDoc)
|
||||
import qualified Proto3.Suite.JSONPB as JSONPB
|
||||
|
||||
import Test.Tasty
|
||||
import Test.Tasty.Golden (goldenVsStringDiff)
|
||||
import qualified Test.Tasty.HUnit as HUnit
|
||||
import Test.Tasty.HUnit ((@?=))
|
||||
import Test.Tasty.Options
|
||||
import Test.Tasty.Providers
|
||||
import Test.Tasty.Providers.ConsoleFormat (noResultDetails)
|
||||
import Test.Tasty.Runners (Outcome(..), Result(..))
|
||||
import Test.Tasty.Runners (Result(..))
|
||||
|
||||
import DA.Daml.Package.Config (PackageSdkVersion (..))
|
||||
import DA.Cli.Damlc.DependencyDb (installDependencies)
|
||||
@ -256,29 +265,51 @@ uniqueUniques = HUnit.testCase "Uniques" $
|
||||
let n = length $ nubOrd $ concat results
|
||||
n @?= 10000
|
||||
|
||||
getDamlTestFiles :: FilePath -> IO [(String, FilePath, [Ann])]
|
||||
data DamlTestInput = DamlTestInput
|
||||
{ name :: String
|
||||
, path :: FilePath
|
||||
, anns :: [Ann]
|
||||
}
|
||||
|
||||
getDamlTestFiles :: FilePath -> IO [DamlTestInput]
|
||||
getDamlTestFiles location = do
|
||||
-- test files are declared as data in BUILD.bazel
|
||||
testsLocation <- locateRunfiles $ mainWorkspace </> location
|
||||
files <- filter (".daml" `isExtensionOf`) <$> listFiles testsLocation
|
||||
forM files $ \file -> do
|
||||
anns <- readFileAnns file
|
||||
pure (makeRelative testsLocation file, file, anns)
|
||||
pure DamlTestInput
|
||||
{ name = makeRelative testsLocation file
|
||||
, path = file
|
||||
, anns
|
||||
}
|
||||
|
||||
getBondTradingTestFiles :: IO [(String, FilePath, [Ann])]
|
||||
getBondTradingTestFiles :: IO [DamlTestInput]
|
||||
getBondTradingTestFiles = do
|
||||
-- only run Test.daml (see https://github.com/digital-asset/daml/issues/726)
|
||||
bondTradingLocation <- locateRunfiles $ mainWorkspace </> "compiler/damlc/tests/bond-trading"
|
||||
let file = bondTradingLocation </> "Test.daml"
|
||||
anns <- readFileAnns file
|
||||
pure [("bond-trading/Test.daml", file, anns)]
|
||||
pure
|
||||
[ DamlTestInput
|
||||
{ name = "bond-trading/Test.daml"
|
||||
, path = file
|
||||
, anns
|
||||
}
|
||||
]
|
||||
|
||||
getCantSkipPreprocessorTestFiles :: IO [(String, FilePath, [Ann])]
|
||||
getCantSkipPreprocessorTestFiles :: IO [DamlTestInput]
|
||||
getCantSkipPreprocessorTestFiles = do
|
||||
cantSkipPreprocessorLocation <- locateRunfiles $ mainWorkspace </> "compiler/damlc/tests/cant-skip-preprocessor"
|
||||
let file = cantSkipPreprocessorLocation </> "DA" </> "Internal" </> "Hack.daml"
|
||||
anns <- readFileAnns file
|
||||
pure [("cant-skip-preprocessor/DA/Internal/Hack.daml", file, anns)]
|
||||
pure
|
||||
[ DamlTestInput
|
||||
{ name = "cant-skip-preprocessor/DA/Internal/Hack.daml"
|
||||
, path = file
|
||||
, anns
|
||||
}
|
||||
]
|
||||
|
||||
getIntegrationTests :: (TODO -> IO ()) -> SS.Handle -> ScriptPackageData -> IO TestTree
|
||||
getIntegrationTests registerTODO scenarioService (packageDbPath, packageFlags) = do
|
||||
@ -286,7 +317,7 @@ getIntegrationTests registerTODO scenarioService (packageDbPath, packageFlags) =
|
||||
do n <- getNumCapabilities; putStrLn $ "getNumCapabilities: " ++ show n
|
||||
|
||||
damlTests <-
|
||||
mconcat @(IO [(String, FilePath, [Ann])])
|
||||
mconcat @(IO [DamlTestInput])
|
||||
[ getDamlTestFiles "compiler/damlc/tests/daml-test-files"
|
||||
, getBondTradingTestFiles
|
||||
, getCantSkipPreprocessorTestFiles
|
||||
@ -331,7 +362,7 @@ getIntegrationTests registerTODO scenarioService (packageDbPath, packageFlags) =
|
||||
shutdown
|
||||
$ \service ->
|
||||
testGroup ("Tests for Daml-LF " ++ renderPretty version) $
|
||||
map (testCase version isScriptV2Opt evalOrder service outdir registerTODO) damlTests
|
||||
map (damlFileTestTree version isScriptV2Opt evalOrder service outdir registerTODO) damlTests
|
||||
|
||||
pure tree
|
||||
|
||||
@ -339,43 +370,98 @@ newtype TestCase = TestCase ((String -> IO ()) -> IO Result)
|
||||
|
||||
instance IsTest TestCase where
|
||||
run _ (TestCase r) _ = do
|
||||
logger <- newIORef DList.empty
|
||||
let log msg = modifyIORef logger (`DList.snoc` msg)
|
||||
(res, log) <- withLog \log -> do
|
||||
res <- r log
|
||||
msgs <- readIORef logger
|
||||
let desc
|
||||
| null (resultDescription res) = unlines (DList.toList msgs)
|
||||
| otherwise = unlines (DList.toList (msgs `DList.snoc` resultDescription res))
|
||||
pure $ res { resultDescription = desc }
|
||||
log (resultDescription res)
|
||||
pure res
|
||||
pure res { resultDescription = log }
|
||||
testOptions = Tagged []
|
||||
|
||||
testCase :: LF.Version -> IsScriptV2Opt -> EvaluationOrder -> IO IdeState -> FilePath -> (TODO -> IO ()) -> (String, FilePath, [Ann]) -> TestTree
|
||||
testCase version (IsScriptV2Opt isScriptV2Opt) evalOrderOpt getService outdir registerTODO (name, file, anns) = singleTest name . TestCase $ \log -> do
|
||||
service <- getService
|
||||
if any (`notElem` supportedOutputVersions) [v | UntilLF v <- anns] then
|
||||
pure (testFailed "Unsupported Daml-LF version in UNTIL-LF annotation")
|
||||
else if any (ignoreVersion version) anns
|
||||
then pure $ Result
|
||||
{ resultOutcome = Success
|
||||
, resultDescription = ""
|
||||
, resultShortDescription = "IGNORE"
|
||||
, resultTime = 0
|
||||
, resultDetailsPrinter = noResultDetails
|
||||
-- | 'withLog' takes a function 'f :: (String -> IO ()) -> IO a'
|
||||
-- (that is, a function such that given a logger function ':: String -> IO ()'
|
||||
-- returns (in an IO context) a value of type 'a'), so that 'withLog f' is an
|
||||
-- IO action that performs all the actions of 'f' and returns the
|
||||
-- final value of type 'a' together with the final log.
|
||||
withLog :: ((String -> IO ()) -> IO a) -> IO (a, String)
|
||||
withLog action = do
|
||||
logger <- newIORef DList.empty
|
||||
let log msg = unless (null msg) $ modifyIORef logger (`DList.snoc` msg)
|
||||
r <- action log
|
||||
msgs <- readIORef logger
|
||||
pure (r, unlines (DList.toList msgs))
|
||||
|
||||
data DamlOutput = DamlOutput
|
||||
{ diagnostics :: [D.FileDiagnostic]
|
||||
, jsonPackagePath :: Maybe FilePath
|
||||
, buildLog :: String
|
||||
, scriptResults :: HashMap.HashMap T.Text T.Text
|
||||
}
|
||||
else do
|
||||
|
||||
testSetup :: IO IdeState -> FilePath -> FilePath -> IO DamlOutput
|
||||
testSetup getService outdir path = do
|
||||
service <- getService
|
||||
(ex, buildLog) <- withLog \log ->
|
||||
try @SomeException $ mainProj service outdir log (toNormalizedFilePath' path)
|
||||
diags0 <- getDiagnostics service
|
||||
pure DamlOutput
|
||||
{ diagnostics =
|
||||
[ ideErrorText "" $ T.pack $ show e
|
||||
| Left e <- [ex]
|
||||
, not $ "_IGNORE_" `isInfixOf` show e
|
||||
] ++ diags0
|
||||
, jsonPackagePath = (\(_, x, _) -> x) <$> eitherToMaybe ex
|
||||
, scriptResults = either (const HashMap.empty) (\(_, _, x) -> x) ex
|
||||
, buildLog
|
||||
}
|
||||
|
||||
damlFileTestTree :: LF.Version -> IsScriptV2Opt -> EvaluationOrder -> IO IdeState -> FilePath -> (TODO -> IO ()) -> DamlTestInput -> TestTree
|
||||
damlFileTestTree version (IsScriptV2Opt isScriptV2Opt) evalOrderOpt getService outdir registerTODO input
|
||||
| any (`notElem` supportedOutputVersions) [v | UntilLF v <- anns] =
|
||||
singleTest name $ TestCase \_ ->
|
||||
pure $ testFailed "Unsupported Daml-LF version in UNTIL-LF annotation"
|
||||
| any (ignoreVersion version) anns =
|
||||
singleTest name $ TestCase \_ ->
|
||||
pure (testPassed "") { resultShortDescription = "IGNORE" }
|
||||
| otherwise =
|
||||
withResource
|
||||
(testSetup getService outdir path)
|
||||
(\_ ->
|
||||
-- FIXME: Use of unsafeClearDiagnostics is only because we don't naturally lose them when we change setFilesOfInterest
|
||||
unsafeClearDiagnostics service
|
||||
ex <- try $ mainProj service outdir log (toNormalizedFilePath' file) :: IO (Either SomeException (Package, FilePath))
|
||||
diags <- getDiagnostics service
|
||||
for_ [file ++ ", " ++ x | Todo x <- anns] (registerTODO . TODO)
|
||||
resDiag <- checkDiagnostics log [fields | DiagnosticFields fields <- anns] $
|
||||
[ideErrorText "" $ T.pack $ show e | Left e <- [ex], not $ "_IGNORE_" `isInfixOf` show e] ++ diags
|
||||
resQueries <- runJqQuery log (eitherToMaybe $ snd <$> ex) [(q, isStream) | QueryLF q isStream <- anns]
|
||||
let failures = catMaybes $ resDiag : resQueries
|
||||
case failures of
|
||||
err : _others -> pure $ testFailed err
|
||||
[] -> pure $ testPassed ""
|
||||
getService >>= unsafeClearDiagnostics
|
||||
)
|
||||
\getDamlOutput -> do
|
||||
testGroup name
|
||||
[ singleTest "Build log" $ TestCase \_ -> do
|
||||
for_ [path ++ ", " ++ x | Todo x <- anns] (registerTODO . TODO)
|
||||
testPassed . buildLog <$> getDamlOutput
|
||||
, singleTest "Check diagnostics" $ TestCase \log -> do
|
||||
diags <- diagnostics <$> getDamlOutput
|
||||
resDiag <- checkDiagnostics log [fields | DiagnosticFields fields <- anns] diags
|
||||
pure $ maybe (testPassed "") testFailed resDiag
|
||||
, testGroup "jq Queries"
|
||||
[ singleTest ("#" <> show @Integer ix) $ TestCase \log -> do
|
||||
mJsonFile <- jsonPackagePath <$> getDamlOutput
|
||||
r <- runJqQuery log mJsonFile q isStream
|
||||
pure $ maybe (testPassed "") testFailed r
|
||||
| (ix, QueryLF q isStream) <- zip [1..] anns
|
||||
]
|
||||
, testGroup "Ledger expectation tests"
|
||||
[ goldenVsStringDiff
|
||||
("Script: " <> scriptName <> ", file: " <> expectedFile)
|
||||
diff
|
||||
(takeDirectory path </> expectedFile)
|
||||
do
|
||||
scriptResult <-
|
||||
fromMaybe (error $ "Ledger expectation test failure: the script '" <> scriptName <> "' did not run")
|
||||
. HashMap.lookup (T.pack scriptName)
|
||||
. scriptResults
|
||||
<$> getDamlOutput
|
||||
pure $ BSL.fromStrict $ TE.encodeUtf8 scriptResult
|
||||
| Ledger scriptName expectedFile <- anns
|
||||
]
|
||||
]
|
||||
where
|
||||
DamlTestInput { name, path, anns } = input
|
||||
ignoreVersion version = \case
|
||||
Ignore -> True
|
||||
SinceLF minVersion -> version < minVersion
|
||||
@ -383,12 +469,12 @@ testCase version (IsScriptV2Opt isScriptV2Opt) evalOrderOpt getService outdir re
|
||||
ScriptV2 -> not isScriptV2Opt
|
||||
EvaluationOrder evalOrder -> evalOrder /= evalOrderOpt
|
||||
_ -> False
|
||||
diff ref new = [POSIX_DIFF, "--strip-trailing-cr", ref, new]
|
||||
|
||||
runJqQuery :: (String -> IO ()) -> Maybe FilePath -> [(String, Bool)] -> IO [Maybe String]
|
||||
runJqQuery log mJsonFile qs = do
|
||||
runJqQuery :: (String -> IO ()) -> Maybe FilePath -> String -> Bool -> IO (Maybe String)
|
||||
runJqQuery log mJsonFile q isStream = do
|
||||
case mJsonFile of
|
||||
Just jsonPath ->
|
||||
forM qs $ \(q, isStream) -> do
|
||||
Just jsonPath -> do
|
||||
log $ "running jq query: " ++ q
|
||||
let jqKey = "external" </> "jq_dev_env" </> "bin" </> if isWindows then "jq.exe" else "jq"
|
||||
jq <- locateRunfiles $ mainWorkspace </> jqKey
|
||||
@ -398,10 +484,9 @@ runJqQuery log mJsonFile qs = do
|
||||
case trim out of
|
||||
"true" -> pure Nothing
|
||||
other -> pure $ Just $ "jq query failed: got " ++ other
|
||||
_ | not $ null qs -> do
|
||||
log $ "jq query failed: " ++ show (length qs) ++ " queries failed to run as test errored"
|
||||
pure [Just "Couldn't run jq"]
|
||||
_ -> pure []
|
||||
_ | otherwise -> do
|
||||
log "jq query failed to run as test errored"
|
||||
pure (Just "Couldn't run jq")
|
||||
|
||||
data DiagnosticField
|
||||
= DFilePath !FilePath
|
||||
@ -456,14 +541,25 @@ checkDiagnostics log expected got
|
||||
------------------------------------------------------------
|
||||
-- functionality
|
||||
data Ann
|
||||
= Ignore -- Don't run this test at all
|
||||
| SinceLF LF.Version -- Only run this test since the given Daml-LF version (inclusive)
|
||||
| UntilLF LF.Version -- Only run this test until the given Daml-LF version (exclusive)
|
||||
| DiagnosticFields [DiagnosticField] -- I expect a diagnostic that has the given fields
|
||||
| QueryLF String Bool -- The jq query against the produced Daml-LF returns "true". Includes a boolean for is stream
|
||||
| ScriptV2 -- Run only in daml script V2
|
||||
| Todo String -- Just a note that is printed out
|
||||
= Ignore
|
||||
-- ^ Don't run this test at all
|
||||
| SinceLF LF.Version
|
||||
-- ^ Only run this test since the given Daml-LF version (inclusive)
|
||||
| UntilLF LF.Version
|
||||
-- ^ Only run this test until the given Daml-LF version (exclusive)
|
||||
| DiagnosticFields [DiagnosticField]
|
||||
-- ^ I expect a diagnostic that has the given fields
|
||||
| QueryLF String Bool
|
||||
-- ^ The jq query against the produced Daml-LF returns "true". Includes a boolean for is stream
|
||||
| ScriptV2
|
||||
-- ^ Run only in daml script V2
|
||||
| Todo String
|
||||
-- ^ Just a note that is printed out
|
||||
| Ledger String FilePath
|
||||
-- ^ I expect the output of running the script named <first argument> to match the golden file <second argument>.
|
||||
-- The path of the golden file is relative to the `.daml` test file.
|
||||
| EvaluationOrder EvaluationOrder
|
||||
-- ^ Only run this test with the given evaluation order.
|
||||
|
||||
readFileAnns :: FilePath -> IO [Ann]
|
||||
readFileAnns file = do
|
||||
@ -484,6 +580,7 @@ readFileAnns file = do
|
||||
("QUERY-LF-STREAM", x) -> Just $ QueryLF x True
|
||||
("SCRIPT-V2", _) -> Just ScriptV2
|
||||
("TODO",x) -> Just $ Todo x
|
||||
("LEDGER", words -> [script, path]) -> Just $ Ledger script path
|
||||
("EVALUATION-ORDER", x) -> EvaluationOrder <$> readMaybe x
|
||||
_ -> error $ "Can't understand test annotation in " ++ show file ++ ", got " ++ show x
|
||||
f _ = Nothing
|
||||
@ -519,7 +616,7 @@ parseRange s =
|
||||
(Position (rowEnd - 1) (colEnd - 1))
|
||||
_ -> error $ "Failed to parse range, got " ++ s
|
||||
|
||||
mainProj :: IdeState -> FilePath -> (String -> IO ()) -> NormalizedFilePath -> IO (LF.Package, FilePath)
|
||||
mainProj :: IdeState -> FilePath -> (String -> IO ()) -> NormalizedFilePath -> IO (LF.Package, FilePath, HashMap.HashMap T.Text T.Text)
|
||||
mainProj service outdir log file = do
|
||||
let proj = takeBaseName (fromNormalizedFilePath file)
|
||||
|
||||
@ -542,9 +639,9 @@ mainProj service outdir log file = do
|
||||
corePrettyPrint core
|
||||
lf <- lfTypeCheck log file
|
||||
lfSave lf
|
||||
lfRunScripts log file
|
||||
scriptResults <- lfRunScripts log file
|
||||
jsonSave lf
|
||||
pure (lf, jsonPath)
|
||||
pure (lf, jsonPath, scriptResults)
|
||||
|
||||
unjust :: Action (Maybe b) -> Action b
|
||||
unjust act = do
|
||||
@ -567,8 +664,30 @@ lfConvert log file = timed log "LF convert" $ unjust $ getRawDalf file
|
||||
lfTypeCheck :: (String -> IO ()) -> NormalizedFilePath -> Action LF.Package
|
||||
lfTypeCheck log file = timed log "LF type check" $ unjust $ getDalf file
|
||||
|
||||
lfRunScripts :: (String -> IO ()) -> NormalizedFilePath -> Action ()
|
||||
lfRunScripts log file = timed log "LF scripts execution" $ void $ unjust $ runScripts file
|
||||
lfRunScripts :: (String -> IO ()) -> NormalizedFilePath -> Action (HashMap.HashMap T.Text T.Text)
|
||||
lfRunScripts log file = timed log "LF scripts execution" $ do
|
||||
world <- worldForFile file
|
||||
results <- unjust $ runScripts file
|
||||
pure $ HashMap.fromList
|
||||
[ (vrScenarioName k, format world res)
|
||||
| (k, res) <- results
|
||||
, vrScenarioFile k == file
|
||||
]
|
||||
where
|
||||
format world
|
||||
= renderPlain
|
||||
. ($$ text "") -- add a newline at the end to appease git
|
||||
. \case
|
||||
Right res ->
|
||||
let activeContracts = S.fromList (V.toList (SS.scenarioResultActiveContracts res))
|
||||
in prettyScenarioResult lvl world activeContracts res
|
||||
Left (SS.ScenarioError err) ->
|
||||
prettyScenarioError lvl world err
|
||||
Left e ->
|
||||
shown e
|
||||
lvl =
|
||||
-- hide package ids
|
||||
PrettyLevel (-1)
|
||||
|
||||
timed :: MonadIO m => (String -> IO ()) -> String -> m a -> m a
|
||||
timed log msg act = do
|
||||
|
Loading…
Reference in New Issue
Block a user