@@ -1,230 +0,0 @@
8−import qualified Data.Set as S
10−import System.Directory
11−import System.Environment
12−import System.FilePath
18−-- Because GHC earlier than 7.8 lacks setEnv
19−-- Install the setenv package on Windows.
20−#if __GLASGOW_HASKELL__ < 708
21−#ifndef mingw32_HOST_OS
22−import qualified System.Posix.Env as PE(setEnv)
24−setEnv k v = PE.setEnv k v True
26−import System.SetEnv(setEnv)
30−data Flag = Update | Diff | ShowOutput | Quiet | Time deriving (Eq, Show, Ord)
32−type Flags = S.Set Flag
34−data Status = Success | Failure | Updated deriving (Eq, Show)
36−data Config = Config {
42−isQuiet conf = Quiet `S.member` (flags conf)
43−showOutput conf = ShowOutput `S.member` (flags conf)
44−showTime conf = Time `S.member` (flags conf)
45−showDiff conf = Diff `S.member` (flags conf)
46−doUpdate conf = Update `S.member` (flags conf)
48−checkTestName :: String -> Bool
49−checkTestName d = (all isDigit $ take 3 $ reverse d)
50− && (not $ isInfixOf "disabled" d)
52−enumTests :: IO [String]
54− cwd <- getCurrentDirectory
55− dirs <- getDirectoryContents cwd
56− return $ sort $ filter checkTestName dirs
58−parseFlag :: String -> Maybe Flag
59−parseFlag s = case s of
62− "-s" -> Just ShowOutput
67−parseFlags :: [String] -> (S.Set Flag, [String])
68−parseFlags xs = (S.fromList f, i)
70− f = catMaybes $ map parseFlag fl
71− (fl, i) = partition (\s -> parseFlag s /= Nothing) xs
73−parseArgs :: [String] -> IO Config
75− (tests, rest) <- case args of
81− (blacklist, ys) <- return $ break (== "opts") xs
82− return (t \\ blacklist, ys \\ ["opts"])
84− exists <- doesDirectoryExist x
85− return (if checkTestName x && exists then [x] else [], xs)
89− let (testOpts, idOpts) = parseFlags rest
90− return $ Config testOpts idOpts tests
92−-- "bash" needed because Haskell has cmd as the default shell on windows, and
93−-- we also want to run the process with another current directory, so we get
95−runInShell :: String -> [String] -> IO (ExitCode, String)
96−runInShell test opts = do
97− (ec, output, _) <- readCreateProcessWithExitCode
98− ((proc "bash" ("run":opts)) { cwd = Just test,
99− std_out = CreatePipe })
103−runTest :: Config -> String -> IO Status
104−runTest conf test = do
105− -- don't touch the current directory as we want to run these things
106− -- in parallel in the future
107− let inTest s = test ++ "/" ++ s
108− t1 <- getCurrentTime
109− (exitCode, output) <- runInShell test (idrOpts conf)
110− t2 <- getCurrentTime
111− expected <- readFile $ inTest "expected"
112− writeFile (inTest "output") output
113− res <- if (norm output == norm expected)
114− then do putStrLn $ test ++ " finished...success"
116− else if doUpdate conf
117− then do putStrLn $ test ++ " finished...UPDATE"
118− writeFile (inTest "expected") output
120− else do putStrLn $ test ++ " finished...FAILURE"
121− _ <- rawSystem "diff" [inTest "output", inTest "expected"]
123− when (showTime conf) $ do
124− let dt = diffUTCTime t2 t1
125− putStrLn $ "Duration of " ++ test ++ " was " ++ show dt
128− -- just pretend that backslashes are slashes for comparison
129− -- purposes to avoid path problems, so don't write any tests
130− -- that depend on that distinction in other contexts.
131− -- Also rewrite newlines for consistency.
132− norm ('\r':'\n':xs) = '\n' : norm xs
133− norm ('\\':'\\':xs) = '/' : norm xs
134− norm ('\\':xs) = '/' : norm xs
135− norm (x : xs) = x : norm xs
138−printStats :: Config -> [Status] -> IO ()
139−printStats conf stats = do
140− let total = length stats
141− let successful = length $ filter (== Success) stats
142− let failures = length $ filter (== Failure) stats
143− let updates = length $ filter (== Updated) stats
145− putStrLn $ show total ++ " tests run: " ++ show successful ++ " succesful, "
146− ++ show failures ++ " failed, " ++ show updates ++ " updated."
147− let failed = map fst $ filter ((== Failure) . snd) $ zip (tests conf) stats
148− when (failed /= []) $ do
149− putStrLn "\nFailed tests:"
150− mapM_ putStrLn failed
153−runTests :: Config -> IO Bool
155− stats <- mapM (runTest conf) (tests conf)
156− unless (isQuiet conf) $ printStats conf stats
157− return $ all (== Success) stats
159−runShow :: Config -> IO Bool
161− mapM_ (\t -> callProcess "cat" [t++"/output"]) (tests conf)
164−runDiff :: Config -> IO Bool
166− mapM_ (\t -> do putStrLn $ "Differences in " ++ t ++ ":"
167− ec <- rawSystem "diff" [t++"/output", t++"/expected"]
168− when (ec == ExitSuccess) $ putStrLn "No differences found.")
172−whisper :: Config -> String -> IO ()
173−whisper conf s = do unless (isQuiet conf) $ putStrLn s
176−isWindows = os `elem` ["win32", "mingw32", "cygwin32"]
178−setPath :: Config -> IO ()
180− maybeEnv <- lookupEnv "IDRIS"
181− idrisExists <- case maybeEnv of
183− let exeExtension = if isWindows then ".exe" else ""
184− doesFileExist (idrisExe ++ exeExtension)
185− Nothing -> return False
188− idrisAbs <- makeAbsolute $ fromMaybe "" maybeEnv
189− setEnv "IDRIS" idrisAbs
190− whisper conf $ "Using " ++ idrisAbs
192− path <- getEnv "PATH"
194− let sandbox = "../.cabal-sandbox/bin"
195− hasBox <- doesDirectoryExist sandbox
198− whisper conf $ "Using Cabal sandbox at " ++ sandbox
199− makeAbsolute sandbox
201− stackExe <- findExecutable "stack"
204− out <- readProcess stack ["path", "--dist-dir"] []
205− stackDistDir <- return $ takeWhile (/= '\n') out
206− let stackDir = "../" ++ stackDistDir ++ "/build/idris"
207− whisper conf $ "Using stack work dir at " ++ stackDir
208− makeAbsolute stackDir
209− Nothing -> return ""
210− when (bindir /= "") $ setEnv "PATH" (bindir ++ [searchPathSeparator] ++ path)
213− hSetBuffering stdout LineBuffering
214− withCabal <- doesDirectoryExist "test"
216− setCurrentDirectory "test"
218− conf <- parseArgs args
220− t1 <- getCurrentTime
221− res <- case tests conf of
223− xs | showOutput conf -> runShow conf
224− xs | showDiff conf -> runDiff conf
226− t2 <- getCurrentTime
227− when (showTime conf) $ do
228− let dt = diffUTCTime t2 t1
229− putStrLn $ "Duration of Entire Test Suite was " ++ show dt
230− unless res exitFailure