1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import qualified GHC.Paths
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 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 :: FilePath -> IO ()
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 :: FilePath -> IO [String]
readFileIfPresent fileName = do
isPresent <- doesFileExist fileName
if isPresent
then lines <$> readFile fileName
else return []
-- ---------------------------------------------------------------------
main :: IO ()
main = do
let libdir = GHC.Paths.libdir
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 libdir) 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 libdir 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 :: LibDir -> S.Set String -> FilePath -> IO Test
tests libdir done dir = do
roundTripHackage libdir done dir
-- Selection:
-- Hackage dir
roundTripHackage :: LibDir -> S.Set String -> FilePath -> IO Test
roundTripHackage libdir done hackageDir = do
packageDirs <- drop 2 <$> getDirectoryContents hackageDir
when (verb <= Debug) (traceShowM hackageDir)
when (verb <= Debug) (traceShowM packageDirs)
TestList <$> mapM (roundTripPackage libdir done) (zip [0..] (map (hackageDir </>) packageDirs))
roundTripPackage :: LibDir -> S.Set String -> (Int, FilePath) -> IO Test
roundTripPackage libdir 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 libdir) hsFiles))
mkParserTest :: LibDir -> FilePath -> Test
mkParserTest libdir fp =
TestLabel fp $
TestCase (do writeLog $ "starting:" ++ fp
r1 <- catchAny (roundTripTest libdir 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
|
