Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
108 lines (97 sloc) 5.35 KB
-----------------------------------------------------------------------------
-- |
-- Module : Main
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- SBV library unit-test program
-----------------------------------------------------------------------------
module Main(main) where
import Control.Monad (unless, when)
import Data.Maybe (isJust)
import Data.List (isInfixOf)
import System.Directory (doesDirectoryExist)
import System.Environment (getArgs)
import System.Exit (exitWith, exitSuccess, ExitCode(..))
import System.FilePath ((</>))
import Test.HUnit (Test(..), Counts(..), runTestTT)
import Data.Version (showVersion)
import SBVTest (SBVTestSuite(..), generateGoldCheck)
import Paths_sbv (getDataDir, version)
import SBVUnitTestBuildTime (buildTime)
import SBVTestCollection (allTestCases)
main :: IO ()
main = do putStrLn $ "*** SBVUnitTester, version: " ++ showVersion version ++ ", time stamp: " ++ buildTime
tgts <- getArgs
case tgts of
[x] | x `elem` ["-h", "--help", "-?"]
-> do putStrLn "Usage: SBVUnitTests [-c] [-l] [-s] [targets]" -- Not quite right, but sufficient
putStrLn " -l: List all tests"
putStrLn " -s: Skip constant-folding tests"
putStrLn " -c: Create gold-files"
putStrLn " -m: Do a wild-card match on targets"
putStrLn " -i: Do an inverse wild-card match on targets"
putStrLn "If targets are given, run those groups; except with the -m flag which matches test names."
["-l"] -> showTargets
-- undocumented really
("-c":ts) -> run (Nothing, ts) False True ["SBVUnitTest/GoldFiles"]
("-s":ts) -> run (Nothing, ts) True False []
("-m":ts) -> run (Just False, ts) False False []
("-i":ts) -> run (Just True, ts) False False []
_ -> run (Nothing, tgts) False False []
checkGoldDir :: FilePath -> IO ()
checkGoldDir gd = do e <- doesDirectoryExist gd
unless e $ do putStrLn "*** Cannot locate gold file repository!"
putStrLn "*** Please call with one argument, the directory name of the gold files."
putStrLn "*** Cannot run test cases, exiting."
exitWith $ ExitFailure 1
allTargets :: [String]
allTargets = [s | (s, _, _) <- allTestCases]
showTargets :: IO ()
showTargets = do putStrLn "Known test targets are:"
mapM_ (putStrLn . ("\t" ++)) allTargets
run :: (Maybe Bool, [String]) -> Bool -> Bool -> [String] -> IO ()
run (mbWCMatch, targets) skipCF shouldCreate [gd] =
do mapM_ checkTgt targets
putStrLn $ "*** Starting SBV unit tests..\n*** Gold files at: " ++ show gd
checkGoldDir gd
cts <- runTestTT $ TestList $ concatMap mkTst [c | (tc, needsSolver, c) <- allTestCases, select needsSolver tc]
decide shouldCreate cts
where mkTst (SBVTestSuite f) = pick $ f (generateGoldCheck gd shouldCreate)
where pick :: Test -> [Test]
pick tst = case mbWCMatch of
Nothing -> [tst]
Just inverted -> collect tst
where collect (TestCase _) = []
collect (TestList ts) = concatMap collect ts
collect t@(TestLabel s _)
| all (`isInfixOf` s) targets = [t | not inverted]
| True = [t | inverted]
wcMode = isJust mbWCMatch
select needsSolver tc
| not included = False
| shouldCreate = True
| needsSolver = True
| True = not skipCF
where included | wcMode = True
| True = null targets || tc `elem` targets
checkTgt t | wcMode = return ()
| t `elem` allTargets = return ()
| True = do putStrLn $ "*** Unknown test target: " ++ show t
exitWith $ ExitFailure 1
run targets skipCF shouldCreate [] = getDataDir >>= \d -> run targets skipCF shouldCreate [d </> "SBVUnitTest" </> "GoldFiles"]
run _ _ _ _ = error "SBVUnitTests.run: impossible happened!"
decide :: Bool -> Counts -> IO ()
decide shouldCreate (Counts c t e f) = do
when (c /= t) $ putStrLn $ "*** Not all test cases were tried. (Only tested " ++ show t ++ " of " ++ show c ++ ")"
when (e /= 0) $ putStrLn $ "*** " ++ show e ++ " (of " ++ show c ++ ") test cases in error."
when (f /= 0) $ putStrLn $ "*** " ++ show f ++ " (of " ++ show c ++ ") test cases failed."
if c == t && e == 0 && f == 0
then do putStrLn $ "All " ++ show c ++ " test cases "
++ (if shouldCreate
then " executed in gold-file generation mode."
else " successfully passed.")
exitSuccess
else exitWith $ ExitFailure 2
Something went wrong with that request. Please try again.