@@ -1,230 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−module Main where
3−
4−import Control.Monad
5−import Data.Char
6−import Data.List
7−import Data.Maybe
8−import qualified Data.Set as S
9−import Data.Time.Clock
10−import System.Directory
11−import System.Environment
12−import System.FilePath
13−import System.Exit
14−import System.Info
15−import System.IO
16−import System.Process
17−
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)
23−
24−setEnv k v = PE.setEnv k v True
25−#else
26−import System.SetEnv(setEnv)
27−#endif
28−#endif
29−
30−data Flag = Update | Diff | ShowOutput | Quiet | Time deriving (Eq, Show, Ord)
31−
32−type Flags = S.Set Flag
33−
34−data Status = Success | Failure | Updated deriving (Eq, Show)
35−
36−data Config = Config {
37− flags :: Flags,
38− idrOpts :: [String],
39− tests :: [String]
40−} deriving (Show, Eq)
41−
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)
47−
48−checkTestName :: String -> Bool
49−checkTestName d = (all isDigit $ take 3 $ reverse d)
50− && (not $ isInfixOf "disabled" d)
51−
52−enumTests :: IO [String]
53−enumTests = do
54− cwd <- getCurrentDirectory
55− dirs <- getDirectoryContents cwd
56− return $ sort $ filter checkTestName dirs
57−
58−parseFlag :: String -> Maybe Flag
59−parseFlag s = case s of
60− "-u" -> Just Update
61− "-d" -> Just Diff
62− "-s" -> Just ShowOutput
63− "-t" -> Just Time
64− "-q" -> Just Quiet
65− _ -> Nothing
66−
67−parseFlags :: [String] -> (S.Set Flag, [String])
68−parseFlags xs = (S.fromList f, i)
69− where
70− f = catMaybes $ map parseFlag fl
71− (fl, i) = partition (\s -> parseFlag s /= Nothing) xs
72−
73−parseArgs :: [String] -> IO Config
74−parseArgs args = do
75− (tests, rest) <- case args of
76− ("all":xs) -> do
77− et <- enumTests
78− return (et, xs)
79− ("without":xs) -> do
80− t <- enumTests
81− (blacklist, ys) <- return $ break (== "opts") xs
82− return (t \\ blacklist, ys \\ ["opts"])
83− (x:xs) -> do
84− exists <- doesDirectoryExist x
85− return (if checkTestName x && exists then [x] else [], xs)
86− [] -> do
87− et <- enumTests
88− return (et, [])
89− let (testOpts, idOpts) = parseFlags rest
90− return $ Config testOpts idOpts tests
91−
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
94−-- this thing.
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 })
100− ""
101− return (ec, output)
102−
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"
115− return Success
116− else if doUpdate conf
117− then do putStrLn $ test ++ " finished...UPDATE"
118− writeFile (inTest "expected") output
119− return Updated
120− else do putStrLn $ test ++ " finished...FAILURE"
121− _ <- rawSystem "diff" [inTest "output", inTest "expected"]
122− return Failure
123− when (showTime conf) $ do
124− let dt = diffUTCTime t2 t1
125− putStrLn $ "Duration of " ++ test ++ " was " ++ show dt
126− return res
127− where
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
136− norm [] = []
137−
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
144− putStrLn "\n----"
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
151− putStrLn ""
152−
153−runTests :: Config -> IO Bool
154−runTests conf = do
155− stats <- mapM (runTest conf) (tests conf)
156− unless (isQuiet conf) $ printStats conf stats
157− return $ all (== Success) stats
158−
159−runShow :: Config -> IO Bool
160−runShow conf = do
161− mapM_ (\t -> callProcess "cat" [t++"/output"]) (tests conf)
162− return True
163−
164−runDiff :: Config -> IO Bool
165−runDiff conf = do
166− mapM_ (\t -> do putStrLn $ "Differences in " ++ t ++ ":"
167− ec <- rawSystem "diff" [t++"/output", t++"/expected"]
168− when (ec == ExitSuccess) $ putStrLn "No differences found.")
169− (tests conf)
170− return True
171−
172−whisper :: Config -> String -> IO ()
173−whisper conf s = do unless (isQuiet conf) $ putStrLn s
174−
175−isWindows :: Bool
176−isWindows = os `elem` ["win32", "mingw32", "cygwin32"]
177−
178−setPath :: Config -> IO ()
179−setPath conf = do
180− maybeEnv <- lookupEnv "IDRIS"
181− idrisExists <- case maybeEnv of
182− Just idrisExe -> do
183− let exeExtension = if isWindows then ".exe" else ""
184− doesFileExist (idrisExe ++ exeExtension)
185− Nothing -> return False
186− if (idrisExists)
187− then do
188− idrisAbs <- makeAbsolute $ fromMaybe "" maybeEnv
189− setEnv "IDRIS" idrisAbs
190− whisper conf $ "Using " ++ idrisAbs
191− else do
192− path <- getEnv "PATH"
193− setEnv "IDRIS" ""
194− let sandbox = "../.cabal-sandbox/bin"
195− hasBox <- doesDirectoryExist sandbox
196− bindir <- if hasBox
197− then do
198− whisper conf $ "Using Cabal sandbox at " ++ sandbox
199− makeAbsolute sandbox
200− else do
201− stackExe <- findExecutable "stack"
202− case stackExe of
203− Just stack -> do
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)
211−
212−main = do
213− hSetBuffering stdout LineBuffering
214− withCabal <- doesDirectoryExist "test"
215− when withCabal $ do
216− setCurrentDirectory "test"
217− args <- getArgs
218− conf <- parseArgs args
219− setPath conf
220− t1 <- getCurrentTime
221− res <- case tests conf of
222− [] -> return True
223− xs | showOutput conf -> runShow conf
224− xs | showDiff conf -> runDiff conf
225− xs -> runTests 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