From f5cda1e6a385ec6fe847db1ab77b67535ae41e7d Mon Sep 17 00:00:00 2001 From: hallgren Date: Tue, 3 Dec 2013 17:13:39 +0000 Subject: [PATCH] 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 | 41 ++------------------------ gf.cabal | 6 ++++ testsuite/run.hs | 77 ++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 85 insertions(+), 39 deletions(-) create mode 100644 testsuite/run.hs diff --git a/Setup.hs b/Setup.hs index 87aab235b..8085e50b6 100644 --- a/Setup.hs +++ b/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" diff --git a/gf.cabal b/gf.cabal index 1c5aed4e3..567daea3a 100644 --- a/gf.cabal +++ b/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 diff --git a/testsuite/run.hs b/testsuite/run.hs new file mode 100644 index 000000000..1f671eabf --- /dev/null +++ b/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\n" + ++ "\n" + ++ "\n" + ++ "\n
ResultInputGoldOutput\n" + ++ unlines (map testToHTML res) + ++ "
\n" + + testToHTML (res,(input,gold,output)) = + ""++concatMap (td.pre) [res,input,gold,output] + pre s = "
"++s++"
" + td s = ""++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