msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Superficial refactoring to testsuite module

Browse Source
This commit is contained in:
John J. Camilleri
2021-06-30 12:12:26 +02:00
parent 6efbd23c5c
commit d5c6aec3ec
1 changed files with 63 additions and 41 deletions
Download Patch File Download Diff File Expand all files Collapse all files

104
testsuite/run.hs
View File

@@ -1,13 +1,17 @@
import Data.List(partition) import Data.List(partition)
import System.IO import System.IO
import Distribution.Simple.BuildPaths(exeExtension) import Distribution.Simple.BuildPaths(exeExtension)
import Distribution.System ( buildPlatform, OS (Windows), Platform (Platform) ) import Distribution.System(buildPlatform, OS (Windows), Platform (Platform) )
import System.Process(readProcess) import System.Process(readProcess)
import System.Directory(doesFileExist,getDirectoryContents) import System.Directory(doesFileExist,getDirectoryContents)
import System.FilePath((</>),(<.>),takeExtension) import System.FilePath((</>),(<.>),takeExtension)
import System.Exit(exitSuccess,exitFailure) import System.Exit(exitSuccess,exitFailure)
main = type TestResult = (FilePath, RunResult)
type RunResult = (String, (String, String, String)) -- (message, (input commands, gold output, actual output))
main :: IO ()
main =
do res <- walk "testsuite" do res <- walk "testsuite"
let cnt = length res let cnt = length res
(good,bad) = partition ((=="OK").fst.snd) res (good,bad) = partition ((=="OK").fst.snd) res
@@ -16,29 +20,16 @@ main =
putStrLn $ show ok++"/"++show cnt++ " passed/tests" putStrLn $ show ok++"/"++show cnt++ " passed/tests"
let overview = "gf-tests.html" let overview = "gf-tests.html"
writeFile overview (toHTML bad) writeFile overview (toHTML bad)
if ok<cnt if ok<cnt
then do putStrLn $ overview++" contains an overview of the failed tests" then do putStrLn $ overview++" contains an overview of the failed tests"
exitFailure exitFailure
else exitSuccess else exitSuccess
-- | Recurse through files in path, running a test for all .gfs files
walk :: FilePath -> IO [TestResult]
walk path = fmap concat . mapM (walkFile . (path </>)) =<< ls path
where where
toHTML res = walkFile :: FilePath -> IO [TestResult]
"<!DOCTYPE html>\n"
++ "<meta charset=\"UTF-8\">\n"
++ "<style>\n"
++ "pre { max-width: 600px; overflow: scroll; }\n"
++ "th,td { vertical-align: top; text-align: left; }\n"
++ "</style>\n"
++ "<table border=1>\n<tr><th>Result<th>Input<th>Gold<th>Output\n"
++ unlines (map testToHTML res)
++ "</table>\n"
testToHTML (in_file,(res,(input,gold,output))) =
"<tr>"++concatMap td [pre res,in_file++":\n"++pre input,pre gold,pre output]
pre s = "<pre>"++s++"</pre>"
td s = "<td>"++s
walk path = fmap concat . mapM (walkFile . (path </>)) =<< ls path
walkFile fpath = do walkFile fpath = do
exists <- doesFileExist fpath exists <- doesFileExist fpath
if exists if exists
@@ -53,25 +44,23 @@ main =
else return [] else return []
else walk fpath else walk fpath
runTest in_file out_file gold_file = do -- | Run an individual test
input <- readFile in_file runTest :: FilePath -> FilePath -> FilePath -> IO RunResult
writeFile out_file =<< run_gf ["-run"] input runTest in_file out_file gold_file = do
exists <- doesFileExist gold_file input <- readFile in_file
if exists writeFile out_file =<< runGF ["-run"] input
then do out <- compatReadFile out_file exists <- doesFileExist gold_file
gold <- compatReadFile gold_file if exists
let info = (input,gold,out) then do out <- compatReadFile out_file
if in_file `elem` expectedFailures gold <- compatReadFile gold_file
then return $! if out == gold then ("Unexpected success",info) else ("FAIL (expected)",info) let info = (input,gold,out)
else return $! if out == gold then ("OK",info) else ("FAIL",info) if in_file `elem` expectedFailures
else do out <- compatReadFile out_file then return $! if out == gold then ("Unexpected success",info) else ("FAIL (expected)",info)
return ("MISSING GOLD",(input,"",out)) else return $! if out == gold then ("OK",info) else ("FAIL",info)
-- Avoid failures caused by Win32/Unix text file incompatibility else do out <- compatReadFile out_file
compatReadFile path = return ("MISSING GOLD",(input,"",out))
do h <- openFile path ReadMode
hSetNewlineMode h universalNewlineMode
hGetContents h
-- | Test scripts which should fail
expectedFailures :: [String] expectedFailures :: [String]
expectedFailures = expectedFailures =
[ "testsuite/runtime/parser/parser.gfs" -- Only parses `z` as `zero` and not also as e.g. `succ zero` as expected [ "testsuite/runtime/parser/parser.gfs" -- Only parses `z` as `zero` and not also as e.g. `succ zero` as expected
@@ -79,9 +68,34 @@ expectedFailures =
, "testsuite/compiler/typecheck/abstract/non-abstract-terms.gfs" -- Gives a different error than expected , "testsuite/compiler/typecheck/abstract/non-abstract-terms.gfs" -- Gives a different error than expected
] ]
-- | Produce HTML document with test results
toHTML :: [TestResult] -> String
toHTML res =
"<!DOCTYPE html>\n"
++ "<meta charset=\"UTF-8\">\n"
++ "<style>\n"
++ "pre { max-width: 600px; overflow: scroll; }\n"
++ "th,td { vertical-align: top; text-align: left; }\n"
++ "</style>\n"
++ "<table border=1>\n<tr><th>Result<th>Input<th>Gold<th>Output\n"
++ unlines (map testToHTML res)
++ "</table>\n"
where
testToHTML (in_file,(res,(input,gold,output))) =
"<tr>"++concatMap td [pre res,in_file++":\n"++pre input,pre gold,pre output]
pre s = "<pre>"++s++"</pre>"
td s = "<td>"++s
-- | Run commands in GF shell, returning output
runGF
:: [String] -- ^ command line flags
-> String -- ^ standard input (shell commands)
-> IO String -- ^ standard output
runGF = readProcess defaultGF
-- Should consult the Cabal configuration! -- Should consult the Cabal configuration!
run_gf = readProcess default_gf defaultGF :: FilePath
default_gf = "gf"<.>exeExtension defaultGF = "gf"<.>exeExtension
where where
-- shadows Distribution.Simple.BuildPaths.exeExtension, which changed type signature in Cabal 2.4 -- shadows Distribution.Simple.BuildPaths.exeExtension, which changed type signature in Cabal 2.4
exeExtension = case buildPlatform of exeExtension = case buildPlatform of
@@ -89,4 +103,12 @@ default_gf = "gf"<.>exeExtension
_ -> "" _ -> ""
-- | List files, excluding "." and ".." -- | List files, excluding "." and ".."
ls :: FilePath -> IO [String]
ls path = filter (`notElem` [".",".."]) `fmap` getDirectoryContents path ls path = filter (`notElem` [".",".."]) `fmap` getDirectoryContents path
-- | Avoid failures caused by Win32/Unix text file incompatibility
compatReadFile :: FilePath -> IO String
compatReadFile path =
do h <- openFile path ReadMode
hSetNewlineMode h universalNewlineMode
hGetContents h