mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 13:09:33 -06:00
60 lines
2.2 KiB
Haskell
60 lines
2.2 KiB
Haskell
import Control.Monad ( unless, forM, liftM )
|
|
import System.Exit ( ExitCode(..) )
|
|
import Data.Maybe ( isNothing, fromJust )
|
|
import System.Directory (doesDirectoryExist, getDirectoryContents, doesFileExist)
|
|
import System.FilePath ((</>), takeExtension, replaceExtension)
|
|
|
|
import Test.Framework
|
|
import Test.Framework.TestManager ( makeBlackBoxTest )
|
|
import Test.Framework.TestTypes ( Test )
|
|
import Test.Framework.BlackBoxTest ( defaultDiff )
|
|
import Test.HUnit ( assertFailure )
|
|
|
|
import System.Process ( readProcessWithExitCode )
|
|
|
|
runTest :: FilePath -- ^ name of program under test
|
|
-> [String] -- ^ cli arguments
|
|
-> FilePath -- ^ stdin
|
|
-> Maybe FilePath -- ^ stdout
|
|
-> Maybe FilePath -- ^ stderr
|
|
-> Test
|
|
runTest put args inF outF errF = makeBlackBoxTest testID assertion
|
|
where testID = inF
|
|
assertion =
|
|
do stdin <- readFile inF
|
|
(s,out,err) <- readProcessWithExitCode put args stdin
|
|
unless ( s == ExitSuccess ) $ assertFailure ( "Exit code: " ++ show s )
|
|
outDiff <- defaultDiff outF out
|
|
assertNoDiff outF out
|
|
assertNoDiff errF err
|
|
assertNoDiff file str =
|
|
defaultDiff file str >>= \d ->
|
|
unless ( isNothing d ) ( assertFailure ( fromJust d ) )
|
|
|
|
findFiles :: FilePath -- ^ root dir
|
|
-> IO [FilePath]
|
|
findFiles root = do
|
|
names <- getDirectoryContents root
|
|
let properNames = filter (`notElem` [".", ".."]) names
|
|
paths <- forM properNames $ \name -> do
|
|
let path = root </> name
|
|
isDirectory <- doesDirectoryExist path
|
|
if isDirectory
|
|
then findFiles path
|
|
else return [path]
|
|
return (concat paths)
|
|
|
|
findGfsFiles = liftM ( filter ( hasExtension ".gfs" ) ) . findFiles
|
|
where hasExtension ext = (== ext) . takeExtension
|
|
|
|
runGfsTest :: FilePath -> IO Test
|
|
runGfsTest file = do
|
|
outF <- maybeFile ( replaceExtension file ".out" )
|
|
errF <- maybeFile ( replaceExtension file ".err" )
|
|
return $ runTest "dist/build/gf/gf" ["--run"] file outF errF
|
|
where maybeFile f = do b <- doesFileExist f
|
|
return ( if b then Just f else Nothing )
|
|
|
|
main =
|
|
findGfsFiles "lib/tests" >>= mapM runGfsTest >>= htfMain
|