futhark-0.26.3: src/Futhark/CLI/Test.hs
{-# LANGUAGE LambdaCase #-}
-- | @futhark test@
module Futhark.CLI.Test (main) where
import Control.Applicative.Lift (Errors, Lift (..), failure, runErrors)
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception
import Control.Monad
import Control.Monad.Except (ExceptT (..), MonadError, runExceptT, withExceptT)
import Control.Monad.Except qualified as E
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import Data.ByteString qualified as SBS
import Data.ByteString.Lazy qualified as LBS
import Data.IORef
import Data.List (delete, partition)
import Data.Map.Strict qualified as M
import Data.Maybe (mapMaybe)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.IO qualified as T
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
import Data.Word (Word64)
import Futhark.Analysis.Metrics.Type
import Futhark.Server
import Futhark.Test
import Futhark.Util (atMostChars, fancyTerminal, randomSeed, showText)
import Futhark.Util.Options
import Futhark.Util.Pretty (annotate, bgColor, bold, hardline, pretty, putDoc, vsep)
import Futhark.Util.Table
import System.Console.ANSI (clearFromCursorToScreenEnd, clearLine, cursorUpLine)
import System.Console.Terminal.Size qualified as Terminal
import System.Environment
import System.Exit
import System.FilePath
import System.IO
import System.Process.ByteString (readProcessWithExitCode)
import Text.Regex.TDFA
--- Test execution
-- The use of [T.Text] here is somewhat kludgy. We use it to track how
-- many errors have occurred during testing of a single program (which
-- may have multiple entry points). This should really not be done at
-- the monadic level - a test failing should be handled explicitly.
type TestM = ExceptT [T.Text] IO
-- Taken from transformers-0.5.5.0.
eitherToErrors :: Either e a -> Errors e a
eitherToErrors = either failure Pure
throwError :: (MonadError [e] m) => e -> m a
throwError e = E.throwError [e]
runTestM :: TestM () -> IO TestResult
runTestM = fmap (either Failure $ const Success) . runExceptT
liftExcept :: ExceptT T.Text IO a -> TestM a
liftExcept = either (E.throwError . pure) pure <=< liftIO . runExceptT
context :: T.Text -> TestM a -> TestM a
context s = withExceptT $
\case
[] -> []
(e : es') -> (s <> ":\n" <> e) : es'
context1 :: (Monad m) => T.Text -> ExceptT T.Text m a -> ExceptT T.Text m a
context1 s = withExceptT $ \e -> s <> ":\n" <> e
accErrors :: [TestM a] -> TestM [a]
accErrors tests = do
eithers <- lift $ mapM runExceptT tests
let errors = traverse eitherToErrors eithers
ExceptT $ pure $ runErrors errors
accErrors_ :: [TestM a] -> TestM ()
accErrors_ = void . accErrors
data TestResult
= Success
| Failure [T.Text]
deriving (Eq, Show)
pureTestResults :: IO [TestResult] -> TestM ()
pureTestResults m = do
errs <- foldr collectErrors mempty <$> liftIO m
unless (null errs) $ E.throwError $ concat errs
where
collectErrors Success errs = errs
collectErrors (Failure err) errs = err : errs
-- | The longest we are willing to wait for a test, in microseconds.
timeout :: Int
timeout = 5 * 60 * 1000000
withProgramServer :: FilePath -> FilePath -> [String] -> IORef PBTPhase -> (Server -> IO [TestResult]) -> TestM ()
withProgramServer program runner extra_options phaseRef f = do
-- Explicitly prefixing the current directory is necessary for
-- readProcessWithExitCode to find the binary when binOutputf has
-- no path component.
let binOutputf = dropExtension program
binpath = "." </> binOutputf
(to_run, to_run_args)
| null runner = (binpath, extra_options)
| otherwise = (runner, binpath : extra_options)
prog_ctx =
"Running " <> T.pack (unwords $ binpath : extra_options)
context prog_ctx . pureTestResults . liftIO $
withServer (futharkServerCfg to_run to_run_args) $ \server ->
race (threadDelay timeout) (f server) >>= \case
Left _ -> do
abortServer server
st <- readIORef phaseRef
fail . T.unpack $
"test timeout after " <> showText timeout <> " microseconds" <> case activeTest st of
Nothing -> mempty
Just activeTestName -> do
-- use annotate to make the phase name stand out in the error message, since it is the most likely place to find out what went wrong
let phaseInfo = maybe mempty (" during phase " <>) (phase st)
shrinkInfo = maybe mempty (" while shrinking with " <>) (shrinkWith st)
sizeInfo = maybe mempty ((" at size=" <>) . showText) (phaseSize st)
seedInfo = maybe mempty ((" and seed=" <>) . showText) (phaseSeed st)
tacticInfo = maybe mempty ((" with tactic=" <>) . showText) (phaseRandom st)
". Was evaluating property:\n"
<> activeTestName
<> phaseInfo
<> shrinkInfo
<> sizeInfo
<> seedInfo
<> tacticInfo
Right r -> pure r
data TestMode
= -- | Only type check.
TypeCheck
| -- | Only compile (do not run).
Compile
| -- | Only internalise (do not run).
Internalise
| -- | Test compiled code.
Compiled
| -- | Test interpreted code.
Interpreted
| -- | Perform structure tests.
Structure
deriving (Eq, Show)
data TestCase = TestCase
{ _testCaseMode :: TestMode,
testCaseProgram :: FilePath,
testCaseTest :: ProgramTest,
_testCasePrograms :: ProgConfig,
pbtConfig :: PBTConfig
}
deriving (Show)
instance Eq TestCase where
x == y = testCaseProgram x == testCaseProgram y
instance Ord TestCase where
x `compare` y = testCaseProgram x `compare` testCaseProgram y
data RunResult m
= ErrorResult T.Text
| SuccessResult (m [Value]) (m ())
progNotFound :: T.Text -> T.Text
progNotFound s = s <> ": command not found"
optimisedProgramMetrics :: ProgConfig -> StructurePipeline -> FilePath -> TestM AstMetrics
optimisedProgramMetrics programs pipeline program =
case pipeline of
SOACSPipeline ->
check ["-s"]
GpuPipeline ->
check ["--gpu"]
MCPipeline ->
check ["--mc"]
SeqMemPipeline ->
check ["--seq-mem"]
GpuMemPipeline ->
check ["--gpu-mem"]
MCMemPipeline ->
check ["--mc-mem"]
NoPipeline ->
check []
where
check opt = do
futhark <- liftIO $ maybe getExecutablePath pure $ configFuthark programs
let opts = ["dev"] ++ opt ++ ["--metrics", program]
(code, output, err) <- liftIO $ readProcessWithExitCode futhark opts ""
let output' = T.decodeUtf8 output
case code of
ExitSuccess
| [(m, [])] <- reads $ T.unpack output' -> pure m
| otherwise -> throwError $ "Could not read metrics output:\n" <> output'
ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark
ExitFailure _ -> throwError $ T.decodeUtf8 err
testMetrics :: ProgConfig -> FilePath -> StructureTest -> TestM ()
testMetrics programs program (StructureTest pipeline (AstMetrics expected)) =
context "Checking metrics" $ do
actual <- optimisedProgramMetrics programs pipeline program
accErrors_ $ map (ok actual) $ M.toList expected
where
maybePipeline :: StructurePipeline -> T.Text
maybePipeline SOACSPipeline = "(soacs) "
maybePipeline GpuPipeline = "(gpu) "
maybePipeline MCPipeline = "(mc) "
maybePipeline SeqMemPipeline = "(seq-mem) "
maybePipeline GpuMemPipeline = "(gpu-mem) "
maybePipeline MCMemPipeline = "(mc-mem) "
maybePipeline NoPipeline = " "
ok (AstMetrics metrics) (name, expected_occurences) =
case M.lookup name metrics of
Nothing
| expected_occurences > 0 ->
throwError $
name
<> maybePipeline pipeline
<> "should have occurred "
<> showText expected_occurences
<> " times, but did not occur at all in optimised program."
Just actual_occurences
| expected_occurences /= actual_occurences ->
throwError $
name
<> maybePipeline pipeline
<> "should have occurred "
<> showText expected_occurences
<> " times, but occurred "
<> showText actual_occurences
<> " times."
_ -> pure ()
testWarnings :: [WarningTest] -> SBS.ByteString -> TestM ()
testWarnings warnings futerr = accErrors_ $ map testWarning warnings
where
testWarning (ExpectedWarning regex_s regex)
| not (match regex $ T.unpack $ T.decodeUtf8 futerr) =
throwError $
"Expected warning:\n "
<> regex_s
<> "\nGot warnings:\n "
<> T.decodeUtf8 futerr
| otherwise = pure ()
runInterpretedEntry :: FutharkExe -> FilePath -> InputOutputs -> TestM ()
runInterpretedEntry (FutharkExe futhark) program (InputOutputs entry run_cases) =
let dir = takeDirectory program
runInterpretedCase run@(TestRun _ inputValues _ index _) =
unless (any (`elem` runTags run) ["compiled", "script"]) $
context ("Entry point: " <> entry <> "; dataset: " <> runDescription run) $ do
input <- T.unlines . map valueText <$> getValues (FutharkExe futhark) dir inputValues
expectedResult' <- getExpectedResult (FutharkExe futhark) program entry run
(code, output, err) <-
liftIO $
readProcessWithExitCode futhark ["run", "-e", T.unpack entry, program] $
T.encodeUtf8 input
case code of
ExitFailure 127 ->
throwError $ progNotFound $ T.pack futhark
_ ->
liftExcept $
compareResult entry index program expectedResult' $
runResult program code output err
in accErrors_ $ map runInterpretedCase run_cases
runTestCase :: TestCase -> TestM ()
runTestCase (TestCase mode program testcase progs pbtConfig) = do
futhark <- liftIO $ maybe getExecutablePath pure $ configFuthark progs
let checkctx =
mconcat
[ "Type-checking with '",
T.pack futhark,
" check ",
T.pack program,
"'"
]
case testAction testcase of
CompileTimeFailure expected_error ->
unless (mode `elem` [Structure, Internalise]) . context checkctx $ do
(code, _, err) <-
liftIO $ readProcessWithExitCode futhark ["check", program] ""
case code of
ExitSuccess -> throwError "Expected failure\n"
ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark
ExitFailure 1 -> throwError $ T.decodeUtf8 err
ExitFailure _ -> liftExcept $ checkError expected_error $ T.decodeUtf8 err
RunCases {}
| mode == TypeCheck -> do
let options = ["check", program] ++ configExtraCompilerOptions progs
context checkctx $ do
(code, _, err) <- liftIO $ readProcessWithExitCode futhark options ""
case code of
ExitSuccess -> pure ()
ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark
ExitFailure _ -> throwError $ T.decodeUtf8 err
| mode == Internalise -> do
let options = ["dev", program] ++ configExtraCompilerOptions progs
context checkctx $ do
(code, _, err) <- liftIO $ readProcessWithExitCode futhark options ""
case code of
ExitSuccess -> pure ()
ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark
ExitFailure _ -> throwError $ T.decodeUtf8 err
RunCases ios structures warnings properties -> do
-- Compile up-front and reuse same executable for several entry points.
let backend = configBackend progs
extra_compiler_options = configExtraCompilerOptions progs
phaseRef <-
liftIO . newIORef $
PBTPhase
{ activeTest = Nothing,
phase = Nothing,
shrinkWith = Nothing,
phaseSize = Nothing,
phaseSeed = Nothing,
phaseRandom = Nothing
}
when (mode `elem` [Compiled, Interpreted]) $
context "Generating reference outputs" $
-- We probably get the concurrency at the test program level,
-- so force just one data set at a time here.
withExceptT pure $
ensureReferenceOutput (Just 1) (FutharkExe futhark) "c" program ios
when (mode == Structure) $
mapM_ (testMetrics progs program) structures
when (mode `elem` [Compile, Compiled]) $
context ("Compiling with --backend=" <> T.pack backend) $ do
compileTestProgram extra_compiler_options (FutharkExe futhark) backend program warnings
unless (mode == Compile) $ do
(tuning_opts, _) <-
liftIO $ determineTuning (configTuning progs) program
let extra_options =
determineCache (configCacheExt progs) program
++ tuning_opts
++ configExtraOptions progs
runner = configRunner progs
context "Running compiled program" $
withProgramServer program runner extra_options phaseRef $ \server -> do
let run = runCompiledEntry (FutharkExe futhark) server program
liftIO (extractPropSpecs server (map propertyEntryPoint properties)) >>= \case
Left err -> pure [Failure [err]]
Right propSpecs -> liftIO $ do
normal_test_result <- concat <$> mapM run ios
let verifiedProps = selectRequestedPropSpecs properties propSpecs
pbt_resultE <- runPBT pbtConfig server verifiedProps phaseRef program
let allResults = flip map pbt_resultE $ \case
Left err -> Failure [err]
Right (Just e) -> Failure [e]
Right Nothing -> Success
let hasFailures = any (\case Failure _ -> True; _ -> False) allResults
when hasFailures $
liftIO $
propToFile program allResults
pure $ normal_test_result ++ allResults
when (mode == Interpreted) $
context "Interpreting" $
accErrors_ $
map (runInterpretedEntry (FutharkExe futhark) program) ios
liftCommand ::
(MonadError T.Text m, MonadIO m) =>
IO (Maybe CmdFailure) ->
m ()
liftCommand m = do
r <- liftIO m
case r of
Just (CmdFailure _ err) -> E.throwError $ T.unlines err
Nothing -> pure ()
runCompiledEntry :: FutharkExe -> Server -> FilePath -> InputOutputs -> IO [TestResult]
runCompiledEntry futhark server program (InputOutputs entry run_cases) = do
input_types <- cmdInputs server entry
output_type <- fmap outputType <$> cmdOutput server entry
case (,) <$> input_types <*> output_type of
Left (CmdFailure _ err) ->
pure [Failure err]
Right (input_types', out_t) -> do
let out = "out"
ins = ["in" <> showText i | i <- [0 .. length input_types' - 1]]
onRes = either (Failure . pure) (const Success)
mapM (fmap onRes . runCompiledCase input_types' (out, out_t) ins) run_cases
where
dir = takeDirectory program
runCompiledCase input_types (out, out_t) ins run = runExceptT $ do
let TestRun _ input_spec _ index _ = run
case_ctx =
"Entry point: "
<> entry
<> "; dataset: "
<> runDescription run
context1 case_ctx $ do
expected <- getExpectedResult futhark program entry run
valuesAsVars server (zip ins (map inputType input_types)) futhark dir input_spec
call_r <- liftIO $ cmdCall server entry out ins
liftCommand $ cmdFree server ins
let res = case call_r of
Left (CmdFailure _ err) ->
ErrorResult $ T.unlines err
Right _ ->
SuccessResult
(readResults server (out, out_t) <* liftCommand (cmdFree server [out]))
(liftCommand (cmdFree server [out]))
compareResult entry index program expected res
checkError :: (MonadError T.Text m) => ExpectedError -> T.Text -> m ()
checkError (ThisError regex_s regex) err
| not (match regex $ T.unpack err) =
E.throwError $
"Expected error:\n "
<> regex_s
<> "\nGot error:\n"
<> T.unlines (map (" " <>) (T.lines err))
checkError _ _ =
pure ()
runResult ::
(MonadIO m, MonadError T.Text m) =>
FilePath ->
ExitCode ->
SBS.ByteString ->
SBS.ByteString ->
RunResult m
runResult program ExitSuccess stdout_s _ =
SuccessResult fetch (pure ())
where
fetch = case valuesFromByteString "stdout" $ LBS.fromStrict stdout_s of
Left e -> do
let actualf = program `addExtension` "actual"
liftIO $ SBS.writeFile actualf stdout_s
E.throwError $ T.pack e <> "\n(See " <> T.pack actualf <> ")"
Right vs -> pure vs
runResult _ (ExitFailure _) _ stderr_s =
ErrorResult $ T.decodeUtf8 stderr_s
compileTestProgram :: [String] -> FutharkExe -> String -> FilePath -> [WarningTest] -> TestM ()
compileTestProgram extra_options futhark backend program warnings = do
(_, futerr) <-
withExceptT pure $
compileProgram ("--server" : extra_options) futhark backend program
testWarnings warnings futerr
compareResult ::
(MonadIO m, MonadError T.Text m) =>
T.Text ->
Int ->
FilePath ->
ExpectedResult [Value] ->
RunResult m ->
m ()
compareResult _ _ _ (Succeeds Nothing) (SuccessResult _ free_vs) =
free_vs
compareResult entry index program (Succeeds (Just expected_vs)) (SuccessResult get_actual_vs _) = do
actual_vs <- get_actual_vs
checkResult
(program <.> T.unpack entry <.> show index)
expected_vs
actual_vs
compareResult _ _ _ (RunTimeFailure expectedError) (ErrorResult actualError) =
checkError expectedError actualError
compareResult _ _ _ (Succeeds _) (ErrorResult err) =
E.throwError $ "Function failed with error:\n" <> err
compareResult _ _ _ (RunTimeFailure f) (SuccessResult _ free_vs) = do
free_vs
E.throwError $ "Program succeeded, but expected failure:\n " <> showText f
---
--- Test manager
---
data TestStatus = TestStatus
{ testStatusRemain :: [TestCase],
testStatusRun :: [TestCase],
testStatusTotal :: Int,
testStatusFail :: Int,
testStatusPass :: Int,
testStatusRuns :: Int,
testStatusRunsRemain :: Int,
testStatusRunPass :: Int,
testStatusRunFail :: Int
}
catching :: IO TestResult -> IO TestResult
catching m = m `catch` save
where
save :: SomeException -> IO TestResult
save e = pure $ Failure [showText e]
doTest :: TestCase -> IO TestResult
doTest = catching . runTestM . runTestCase
makeTestCase :: TestConfig -> TestMode -> (FilePath, ProgramTest) -> TestCase
makeTestCase config mode (file, spec) =
excludeCases config $ TestCase mode file spec (configPrograms config) (configPBTConfig config)
data ReportMsg
= TestStarted TestCase
| TestDone TestCase TestResult
runTest :: MVar TestCase -> MVar ReportMsg -> IO ()
runTest testmvar resmvar = forever $ do
test <- takeMVar testmvar
putMVar resmvar $ TestStarted test
res <- doTest test
putMVar resmvar $ TestDone test res
excludedTest :: TestConfig -> TestCase -> Bool
excludedTest config =
any (`elem` configExclude config) . testTags . testCaseTest
-- | Exclude those test cases that have tags we do not wish to run or
-- exclude based on entry point name.
excludeCases :: TestConfig -> TestCase -> TestCase
excludeCases config tcase =
tcase {testCaseTest = onTest $ testCaseTest tcase}
where
onTest (ProgramTest desc tags action) =
ProgramTest desc tags $ onAction action
onAction (RunCases ios stest wtest properties) =
RunCases (map onIOs $ filter relevantEntry ios) stest wtest properties
onAction action = action
onIOs (InputOutputs entry runs) =
InputOutputs entry $ filter (not . any excluded . runTags) runs
relevantEntry (InputOutputs entry _) =
maybe True (== T.unpack entry) (configEntryPoint config)
excluded = (`elem` configExclude config)
putStatusTable :: TestStatus -> IO ()
putStatusTable ts = hPutTable stdout rows 1
where
rows =
[ [mkEntry "" mempty, passed, failed, mkEntry "remaining" mempty],
map (`mkEntry` mempty) ["programs", passedProgs, failedProgs, remainProgs'],
map (`mkEntry` mempty) ["runs", passedRuns, failedRuns, remainRuns']
]
passed = mkEntry "passed" $ color Green
failed = mkEntry "failed" $ color Red
passedProgs = show $ testStatusPass ts
failedProgs = show $ testStatusFail ts
totalProgs = show $ testStatusTotal ts
totalRuns = show $ testStatusRuns ts
passedRuns = show $ testStatusRunPass ts
failedRuns = show $ testStatusRunFail ts
remainProgs = show . length $ testStatusRemain ts
remainProgs' = remainProgs ++ "/" ++ totalProgs
remainRuns = show $ testStatusRunsRemain ts
remainRuns' = remainRuns ++ "/" ++ totalRuns
tableLines :: Int
tableLines = 8
spaceTable :: IO ()
spaceTable = putStr $ replicate tableLines '\n'
reportTable :: TestStatus -> IO ()
reportTable ts = do
moveCursorToTableTop
putStatusTable ts
clearLine
w <- maybe 80 Terminal.width <$> Terminal.size
T.putStrLn $ atMostChars (w - T.length labelstr) running
where
running = labelstr <> (T.unwords . reverse . map (T.pack . testCaseProgram) . testStatusRun) ts
labelstr = "Now testing: "
reportLine :: MVar SystemTime -> TestStatus -> IO ()
reportLine time_mvar ts =
modifyMVar_ time_mvar $ \time -> do
time_now <- getSystemTime
if systemSeconds time_now - systemSeconds time >= period
then do
T.putStrLn $
showText (testStatusFail ts)
<> " failed, "
<> showText (testStatusPass ts)
<> " passed, "
<> showText num_remain
<> " to go."
pure time_now
else pure time
where
num_remain = length $ testStatusRemain ts
period = 60
moveCursorToTableTop :: IO ()
moveCursorToTableTop = cursorUpLine tableLines
runTests :: TestConfig -> [FilePath] -> IO ()
runTests config paths = do
-- We force line buffering to ensure that we produce running output.
-- Otherwise, CI tools and the like may believe we are hung and kill
-- us.
hSetBuffering stdout LineBuffering
let mode = configTestMode config
all_tests <-
map (makeTestCase config mode)
<$> testSpecsFromPathsOrDie paths
-- putStrLn $ "Test cases are: " ++ show (map testCaseProgram all_tests)
testmvar <- newEmptyMVar
reportmvar <- newEmptyMVar
concurrency <- maybe getNumCapabilities pure $ configConcurrency config
replicateM_ concurrency $ forkIO $ runTest testmvar reportmvar
let (excluded, included) = partition (excludedTest config) all_tests
_ <- forkIO $ mapM_ (putMVar testmvar . excludeCases config) included
time_mvar <- newMVar $ MkSystemTime 0 0
let fancy = not (configLineOutput config) && fancyTerminal
report
| fancy = reportTable
| otherwise = reportLine time_mvar
clear
| fancy = clearFromCursorToScreenEnd
| otherwise = pure ()
numTestCases tc =
case testAction $ testCaseTest tc of
CompileTimeFailure _ -> 1
RunCases ios sts wts pbts ->
length (concatMap iosTestRuns ios)
+ length sts
+ length wts
+ length pbts
getResults ts
| null (testStatusRemain ts) = report ts >> pure ts
| otherwise = do
report ts
msg <- takeMVar reportmvar
case msg of
TestStarted test ->
getResults $ ts {testStatusRun = test : testStatusRun ts}
TestDone test res -> do
let ts' =
ts
{ testStatusRemain = test `delete` testStatusRemain ts,
testStatusRun = test `delete` testStatusRun ts,
testStatusRunsRemain =
testStatusRunsRemain ts - numTestCases test
}
case res of
Success -> do
let ts'' =
ts'
{ testStatusRunPass =
testStatusRunPass ts' + numTestCases test
}
getResults $ ts'' {testStatusPass = testStatusPass ts + 1}
Failure s -> do
when fancy moveCursorToTableTop
clear
putDoc $
annotate (bold <> bgColor Red) (pretty (testCaseProgram test) <> ":")
<> hardline
<> vsep (map pretty s)
<> hardline
when fancy spaceTable
getResults $
ts'
{ testStatusFail = testStatusFail ts' + 1,
testStatusRunPass =
testStatusRunPass ts'
+ max 0 (numTestCases test - length s),
testStatusRunFail =
testStatusRunFail ts'
+ min (numTestCases test) (length s)
}
when fancy spaceTable
ts <-
getResults
TestStatus
{ testStatusRemain = included,
testStatusRun = [],
testStatusTotal = length included,
testStatusFail = 0,
testStatusPass = 0,
testStatusRuns = sum $ map numTestCases included,
testStatusRunsRemain = sum $ map numTestCases included,
testStatusRunPass = 0,
testStatusRunFail = 0
}
-- Removes "Now testing" output.
if fancy
then cursorUpLine 1 >> clearLine
else
putStrLn $
show (testStatusPass ts)
<> "/"
<> show (testStatusTotal ts)
<> " passed."
unless (null excluded) . putStrLn $
show (length excluded) ++ " program(s) excluded."
exitWith $ case testStatusFail ts of
0 -> ExitSuccess
_ -> ExitFailure 1
---
--- Configuration and command line parsing
---
data TestConfig = TestConfig
{ configTestMode :: TestMode,
configPrograms :: ProgConfig,
configExclude :: [T.Text],
configLineOutput :: Bool,
configConcurrency :: Maybe Int,
configEntryPoint :: Maybe String,
configPBTConfig :: PBTConfig
}
defaultConfig :: TestConfig
defaultConfig =
TestConfig
{ configTestMode = Compiled,
configExclude = ["disable", "notest"],
configPrograms =
ProgConfig
{ configBackend = "c",
configFuthark = Nothing,
configRunner = "",
configExtraOptions = [],
configExtraCompilerOptions = [],
configTuning = Just "tuning",
configCacheExt = Nothing
},
configLineOutput = False,
configConcurrency = Nothing,
configEntryPoint = Nothing,
configPBTConfig =
PBTConfig
{ configNumTests = 100,
configMaxSize = 50,
configSeed = randomSeed,
configShrinkTries = 5
}
}
data ProgConfig = ProgConfig
{ configBackend :: String,
configFuthark :: Maybe FilePath,
configRunner :: FilePath,
configExtraCompilerOptions :: [String],
configTuning :: Maybe String,
configCacheExt :: Maybe String,
-- | Extra options passed to the programs being run.
configExtraOptions :: [String]
}
deriving (Show)
changeProgConfig :: (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig
changeProgConfig f config = config {configPrograms = f $ configPrograms config}
changePBTConfig :: (PBTConfig -> PBTConfig) -> TestConfig -> TestConfig
changePBTConfig f config = config {configPBTConfig = f $ configPBTConfig config}
setBackend :: FilePath -> ProgConfig -> ProgConfig
setBackend backend config =
config {configBackend = backend}
setFuthark :: FilePath -> ProgConfig -> ProgConfig
setFuthark futhark config =
config {configFuthark = Just futhark}
setRunner :: FilePath -> ProgConfig -> ProgConfig
setRunner runner config =
config {configRunner = runner}
addCompilerOption :: String -> ProgConfig -> ProgConfig
addCompilerOption option config =
config {configExtraCompilerOptions = configExtraCompilerOptions config ++ [option]}
addOption :: String -> ProgConfig -> ProgConfig
addOption option config =
config {configExtraOptions = configExtraOptions config ++ [option]}
commandLineOptions :: [FunOptDescr TestConfig]
commandLineOptions =
[ Option
"t"
["typecheck"]
(NoArg $ Right $ \config -> config {configTestMode = TypeCheck})
"Only perform type-checking",
Option
"i"
["interpreted"]
(NoArg $ Right $ \config -> config {configTestMode = Interpreted})
"Only interpret",
Option
"c"
["compiled"]
(NoArg $ Right $ \config -> config {configTestMode = Compiled})
"Only run compiled code (the default)",
Option
"C"
["compile"]
(NoArg $ Right $ \config -> config {configTestMode = Compile})
"Only compile, do not run.",
Option
"s"
["structure"]
(NoArg $ Right $ \config -> config {configTestMode = Structure})
"Perform structure tests.",
Option
"I"
["internalise"]
(NoArg $ Right $ \config -> config {configTestMode = Internalise})
"Only run the compiler frontend.",
Option
[]
["no-terminal", "notty"]
(NoArg $ Right $ \config -> config {configLineOutput = True})
"Provide simpler line-based output.",
Option
[]
["backend"]
(ReqArg (Right . changeProgConfig . setBackend) "BACKEND")
"Backend used for compilation (defaults to 'c').",
Option
[]
["futhark"]
(ReqArg (Right . changeProgConfig . setFuthark) "PROGRAM")
"Program to run for subcommands (defaults to same binary as 'futhark test').",
Option
[]
["runner"]
(ReqArg (Right . changeProgConfig . setRunner) "PROGRAM")
"The program used to run the Futhark-generated programs (defaults to nothing).",
Option
[]
["exclude"]
( ReqArg
( \tag ->
Right $ \config ->
config {configExclude = T.pack tag : configExclude config}
)
"TAG"
)
"Exclude test programs that define this tag.",
Option
"p"
["pass-option"]
(ReqArg (Right . changeProgConfig . addOption) "OPT")
"Pass this option to programs being run.",
Option
[]
["pass-compiler-option"]
(ReqArg (Right . changeProgConfig . addCompilerOption) "OPT")
"Pass this option to the compiler (or typechecker if in -t mode).",
Option
[]
["tuning"]
( ReqArg
(\s -> Right $ changeProgConfig $ \config -> config {configTuning = Just s})
"EXTENSION"
)
"Look for tuning files with this extension (defaults to .tuning).",
Option
[]
["no-tuning"]
(NoArg $ Right $ changeProgConfig $ \config -> config {configTuning = Nothing})
"Do not load tuning files.",
Option
[]
["cache-extension"]
( ReqArg
(\s -> Right $ changeProgConfig $ \config -> config {configCacheExt = Just s})
"EXTENSION"
)
"Use cache files with this extension (none by default).",
Option
[]
["concurrency"]
( ReqArg
( \n ->
case reads n of
[(n', "")]
| n' > 0 ->
Right $ \config -> config {configConcurrency = Just n'}
_ ->
Left . optionsError $ "'" ++ n ++ "' is not a positive integer."
)
"NUM"
)
"Number of tests to run concurrently.",
Option
"e"
["entry-point"]
( ReqArg
( \s -> Right $ \config ->
config {configEntryPoint = Just s}
)
"NAME"
)
"Only run entry points with this name.",
Option
"n"
["num-tests"]
( ReqArg
( \n ->
case reads n of
[(n', "")]
| n' >= 0 ->
Right $ changePBTConfig $ \pbt -> pbt {configNumTests = n'}
_ ->
Left . optionsError $ "'" ++ n ++ "' is not a non-negative integer."
)
"NUM"
)
$ "Number of tests to run per property (default: "
<> show (configNumTests . configPBTConfig $ defaultConfig)
<> ").",
Option
"m"
["max-size"]
( ReqArg
( \n ->
case reads n of
[(n', "")]
| n' >= 0 ->
Right $ changePBTConfig $ \pbt -> pbt {configMaxSize = n'}
_ ->
Left . optionsError $ "'" ++ n ++ "' is not a non-negative integer."
)
"NUM"
)
$ "Maximum size parameter to use for generators (default: "
<> show (configMaxSize . configPBTConfig $ defaultConfig)
<> ").",
Option
[]
["seed"]
( ReqArg
( \n ->
case (reads n :: [(Word64, String)]) of
[(n', "")] ->
Right $ changePBTConfig $ \pbt -> pbt {configSeed = n'}
_ ->
Left . optionsError $ "'" ++ n ++ "' is not a valid integer."
)
"NUM"
)
"Set seed for all tests to use for generators.",
Option
[]
["num-tries"]
( ReqArg
( \n ->
case reads n of
[(n', "")]
| n' >= 0 ->
Right $ changePBTConfig $ \pbt -> pbt {configShrinkTries = n'}
_ ->
Left . optionsError $ "'" ++ n ++ "' is not a non-negative integer."
)
"NUM"
)
$ "The number of tries the shrinker will perform before giving up (default: "
<> show (configShrinkTries . configPBTConfig $ defaultConfig)
<> ")."
]
excludeBackend :: TestConfig -> TestConfig
excludeBackend config =
config
{ configExclude =
"no_" <> T.pack (configBackend (configPrograms config))
: configExclude config
}
selectRequestedPropSpecs :: [PropertyCase] -> [PropSpec] -> [PropSpec]
selectRequestedPropSpecs properties specs =
mapMaybe lookupSpec properties
where
lookupSpec (PropertyCase name) =
firstMatching name specs
firstMatching _ [] =
Nothing
firstMatching name (spec : rest)
| psProp spec == name = Just spec
| otherwise = firstMatching name rest
-- Save to file helper functions
propToFile :: FilePath -> [TestResult] -> IO ()
propToFile testFile results = do
let fileName = dropExtension testFile <> ".prop_result"
textResults = T.unlines $ concatMap resultLines results
withFile fileName WriteMode $ \h ->
T.hPutStr h textResults
where
resultLines :: TestResult -> [T.Text]
resultLines Success = []
resultLines (Failure msgs) = msgs
-- | Run @futhark test@.
main :: String -> [String] -> IO ()
main =
mainWithOptions defaultConfig commandLineOptions "options... programs..." $ \progs config ->
case progs of
[] -> Nothing
_ -> Just $ runTests (excludeBackend config) progs