1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
|
module Main where
import Data.List (intercalate)
import System.Exit (ExitCode(..), exitFailure, exitSuccess, exitWith)
import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, setCurrentDirectory,
getDirectoryContents)
import System.FilePath ((</>))
import System.Process (readProcessWithExitCode, callProcess)
import System.IO (hPutStrLn, hPrint, stderr)
import Control.Monad (filterM, liftM, when)
testDirs :: [String]
testDirs = ["test/harness","harness","."]
getActualTestDirectory :: [String] -> IO FilePath
getActualTestDirectory test_dirs = do
validDirs <- filterM (doesFileExist . (</> "run-harness.hs")) test_dirs
case validDirs of
[] -> ioError (userError ("run-harness.hs not found in " ++ intercalate " or " test_dirs))
(d:_) -> return d
subdirectoriesOf :: FilePath -> IO [FilePath]
subdirectoriesOf fp = do
entries <- getDirectoryContents fp
filterM (doesDirectoryExist . (fp </>)) (filter (not . isSpecialDir) entries)
where
isSpecialDir "." = True
isSpecialDir ".." = True
isSpecialDir _ = False
-- from Control.Monad.Extra
findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
findM _ [] = return Nothing
findM p (x:xs) = do guard <- p x ; if guard then (return $ Just x) else (findM p xs)
main :: IO ExitCode
main = do
actual_test_dir <- getActualTestDirectory testDirs
has_makefile <- doesFileExist (actual_test_dir </> "Makefile")
when (not has_makefile) $ do
hPutStrLn stderr "No Makefile found (out of source tree)"
hPutStrLn stderr "Skipping harness test"
exitWith ExitSuccess
tests <- subdirectoriesOf actual_test_dir
cdir <- getCurrentDirectory
hPutStrLn stderr ("Changing to test directory " ++ actual_test_dir ++ " and compiling")
-- build test executables
setCurrentDirectory (cdir</>actual_test_dir)
callProcess "make" ["prepare"]
-- run harness tests
hasFailure <- findM (liftM (/= ExitSuccess) . runTest . (cdir</>) . (actual_test_dir</>)) tests
setCurrentDirectory cdir
case hasFailure of
Nothing -> exitSuccess
Just _failed -> exitFailure
where
runTest :: FilePath -> IO ExitCode
runTest dir = do
setCurrentDirectory dir
(exitCode, _outp, _errp) <- readProcessWithExitCode "make" [] ""
hPutStrLn stderr ("cd " ++ dir ++ " && make: " ++ show exitCode)
when (exitCode /= ExitSuccess) $ do
hPutStrLn stderr "=== Standard Output ==="
hPutStrLn stderr _outp
hPutStrLn stderr "=== Error Output ==="
hPutStrLn stderr _errp
hPutStrLn stderr "=== End of Output ==="
return exitCode
|
