testsuite: Use Cabal's new test suite interface

* The old way: a user hook in Setup.hs
  * The new way: specify it in gf.cabal
  * The test suite is now called gf-tests, and it runs testsuite/run.hs.
  * You can run it manually with 'runhaskell testsuite/run.hs'. It also runs,
    together with rgl-tests, when you do 'cabal test'
  * Currently only 9 of 34 tests pass. Many failures have silly causes:
    - Error messages that look slightly different
    - Same output but in a different order
    - Absolute paths in output

Setup.hs

@@ -8,7 +8,7 @@ import Distribution.PackageDescription hiding (Flag)
 import Control.Monad
 import Data.List(isPrefixOf,intersect)
 import Data.Maybe(listToMaybe)
-import System.IO
+--import System.IO
 import qualified Control.Exception as E
 import System.Cmd
 import System.FilePath
@@ -31,7 +31,7 @@ main = defaultMainWithHooks simpleUserHooks{ preBuild =gfPreBuild
                                            , preCopy  =const . checkRGLArgs
                                            , postCopy =gfPostCopy
                                            , sDistHook=sdistRGL
-                                           , runTests =testRGL
+--                                         , runTests =testRGL
                                            }
   where
     gfPreBuild args  = gfPre args . buildDistPref
@@ -166,43 +166,6 @@ sdistRGL pkg mb_lbi hooks flags = do
                else return paths
         else getRGLFiles path paths
 
-testRGL args _ pkg lbi = do
-  let paths = case args of
-                []    -> ["testsuite"]
-                paths -> paths
-  mapM_ walk paths
-  where
-    walk path = mapM_ (walkFile . (path </>)) =<< ls path
-
-    walkFile fpath = do
-      exists <- doesFileExist fpath
-      if exists
-        then if takeExtension fpath == ".gfs"
-               then do let in_file   = fpath
-                           gold_file = addExtension fpath ".gold"
-                           out_file  = addExtension fpath ".out"
-                       putStr (in_file++" ... ")
-                       hFlush stdout
-                       res <- runTest in_file out_file gold_file
-                       putStrLn res
-               else return ()
-        else walk fpath
-
-    runTest in_file out_file gold_file = do
-      writeFile out_file =<< readProcess (default_gf pkg lbi) ["-run"] =<< readFile in_file
-      exists <- doesFileExist gold_file
-      if exists
-        then do out <- compatReadFile out_file
-                gold <- compatReadFile gold_file
-                return $! if out == gold then "OK" else "FAIL"
-        else return "MISSING GOLD"
-
-    -- Avoid failures caused by Win32/Unix text file incompatibility
-    compatReadFile path =
-      do h <- openFile path ReadMode
-         hSetNewlineMode h universalNewlineMode
-         hGetContents h
-
 rgl_src_dir     = "lib" </> "src"
 rgl_dst_dir lbi = buildDir lbi </> "rgl"
 

gf.cabal

@@ -236,3 +236,9 @@ test-suite rgl-tests
   main-is:        run.hs
   hs-source-dirs: lib/tests/
   build-depends:  base, HTF, process, HUnit, filepath, directory
+
+test-suite gf-tests
+  type:           exitcode-stdio-1.0
+  main-is:        run.hs
+  hs-source-dirs: testsuite
+  build-depends:  base>=4.2 && <5, Cabal>=1.8, directory, filepath, process

testsuite/run.hs

@@ -0,0 +1,77 @@
+import Data.List(partition)
+import System.IO
+import Distribution.Simple.BuildPaths(exeExtension)
+import System.Process(readProcess)
+import System.Directory(doesFileExist,getDirectoryContents)
+import System.FilePath((</>),(<.>),takeExtension)
+import System.Exit(exitSuccess,exitFailure)
+
+main = 
+   do res <- walk "testsuite"
+      let cnt = length res
+          (good,bad) = partition ((=="OK").fst) res
+          ok = length good
+          fail = ok<cnt
+      putStrLn $ show ok++"/"++show cnt++ " passed/tests"
+      let overview = "dist/test/gf-tests.html"
+      writeFile overview (toHTML bad)
+      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: 500px; 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 (res,(input,gold,output)) =
+      "<tr>"++concatMap (td.pre) [res,input,gold,output]
+    pre s = "<pre>"++s++"</pre>"
+    td s = "<td>"++s
+
+    walk path = fmap concat . mapM (walkFile . (path </>)) =<< ls path
+
+    walkFile fpath = do
+      exists <- doesFileExist fpath
+      if exists
+        then if takeExtension fpath == ".gfs"
+               then do let in_file   = fpath
+                           gold_file = fpath <.> ".gold"
+                           out_file  = fpath <.> ".out"
+                       res <- runTest in_file out_file gold_file
+                       putStrLn $ fst res++": "++in_file
+                       return [res]
+               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
+
+-- Should consult the Cabal configuration!
+run_gf = readProcess default_gf ["-run","-gf-lib-path="++gf_lib_path]
+default_gf = "dist/build/gf/gf"<.>exeExtension
+gf_lib_path = "dist/build/rgl"
+
+-- | List files, excluding "." and ".."
+ls path = filter (`notElem` [".",".."]) `fmap` getDirectoryContents path