--- ---------------------------------------------------------------------------- --- This program runs some test cases for the partial evaluator --- using the different semantics and abstractions available. --- --- The result of partial evaluation (specialized program) is compared to the --- expected file `.spec` for equality. Since abstraction based on --- a well-founded ordering (wfo) or well-quasi ordering (wqo) may lead --- to different results, in those cases there also exist files `.wfo` --- and `.wqo`. Furthermore, some examples may not terminate without --- abstraction, indicated by an empty `.timeout` file. --- --- In addition to the comparison of the computed and expected specialization, --- both the original and specialized program can be executed (i.e, the --- function `main` is evaluated) and the exit codes and computed results --- are then compared for equality. --- --- @author Björn Peemöller --- @version September 2015 --- ---------------------------------------------------------------------------- module TestDriver where import AnsiCodes (green, magenta, red, yellow) import Char (toLower, toUpper) import Directory (getDirectoryContents, doesDirectoryExist, doesFileExist) import FilePath ( FilePath, (), (<.>), dropExtension, takeBaseName , takeDirectory, takeExtension ) import IO (hFlush, hIsTerminalDevice, hPutStrLn, stderr, stdout) import IOExts (evalCmd) import List (intercalate, last, maximum, nub, sortBy) import Read (readInt) import System (exitWith, getArgs, getProgName) import GetOpt2 ( OptDescr (..), ArgDescr (..), ArgOrder (Permute), OptErr , OptTable, getOpt, onOpts, option, usageInfo ) import Utils ((+\+), count, countBy, indentStr, lpad, rpad) import Configuration -- ----------------------------------------------------------------------------- -- Main -- ----------------------------------------------------------------------------- main :: IO () main = do opts <- getOpts tests <- getTestPrograms opts runTests opts tests -- ----------------------------------------------------------------------------- -- Constants, Options and Parsing of Command-Line Arguments -- ----------------------------------------------------------------------------- --- Path to partial evaluator pevalCmd :: String pevalCmd = "./peval" --- Path to timeout command timeoutCmd :: String timeoutCmd = "/usr/bin/timeout" --- Options supplied to PAKCS for evaluation of program pakcsEvalOpts :: String -> [String] pakcsEvalOpts mod = [":set", "v0", ":set", "-time", ":set", "parser", "-Wnone" , ":load", mod, ":eval", "main", ":quit"] --- Timeout used for evaluation of program using PAKCS evalTimeout :: Int evalTimeout = 5 --- Accepted return codes of evaluation of some program --- (0 = okay, 2 = no value found, 124 = time out) evalReturnCodes :: [Int] evalReturnCodes = [ 0, 2, 124 ] --- Options of test driver. --- @field optHelp - show the help and exit --- @field optVerbose - Enable verbose mode, showing error messages and --- computed/expected program in case of differences --- @field optColorMode - mode for output coloring --- @field optTestDir - directory to search for test cases --- @field optTimeout - timeout in seconds for partial evaluation --- @field optSemantics - semantics to be tested --- @field optAbstract - abstraction operators to be tested --- @field optEval - Enable evaluation of original/specialized program --- @field optAssert - Run partial evaluation with assertions enabled --- @field optSuffix - suffix for specialized programs --- @field optPakcsCmd - Path to the PAKCS binary, used for evaluation data Options = Options { optHelp :: Bool , optVerbose :: Bool , optColorMode :: ColorMode , optTestDir :: FilePath , optTimeout :: Int , optSemantics :: [Semantics] , optAbstract :: [Abstraction] , optEval :: Bool , optAssert :: Bool , optSuffix :: String , optPakcsCmd :: String } --- The default options defaultOptions :: Options defaultOptions = Options { optHelp = False , optVerbose = False , optColorMode = CMAuto , optTestDir = "test" , optTimeout = 2 , optSemantics = [] , optAbstract = [] , optEval = False , optAssert = False , optSuffix = "_pe" , optPakcsCmd = "/opt/pakcs/pakcs/bin/pakcs" } --- Option descriptions options :: [OptDescr (OptErr Options -> OptErr Options)] options = [ Option ['h', '?'] ["help" ] (NoArg (onOpts $ \o -> o { optHelp = True })) "show usage information" , Option ['v'] ["verbose"] (NoArg (onOpts $ \o -> o { optVerbose = True })) "run in verbose mode" , Option ['d'] ["testdir"] (ReqArg (\d -> onOpts $ \o -> o { optTestDir = d }) "DIR") "search for test cases in DIR" , Option ['t'] ["timeout"] (ReqArg (\t -> onOpts $ \o -> o { optTimeout = readInt t }) "N") "set timeout for partial evaluation to N seconds" , Option ['e'] ["eval"] (NoArg (onOpts $ \o -> o { optEval = True })) "evaluate original and specialized program using PAKCS (slower)" , Option [] ["assert"] (NoArg (onOpts $ \o -> o { optAssert = True })) "check additional abstraction assertions (slower)" , Option [] ["suffix"] (ReqArg (\c -> onOpts $ \o -> o { optSuffix = c }) "SUFFIX") "specify the suffix for the specialised program" , Option [] ["pakcs"] (ReqArg (\c -> onOpts $ \o -> o { optPakcsCmd = c }) "PAKCSCMD") "specify the path to the PAKCS curry system" , option [] ["color", "colour"] colorDescriptions "mode" "coloring mode" , option ['S'] ["semantics" ] semanticsDescriptions "semantics" "semantics for evaluation" , option ['A'] ["abstract" ] abstractDescriptions "mode" "abstraction mode" ] --- Semantics descriptions semanticsDescriptions :: OptTable Options semanticsDescriptions = map toDescr semantics where toDescr (flag, name, desc) = (name, desc, set flag) set s opts = opts { optSemantics = nub (optSemantics opts ++ [s]) } --- Abstraction descriptions abstractDescriptions :: OptTable Options abstractDescriptions = map toDescr abstractions where toDescr (flag, name, desc) = (name, desc, set flag) set a opts = opts { optAbstract = nub (optAbstract opts ++ [a]) } --- ColorMode descriptions colorDescriptions :: OptTable Options colorDescriptions = map toDescr colorModes where toDescr (flag, name, desc) = (name, desc, set flag) set c opts = opts { optColorMode = c } --- Parse the supplied command-line arguments. parseOpts :: [String] -> (Options, [String], [String]) parseOpts args = (opts, files, errs ++ argErrs) where (opts, argErrs) = foldl (flip ($)) (defaultOptions, []) optErrs (optErrs, files, errs) = getOpt Permute options args --- Print the usage information and exit. printUsage :: String -> IO a printUsage prog = do flushStrLn $ usageInfo header options exitWith 0 where header = "usage: " ++ prog ++ " [OPTION] ... MODULE ..." --- Print errors about bad usage and exit with error code 1. badUsage :: String -> [String] -> IO a badUsage prog [] = do hPutStrLn stderr $ "Try '" ++ prog ++ " --help' for more information" exitWith 1 badUsage prog (err:errs) = hPutStrLn stderr err >> badUsage prog errs --- Process the parsed options, eventually showing help or errors processOpts :: String -> (Options, [String], [String]) -> IO (Options, [String]) processOpts prog (opts, files, errs) | optHelp opts = printUsage prog | not (null errs') = badUsage prog errs' | otherwise = do opts' <- setColoring opts return (opts', files) where errs' = errs ++ checkOpts opts files --- Check the parsed options for validity checkOpts :: Options -> [String] -> [String] checkOpts opts _ = [ "Please specify a semantics" | null (optSemantics opts)] ++ [ "Please specify an abstraction" | null (optAbstract opts)] --- Set the coloring mode depending on the connected output stream. setColoring :: Options -> IO Options setColoring opts | optColorMode opts == CMAuto = do isTerminal <- hIsTerminalDevice stdout return opts { optColorMode = if isTerminal then CMAlways else CMNever } | otherwise = return opts --- Retrieve, parse and validate the program options getOpts :: IO Options getOpts = do args <- getArgs prog <- getProgName (opts, _) <- processOpts prog $ parseOpts args return opts -- ----------------------------------------------------------------------------- -- Data Types and Functions for Test Cases -- ----------------------------------------------------------------------------- --- Type synonym for a test case (name, test module, test spec files) type TestCase = (String, FilePath, [FilePath]) --- Retrieve the name of a test case. getName :: TestCase -> String getName (n, _, _) = n --- Retrieve the length of the longest name of a list of test cases. maxNameLength :: [TestCase] -> Int maxNameLength tests = maximum $ 0 : map (length . getName) tests --- Test result in increasing severity. --- @cons Ok : Expected result, both for partial evaluation and program --- execution. --- @cons Custom : Expected result for a specific abstraction and expected --- result for program execution. --- @cons Timeout : Partial evaluation did not finish in time. --- Acceptable only for no abstraction mode. --- @cons Failed : The partial evaluator returned an unexpected result, --- but the program semantics is as expected. --- @cons NoEval : The original program could not be executed. This --- decreases the significance of the test as the semantic --- equivalence can not be tested. --- @cons EvalError: The resulting program has a different semantics compared --- to the original program. This is really bad! --- @cons Error : The partial evaluation aborted with an internal error. data Result = Ok | Custom | Timeout | Failed | NoEval | EvalError | Error --- Colorize a `String` with a given coloring function, --- depending on the global coloring mode. color :: Options -> (String -> String) -> String -> String color opts paint s = if optColorMode opts == CMAlways then paint s else s --- Show the result of a test case. showResult :: Options -> Result -> String showResult opts res = color opts (resColor res) (map toUpper $ show res) where resColor Ok = green resColor Custom = green resColor Timeout = magenta resColor Failed = yellow resColor NoEval = yellow resColor EvalError = red resColor Error = red -- ----------------------------------------------------------------------------- -- Running Tests -- ----------------------------------------------------------------------------- --- Retrieve all available test cases. getTestPrograms :: Options -> IO [TestCase] getTestPrograms opts = do mdls <- findFilesRec (hasExtension (== ".curry")) (optTestDir opts) concat `liftIO` mapIO (getOutputSpecs opts) mdls --- Get the output specification for a specific module. getOutputSpecs :: Options -> FilePath -> IO [TestCase] getOutputSpecs opts m = do let d = takeDirectory m specs <- findFiles (isSpecOf opts m) d return $ if null specs then [] else [(dropExtension m, m, map (d ) specs)] --- Is a file a specification file of the given test module? isSpecOf :: Options -> FilePath -> FilePath -> Bool isSpecOf opts m s = takeBaseName s == takeBaseName m && hasExtension (`elem` ".spec" : map absSpec (optAbstract opts)) s where absSpec abs = '.' : toOption abs --- Run all given test cases for all specified abstractions and semantics. runTests :: Options -> [TestCase] -> IO () runTests opts tests = do results <- mapIO (\(sem, abs) -> testSemAbs opts len sem abs tests) combs flushStrLn $ replicate len '=' flushStrLn headers flushStrLn $ replicate len '-' forIO (zip combs results) $ \ ((sem, abs), res) -> do flushStrLn $ intercalate " " [ rpad 9 (show sem) , rpad 11 (show abs) , lpad 6 (show $ length tests) , color opts green $ lpad 3 $ show (count Ok res) , color opts green $ lpad 7 $ show (count Custom res) , color opts magenta $ lpad 8 $ show (count Timeout res) , color opts yellow $ lpad 7 $ show (count Failed res) , color opts yellow $ lpad 7 $ show (count NoEval res) , color opts red $ lpad 10 $ show (count EvalError res) , color opts red $ lpad 6 $ show (count Error res) ] flushStrLn $ replicate len '=' unless (all (`elem` [Ok, Custom, Timeout]) (concat results)) (exitWith 1) where headers = intercalate " " ["Semantics", "Abstraction", "#Tests", "#Ok", "#Custom", "#Timeout" , "#Failed", "#NoEval", "#EvalError", "#Error"] len = length headers combs = [(s, a) | s <- optSemantics opts, a <- optAbstract opts] --- Run all given test cases for a specific combination of semantics --- and abstraction operator. testSemAbs :: Options -> Int -> Semantics -> Abstraction -> [TestCase] -> IO [Result] testSemAbs opts len sem abs tests = do flushStrLn $ replicate len '=' flushStrLn $ "Testing " ++ color opts yellow (show sem) ++ " semantics " ++ "and " ++ color opts yellow (show abs) ++ " abstraction " ++ "with " ++ color opts yellow (show total) ++ " test(s)." flushStrLn $ replicate len '-' results <- mapIO (runTest opts testLen sem abs) tests let okCount = countBy (`elem` [Ok, Custom]) results toCount = count Timeout results flCount = countBy (`elem` [Failed, NoEval]) results erCount = countBy (`elem` [EvalError, Error]) results flushStrLn $ replicate len '=' flushStrLn $ show total ++ " test(s) executed, " ++ color opts green (show okCount) ++ " ok, " ++ color opts magenta (show toCount) ++ " timeouts, " ++ color opts yellow (show flCount) ++ " failed, " ++ color opts red (show erCount) ++ " errors.\n" return results where total = length tests testLen = maxNameLength tests --- Run a single test case for a specific combination of semantics --- and abstraction operator. runTest :: Options -> Int -> Semantics -> Abstraction -> TestCase -> IO Result runTest opts len sem abs (name, mod, specs) = do let pCall = [ pevalCmd , "-v0", "--debug" , "--semantics=" ++ toOption sem , "--abstract=" ++ toOption abs , "--suffix=" ++ optSuffix opts , mod ] ++ [ "--assert" | optAssert opts ] flushStr $ "Testing " ++ rpad len name ++ ": " (ec, res, err) <- evalCmd timeoutCmd (show (optTimeout opts) : pCall) [] spcs <- mapIO readFile (filter (hasExtension (`elem` [".spec", "." ++ toOption abs])) specs) result <- case ec of 0 | res == head spcs -> evalTest opts (dropExtension mod) Ok | res `elem` spcs -> evalTest opts (dropExtension mod) Custom | otherwise -> evalTest opts (dropExtension mod) Failed 124 | abs == None -> doesFileExist (name <.> "timeout") >>= \exists -> return (if exists then Timeout else Failed) | otherwise -> return Failed _ -> return Error flushStrLn $ showResult opts result when (result == Failed && optVerbose opts) $ do flushStrLn $ color opts yellow $ "Expected:" +\+ indentStr 2 (last spcs) flushStrLn $ color opts yellow $ "Got:" +\+ indentStr 2 res when (result == Error && optVerbose opts) $ do flushStrLn $ color opts red $ "Error message:" +\+ indentStr 2 err return result --- Convert a semantics/abstraction to an option name. toOption :: a -> String toOption = map toLower . show --- Evaluate a original program and its specialization and compare the results. evalTest :: Options -> String -> Result -> IO Result evalTest opts mod def | optEval opts = do (ec1, res1, err1) <- eval opts mod if ec1 `notElem` evalReturnCodes then print (ec1, res1, err1) >> return NoEval else do (ec2, res2, err2) <- eval opts (mod ++ optSuffix opts) if (ec1 == ec2 && res1 == res2 && err1 == err2) -- PAKCS does no blackhole detection! || mod == "test/base/blackhole" then return def else print ((ec1,ec2), (res1,res2), (err1,err2)) >> return EvalError | otherwise = return def --- Evaluate a Curry program using PAKCS (with a given timeout) --- and return its exit code as well as the contents of `stdout` and `stderr`. eval :: Options -> String -> IO (Int, String, String) eval opts mod = evalCmd timeoutCmd args [] where args = show evalTimeout : optPakcsCmd opts : pakcsEvalOpts mod -- ----------------------------------------------------------------------------- -- Directory lookup and strict output -- ----------------------------------------------------------------------------- --- Check if the extension of a `FilePath` satisfies the given predicate. hasExtension :: (String -> Bool) -> FilePath -> Bool hasExtension p fn = p (takeExtension fn) --- Find all files in the given directory that satisfy the given predicate. findFiles :: (FilePath -> Bool) -> FilePath -> IO [FilePath] findFiles p dir = filter p `liftIO` getUsefulContents dir --- Recursively find all files in the given directory and any subdirectories --- that satisfy the given predicate. findFilesRec :: (FilePath -> Bool) -> FilePath -> IO [FilePath] findFilesRec p dir = filter p `liftIO` getRecursiveContents dir --- Recursively find all files in the given directory. getRecursiveContents :: FilePath -> IO [FilePath] getRecursiveContents topdir = do names <- getUsefulContents topdir paths <- forIO names $ \name -> do let path = topdir name isDirectory <- doesDirectoryExist path if isDirectory then getRecursiveContents path else return [path] return (concat paths) --- List all files and directores in the given directory, --- excluding the `.curry` directory. getUsefulContents :: FilePath -> IO [String] getUsefulContents dir = (sortBy (<=) . filter (`notElem` [".", "..", ".curry"])) `liftIO` getDirectoryContents dir --- Print a `String` to `stdout` and directly flush the stream afterwards --- to provide immediate information to the user. flushStr :: String -> IO () flushStr str = putStr str >> hFlush stdout --- Print a `String` followed by a newline to `stdout` and directly flush --- the stream afterwards to provide immediate information to the user. flushStrLn :: String -> IO () flushStrLn str = putStrLn str >> hFlush stdout