{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Exception
import Control.Monad
import Data.Time.Clock
import Data.Time.Format
import Debug.Trace
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO
import System.IO.Temp
import Test.Common
import Test.CommonUtils
import Test.HUnit
import qualified Data.Set as S
-- ---------------------------------------------------------------------
data Verbosity = Debug | Status | None deriving (Eq, Show, Ord, Enum)
verb :: Verbosity
verb = Debug
-- ---------------------------------------------------------------------
writeCPP :: FilePath -> IO ()
writeCPP fp = appendFileFlush cppFile (('\n' : fp))
writeError = writeCPP
writeParseFail :: FilePath -> String -> IO ()
writeParseFail fp _s = appendFileFlush parseFailFile (('\n' : fp))
-- writeParseFail fp s = appendFileFlush parseFailFile (('\n' : (fp ++ " " ++ s)))
writeProcessed :: FilePath -> IO ()
writeProcessed fp = appendFileFlush processed (('\n' : fp))
writeFailed :: FilePath -> IO ()
writeFailed fp = appendFileFlush processedFailFile (('\n' : fp))
writeLog :: String -> IO ()
writeLog msg = appendFileFlush logFile (('\n' : msg))
getTimeStamp :: IO String
getTimeStamp = do
t <- getCurrentTime
return $ formatTime defaultTimeLocale (iso8601DateFormat (Just "%H%M%S")) t
writeFailure :: FilePath -> String -> IO ()
writeFailure fp db = do
ts <- getTimeStamp
let outname = failuresDir </> takeFileName fp <.> ts <.> "out"
writeFile outname db
appendFileFlush :: FilePath -> String -> IO ()
appendFileFlush f txt = withFile f AppendMode (\ hdl -> hPutStr hdl txt >> hFlush hdl)
-- ---------------------------------------------------------------------
readFileIfPresent fileName = do
isPresent <- doesFileExist fileName
if isPresent
then lines <$> readFile fileName
else return []
-- ---------------------------------------------------------------------
main :: IO ()
main = do
createDirectoryIfMissing True workDir
createDirectoryIfMissing True configDir
createDirectoryIfMissing True failuresDir
as <- getArgs
case as of
[] -> putStrLn "Must enter directory to process"
["failures"] -> do
fs <- lines <$> readFile origFailuresFile
() <$ runTests (TestList (map mkParserTest fs))
["clean"] -> do
putStrLn "Cleaning..."
writeFile processed ""
writeFile parseFailFile ""
writeFile cppFile ""
writeFile logFile ""
writeFile processedFailFile ""
removeDirectoryRecursive failuresDir
createDirectory failuresDir
putStrLn "Done."
-- ds -> () <$ (runTests =<< (TestList <$> mapM tests ds))
ds -> do
!blackList <- readFileIfPresent blackListed
!knownFailures <- readFileIfPresent knownFailuresFile
!processedList <- lines <$> readFile processed
!cppList <- lines <$> readFile cppFile
!parseFailList <- lines <$> readFile parseFailFile
let done = S.fromList (processedList ++ cppList ++ blackList ++ knownFailures ++ parseFailList)
tsts <- TestList <$> mapM (tests done) ds
runTests tsts
return ()
runTests :: Test -> IO Counts
runTests t = do
let n = testCaseCount t
putStrLn $ "Running " ++ show n ++ " tests."
putStrLn $ "Verbosity: " ++ show verb
runTestTT t
tests :: S.Set String -> FilePath -> IO Test
tests done dir = do
roundTripHackage done dir
-- Selection:
-- Hackage dir
roundTripHackage :: S.Set String -> FilePath -> IO Test
roundTripHackage done hackageDir = do
packageDirs <- drop 2 <$> getDirectoryContents hackageDir
when (verb <= Debug) (traceShowM hackageDir)
when (verb <= Debug) (traceShowM packageDirs)
TestList <$> mapM (roundTripPackage done) (zip [0..] (map (hackageDir </>) packageDirs))
roundTripPackage :: S.Set String -> (Int, FilePath) -> IO Test
roundTripPackage done (n, dir) = do
putStrLn (show n)
when (verb <= Status) (traceM dir)
hsFiles <- filter (flip S.notMember done) <$> findSrcFiles dir
return (TestLabel (dropFileName dir) (TestList $ map mkParserTest hsFiles))
mkParserTest :: FilePath -> Test
mkParserTest fp =
TestLabel fp $
TestCase (do writeLog $ "starting:" ++ fp
r1 <- catchAny (roundTripTest fp) $ \e -> do
writeError fp
throwIO e
case r1 of
Left (ParseFailure _ s) -> do
writeParseFail fp s
exitFailure
Right r -> do
writeProcessed fp
unless (status r == Success) (writeFailure fp (debugTxt r) >> writeFailed fp)
assertBool fp (status r == Success))
catchAny :: IO a -> (SomeException -> IO a) -> IO a
catchAny = Control.Exception.catch