Superficial refactoring to testsuite module

2026-04-09 04:59:31 -06:00 · 2021-06-30 12:12:26 +02:00
parent 6efbd23c5c
commit d5c6aec3ec
1 changed files with 63 additions and 41 deletions
--- a/testsuite/run.hs
+++ b/testsuite/run.hs
@@ -1,13 +1,17 @@
 import Data.List(partition)
 import System.IO
 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.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
@@ -16,29 +20,16 @@ main =
      putStrLn $ show ok++"/"++show cnt++ " passed/tests"
      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
+
+-- | 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
-    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
-
+    walkFile :: FilePath -> IO [TestResult]
    walkFile fpath = do
      exists <- doesFileExist fpath
      if exists
@@ -53,25 +44,23 @@ main =
               else return []
        else walk fpath

-    runTest in_file out_file gold_file = do
-      input <- readFile in_file
-      writeFile out_file =<< run_gf ["-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))
-    -- 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
@@ -79,9 +68,34 @@ expectedFailures =
  , "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 
-default_gf = "gf"<.>exeExtension
+defaultGF :: FilePath
+defaultGF = "gf"<.>exeExtension
  where
    -- shadows Distribution.Simple.BuildPaths.exeExtension, which changed type signature in Cabal 2.4
    exeExtension = case buildPlatform of
@@ -89,4 +103,12 @@ default_gf = "gf"<.>exeExtension
      _ -> ""

 -- | 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