diff options
| author | krangelov <kr.angelov@gmail.com> | 2021-07-26 16:52:11 +0200 |
|---|---|---|
| committer | krangelov <kr.angelov@gmail.com> | 2021-07-26 16:52:11 +0200 |
| commit | e47042424ee2450c69c509601ddc3c1cc8cd9a39 (patch) | |
| tree | 5cfad2acca46f8c9aafa3a5f97600ae26bbe0e1c /testsuite/run.hs | |
| parent | ecf309a28e9935923308da4b6aa2b1cc6c4b52e2 (diff) | |
| parent | d0a881f9038d2ca1620e0d95f90c297a452774d5 (diff) | |
Merge branch 'master' of https://github.com/GrammaticalFramework/gf-core
Diffstat (limited to 'testsuite/run.hs')
| -rw-r--r-- | testsuite/run.hs | 119 |
1 files changed, 77 insertions, 42 deletions
diff --git a/testsuite/run.hs b/testsuite/run.hs index 6bf3c8158..f8e6bf49f 100644 --- a/testsuite/run.hs +++ b/testsuite/run.hs @@ -1,44 +1,35 @@ import Data.List(partition) import System.IO import Distribution.Simple.BuildPaths(exeExtension) -import Distribution.System ( buildPlatform ) +import Distribution.System(buildPlatform, OS (Windows), Platform (Platform) ) import System.Process(readProcess) import System.Directory(doesFileExist,getDirectoryContents) import System.FilePath((</>),(<.>),takeExtension) 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" let cnt = length res (good,bad) = partition ((=="OK").fst.snd) res - ok = length good + ok = length good + length (filter ((=="FAIL (expected)").fst.snd) bad) fail = ok<cnt putStrLn $ show ok++"/"++show cnt++ " passed/tests" - let overview = "dist/test/gf-tests.html" + let overview = "gf-tests.html" writeFile overview (toHTML bad) - if ok<cnt + if ok<cnt then do putStrLn $ overview++" contains an overview of the failed tests" exitFailure else exitSuccess - where - 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" - - 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 +-- | 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 + walkFile :: FilePath -> IO [TestResult] walkFile fpath = do exists <- doesFileExist fpath if exists @@ -53,27 +44,71 @@ main = else return [] else walk fpath - runTest in_file out_file gold_file = do - input <- readFile in_file - writeFile out_file =<< run_gf input - exists <- doesFileExist gold_file - if exists - then do out <- compatReadFile out_file - gold <- compatReadFile gold_file - let info = (input,gold,out) - return $! if out == gold then ("OK",info) else ("FAIL",info) - else do out <- compatReadFile out_file - return ("MISSING GOLD",(input,"",out)) - -- Avoid failures caused by Win32/Unix text file incompatibility - compatReadFile path = - do h <- openFile path ReadMode - hSetNewlineMode h universalNewlineMode - hGetContents h +-- | Run an individual test +runTest :: FilePath -> FilePath -> FilePath -> IO RunResult +runTest in_file out_file gold_file = do + input <- readFile in_file + writeFile out_file =<< runGF ["-run"] input + exists <- doesFileExist gold_file + if exists + then do out <- compatReadFile out_file + gold <- compatReadFile gold_file + let info = (input,gold,out) + if in_file `elem` expectedFailures + then return $! if out == gold then ("Unexpected success",info) else ("FAIL (expected)",info) + else return $! if out == gold then ("OK",info) else ("FAIL",info) + else do out <- compatReadFile out_file + return ("MISSING GOLD",(input,"",out)) + +-- | Test scripts which should fail +expectedFailures :: [String] +expectedFailures = + [ "testsuite/runtime/parser/parser.gfs" -- Only parses `z` as `zero` and not also as e.g. `succ zero` as expected + , "testsuite/runtime/linearize/brackets.gfs" -- Missing "cannot linearize in the end" + , "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! -run_gf = readProcess default_gf ["-run","-gf-lib-path="++gf_lib_path] -default_gf = "dist/build/gf/gf"<.>exeExtension buildPlatform -gf_lib_path = "dist/build/rgl" +defaultGF :: FilePath +defaultGF = "gf"<.>exeExtension + where + -- shadows Distribution.Simple.BuildPaths.exeExtension, which changed type signature in Cabal 2.4 + exeExtension = case buildPlatform of + Platform arch Windows -> "exe" + _ -> "" -- | List files, excluding "." and ".." +ls :: FilePath -> IO [String] 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 |