2024-03-12 21:35:54 +03:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE RecordWildCards #-}
|
2019-09-24 19:09:20 +03:00
|
|
|
|
2021-10-19 03:18:09 +03:00
|
|
|
{- This module kicks off the Transcript Tests.
|
|
|
|
It doesn't do the transcript parsing itself.
|
|
|
|
-}
|
|
|
|
module Main (main) where
|
2019-09-24 19:09:20 +03:00
|
|
|
|
2021-12-07 18:56:49 +03:00
|
|
|
import Data.List
|
2023-05-25 22:02:20 +03:00
|
|
|
import Data.Text qualified as Text
|
|
|
|
import Data.Text.IO qualified as Text
|
2021-12-07 18:56:49 +03:00
|
|
|
import EasyTest
|
|
|
|
import System.Directory
|
2024-03-08 23:46:59 +03:00
|
|
|
import System.Environment (getArgs, getExecutablePath)
|
2021-12-07 18:56:49 +03:00
|
|
|
import System.FilePath
|
2022-02-23 20:00:51 +03:00
|
|
|
( replaceExtension,
|
|
|
|
splitFileName,
|
2024-03-09 21:25:11 +03:00
|
|
|
takeDirectory,
|
2021-12-07 18:56:49 +03:00
|
|
|
takeExtensions,
|
2024-02-16 02:28:52 +03:00
|
|
|
(<.>),
|
2024-03-12 21:35:54 +03:00
|
|
|
(</>),
|
2021-12-07 18:56:49 +03:00
|
|
|
)
|
2022-02-19 09:18:22 +03:00
|
|
|
import System.IO.CodePage (withCP65001)
|
2023-07-05 19:08:27 +03:00
|
|
|
import System.IO.Silently (silence)
|
2024-07-12 01:55:56 +03:00
|
|
|
import Text.Megaparsec qualified as MP
|
2022-02-23 20:00:51 +03:00
|
|
|
import Unison.Codebase.Init (withTemporaryUcmCodebase)
|
2023-05-25 22:02:20 +03:00
|
|
|
import Unison.Codebase.SqliteCodebase qualified as SC
|
2024-07-16 04:32:45 +03:00
|
|
|
import Unison.Codebase.Transcript.Runner as Transcript
|
2023-07-05 18:46:30 +03:00
|
|
|
import Unison.Codebase.Verbosity qualified as Verbosity
|
2021-12-07 18:56:49 +03:00
|
|
|
import Unison.Prelude
|
2023-07-05 19:35:01 +03:00
|
|
|
import UnliftIO.STM qualified as STM
|
2020-03-12 13:09:02 +03:00
|
|
|
|
2021-03-21 18:23:53 +03:00
|
|
|
data TestConfig = TestConfig
|
2024-02-12 18:53:34 +03:00
|
|
|
{ matchPrefix :: Maybe String,
|
|
|
|
runtimePath :: FilePath
|
2021-12-07 18:56:49 +03:00
|
|
|
}
|
|
|
|
deriving (Show)
|
2021-03-21 18:23:53 +03:00
|
|
|
|
2024-02-12 18:53:34 +03:00
|
|
|
type TestBuilder = FilePath -> FilePath -> [String] -> String -> Test ()
|
2019-09-24 19:09:20 +03:00
|
|
|
|
2021-12-07 18:56:49 +03:00
|
|
|
testBuilder ::
|
2024-02-12 18:53:34 +03:00
|
|
|
Bool ->
|
|
|
|
((FilePath, Text) -> IO ()) ->
|
|
|
|
FilePath ->
|
|
|
|
FilePath ->
|
|
|
|
[String] ->
|
|
|
|
String ->
|
|
|
|
Test ()
|
|
|
|
testBuilder expectFailure recordFailure runtimePath dir prelude transcript = scope transcript $ do
|
2023-07-05 18:46:30 +03:00
|
|
|
outputs <- io . withTemporaryUcmCodebase SC.init Verbosity.Silent "transcript" SC.DoLock $ \(codebasePath, codebase) -> do
|
2024-07-10 00:39:09 +03:00
|
|
|
let isTest = True
|
2024-07-12 01:55:56 +03:00
|
|
|
Transcript.withRunner isTest Verbosity.Silent "TODO: pass version here" runtimePath Nothing \runTranscript -> do
|
2023-11-08 01:34:02 +03:00
|
|
|
for files \filePath -> do
|
2022-02-23 20:00:51 +03:00
|
|
|
transcriptSrc <- readUtf8 filePath
|
2023-07-05 19:08:27 +03:00
|
|
|
out <- silence $ runTranscript filePath transcriptSrc (codebasePath, codebase)
|
2022-02-23 20:00:51 +03:00
|
|
|
pure (filePath, out)
|
2023-11-08 01:34:02 +03:00
|
|
|
for_ outputs \case
|
2022-02-23 20:00:51 +03:00
|
|
|
(filePath, Left err) -> do
|
|
|
|
let outputFile = outputFileForTranscript filePath
|
|
|
|
case err of
|
2024-07-12 01:55:56 +03:00
|
|
|
Transcript.ParseError errors -> do
|
2023-07-05 19:35:01 +03:00
|
|
|
when (not expectFailure) $ do
|
2024-07-12 01:55:56 +03:00
|
|
|
let errMsg = "Error parsing " <> filePath <> ": " <> MP.errorBundlePretty errors
|
2023-07-05 19:35:01 +03:00
|
|
|
io $ recordFailure (filePath, Text.pack errMsg)
|
|
|
|
crash errMsg
|
2024-07-12 01:55:56 +03:00
|
|
|
Transcript.RunFailure errOutput -> do
|
2022-02-23 20:00:51 +03:00
|
|
|
io $ writeUtf8 outputFile errOutput
|
2023-07-05 18:46:30 +03:00
|
|
|
when (not expectFailure) $ do
|
|
|
|
io $ Text.putStrLn errOutput
|
2023-07-05 19:35:01 +03:00
|
|
|
io $ recordFailure (filePath, errOutput)
|
2023-07-05 18:46:30 +03:00
|
|
|
crash $ "Failure in " <> filePath
|
2022-02-23 20:00:51 +03:00
|
|
|
(filePath, Right out) -> do
|
|
|
|
let outputFile = outputFileForTranscript filePath
|
|
|
|
io $ writeUtf8 outputFile out
|
2023-07-05 19:35:01 +03:00
|
|
|
when expectFailure $ do
|
|
|
|
let errMsg = "Expected a failure, but transcript was successful."
|
|
|
|
io $ recordFailure (filePath, Text.pack errMsg)
|
|
|
|
crash errMsg
|
2020-10-06 17:59:17 +03:00
|
|
|
ok
|
2021-02-25 11:47:23 +03:00
|
|
|
where
|
2022-02-23 20:00:51 +03:00
|
|
|
files = fmap (dir </>) (prelude ++ [transcript])
|
2020-10-06 17:59:17 +03:00
|
|
|
|
2022-02-23 20:00:51 +03:00
|
|
|
outputFileForTranscript :: FilePath -> FilePath
|
|
|
|
outputFileForTranscript filePath =
|
|
|
|
replaceExtension filePath ".output.md"
|
2020-03-12 13:09:02 +03:00
|
|
|
|
2021-03-21 18:23:53 +03:00
|
|
|
buildTests :: TestConfig -> TestBuilder -> FilePath -> Test ()
|
2024-03-12 21:35:54 +03:00
|
|
|
buildTests TestConfig {..} testBuilder dir = do
|
2020-03-12 13:09:02 +03:00
|
|
|
io
|
2021-12-07 18:56:49 +03:00
|
|
|
. putStrLn
|
|
|
|
. unlines
|
|
|
|
$ [ "",
|
|
|
|
"Searching for transcripts to run in: " ++ dir
|
|
|
|
]
|
2019-10-07 23:29:23 +03:00
|
|
|
files <- io $ listDirectory dir
|
2021-12-07 18:56:49 +03:00
|
|
|
-- Any files that start with _ are treated as prelude
|
|
|
|
let (prelude, transcripts) =
|
|
|
|
files
|
|
|
|
& sort
|
|
|
|
& filter (\f -> takeExtensions f == ".md")
|
|
|
|
& partition ((isPrefixOf "_") . snd . splitFileName)
|
|
|
|
-- if there is a matchPrefix set, filter non-prelude files by that prefix - or return True
|
2024-02-12 18:53:34 +03:00
|
|
|
& second (filter (\f -> maybe True (`isPrefixOf` f) matchPrefix))
|
2021-02-25 11:47:23 +03:00
|
|
|
|
2021-03-21 20:06:23 +03:00
|
|
|
case length transcripts of
|
2021-12-07 18:56:49 +03:00
|
|
|
0 -> pure ()
|
|
|
|
-- EasyTest exits early with "no test results recorded"
|
|
|
|
-- if you don't give it any tests, this keeps it going
|
|
|
|
-- till the end so we can search all transcripts for
|
|
|
|
-- prefix matches.
|
2024-02-12 18:53:34 +03:00
|
|
|
_ -> tests (testBuilder runtimePath dir prelude <$> transcripts)
|
2020-01-25 11:12:25 +03:00
|
|
|
|
2020-03-12 13:09:02 +03:00
|
|
|
-- Transcripts that exit successfully get cleaned-up by the transcript parser.
|
|
|
|
-- Any remaining folders matching "transcript-.*" are output directories
|
|
|
|
-- of failed transcripts and should be moved under the "test-output" folder
|
|
|
|
cleanup :: Test ()
|
|
|
|
cleanup = do
|
2019-09-24 19:09:20 +03:00
|
|
|
files' <- io $ listDirectory "."
|
2020-01-25 11:12:25 +03:00
|
|
|
let dirs = filter ("transcript-" `isPrefixOf`) files'
|
|
|
|
|
|
|
|
-- if any such codebases remain they are moved under test-output
|
|
|
|
unless (null dirs) $ do
|
|
|
|
io $ createDirectoryIfMissing True "test-output"
|
|
|
|
io $ for_ dirs (\d -> renameDirectory d ("test-output" </> d))
|
|
|
|
io
|
|
|
|
. putStrLn
|
|
|
|
. unlines
|
2021-12-07 18:56:49 +03:00
|
|
|
$ [ "",
|
|
|
|
"NOTE: All transcript codebases have been moved into",
|
|
|
|
"the `test-output` directory. Feel free to delete it."
|
2020-01-25 11:12:25 +03:00
|
|
|
]
|
2019-09-24 19:09:20 +03:00
|
|
|
|
2021-03-21 18:23:53 +03:00
|
|
|
test :: TestConfig -> Test ()
|
|
|
|
test config = do
|
2023-07-05 19:35:01 +03:00
|
|
|
-- We manually aggregate and display failures at the end to it much easier to see
|
|
|
|
-- what went wrong in CI
|
|
|
|
failuresVar <- io $ STM.newTVarIO []
|
|
|
|
let recordFailure failure = STM.atomically $ STM.modifyTVar' failuresVar (failure :)
|
|
|
|
buildTests config (testBuilder False recordFailure) $
|
2021-12-07 18:56:49 +03:00
|
|
|
"unison-src" </> "transcripts"
|
2023-07-05 19:35:01 +03:00
|
|
|
buildTests config (testBuilder False recordFailure) $
|
2021-12-07 18:56:49 +03:00
|
|
|
"unison-src" </> "transcripts-using-base"
|
2023-07-05 19:35:01 +03:00
|
|
|
buildTests config (testBuilder True recordFailure) $
|
2021-12-07 18:56:49 +03:00
|
|
|
"unison-src" </> "transcripts" </> "errors"
|
2023-07-05 19:35:01 +03:00
|
|
|
failures <- io $ STM.readTVarIO failuresVar
|
|
|
|
-- Print all aggregated failures
|
|
|
|
when (not $ null failures) . io $ Text.putStrLn $ "Failures:"
|
|
|
|
for failures $ \(filepath, msg) -> io $ do
|
|
|
|
Text.putStrLn $ Text.replicate 80 "="
|
|
|
|
Text.putStrLn $ "🚨 " <> Text.pack filepath <> ": "
|
|
|
|
Text.putStrLn msg
|
2020-03-12 13:09:02 +03:00
|
|
|
cleanup
|
|
|
|
|
2024-02-12 18:53:34 +03:00
|
|
|
handleArgs :: TestConfig -> [String] -> TestConfig
|
2024-03-12 21:35:54 +03:00
|
|
|
handleArgs acc ("--runtime-path" : p : rest) =
|
|
|
|
handleArgs (acc {runtimePath = p}) rest
|
|
|
|
handleArgs acc [prefix] = acc {matchPrefix = Just prefix}
|
2024-02-12 18:53:34 +03:00
|
|
|
handleArgs acc _ = acc
|
|
|
|
|
|
|
|
defaultConfig :: IO TestConfig
|
2024-02-16 02:28:52 +03:00
|
|
|
defaultConfig = TestConfig Nothing <$> defaultRTP
|
|
|
|
where
|
|
|
|
defaultRTP = do
|
2024-03-08 23:46:59 +03:00
|
|
|
ucm <- getExecutablePath
|
2024-03-09 21:17:07 +03:00
|
|
|
pure (takeDirectory ucm </> "runtime" </> "unison-runtime" <.> exeExtension)
|
2021-03-21 18:23:53 +03:00
|
|
|
|
2019-09-24 19:09:20 +03:00
|
|
|
main :: IO ()
|
2022-02-19 09:18:22 +03:00
|
|
|
main = withCP65001 do
|
2024-02-12 18:53:34 +03:00
|
|
|
dcfg <- defaultConfig
|
|
|
|
testConfig <- handleArgs dcfg <$> getArgs
|
2021-03-21 18:23:53 +03:00
|
|
|
run (test testConfig)
|