@@ -0,0 +1,200 @@
6+import qualified Data.Set as S
8+import System.Directory
9+import System.Environment
10+import System.FilePath
17+data Flag = Update | Diff | ShowOutput | Quiet | Time deriving (Eq, Show, Ord)
19+type Flags = S.Set Flag
21+data Status = Success | Failure | Updated deriving (Eq, Show)
23+data Config = Config {
29+isQuiet conf = Quiet `S.member` (flags conf)
30+showOutput conf = ShowOutput `S.member` (flags conf)
31+showTime conf = Time `S.member` (flags conf)
32+showDiff conf = Diff `S.member` (flags conf)
33+doUpdate conf = Update `S.member` (flags conf)
35+checkTestName :: String -> Bool
36+checkTestName d = (matchRegex (mkRegex "[0-9][0-9][0-9]") d /= Nothing)
37+ && (not $ isInfixOf "disabled" d)
39+enumTests :: IO [String]
41+ cd <- getCurrentDirectory
42+ dirs <- getDirectoryContents cd
43+ return $ sort $ filter checkTestName dirs
45+parseFlag :: String -> Maybe Flag
46+parseFlag s = case s of
49+ "-s" -> Just ShowOutput
54+parseFlags :: [String] -> (S.Set Flag, [String])
55+parseFlags xs = (S.fromList f, i)
57+ f = catMaybes $ map parseFlag fl
58+ (fl, i) = partition (\s -> parseFlag s /= Nothing) xs
60+parseArgs :: [String] -> IO Config
62+ (tests, rest) <- case args of
68+ (blacklist, ys) <- return $ break (== "opts") xs
69+ return (t \\ blacklist, ys \\ ["opts"])
71+ exists <- doesDirectoryExist x
72+ return (if checkTestName x && exists then [x] else [], xs)
76+ let (testOpts, idOpts) = parseFlags rest
77+ return $ Config testOpts idOpts tests
79+-- "bash" needed because Haskell has cmd as the default shell on windows, and
80+-- we also want to run the process with another current directory, so we get
82+runInShell :: String -> [String] -> IO (ExitCode, String)
83+runInShell test opts = do
84+ (ec, output, _) <- readCreateProcessWithExitCode
85+ ((proc "bash" ("run":opts)) { cwd = Just test,
86+ std_out = CreatePipe })
90+runTest :: Config -> String -> IO Status
91+runTest conf test = do
92+ -- don't touch the current directory as we want to run these things
93+ -- in parallel in the future
94+ let inTest s = test ++ "/" ++ s
95+ -- just pretend that backslashes are slashes for comparison
96+ -- purposes to avoid path problems, so don't write any tests
97+ -- that depend on that distinction in other contexts
98+ let norm s = map (\c -> if c=='\\' then '/' else c) s
100+ (exitCode, output) <- runInShell test (idrOpts conf)
101+ t2 <- getCurrentTime
102+ expected <- readFile $ inTest "expected"
103+ writeFile (inTest "output") output
104+ res <- if (norm output == norm expected)
105+ then do putStrLn $ test ++ " finished...success"
107+ else if doUpdate conf
108+ then do putStrLn $ test ++ " finished...UPDATE"
109+ writeFile (inTest "expected") output
111+ else do putStrLn $ test ++ " finished...FAILURE"
112+ _ <- rawSystem "diff" [inTest "output", inTest "expected"]
114+ when (showTime conf) $ do
115+ let dt = diffUTCTime t2 t1
116+ putStrLn $ "Duration of " ++ test ++ " was " ++ show dt
119+printStats :: Config -> [Status] -> IO ()
120+printStats conf stats = do
121+ let total = length stats
122+ let successful = length $ filter (== Success) stats
123+ let failures = length $ filter (== Failure) stats
124+ let updates = length $ filter (== Updated) stats
126+ putStrLn $ show total ++ " tests run: " ++ show successful ++ " succesful, "
127+ ++ show failures ++ " failed, " ++ show updates ++ " updated."
128+ let failed = map fst $ filter ((== Failure) . snd) $ zip (tests conf) stats
129+ when (failed /= []) $ do
130+ putStrLn "\nFailed tests:"
131+ mapM_ putStrLn failed
134+runTests :: Config -> IO Bool
136+ stats <- mapM (runTest conf) (tests conf)
137+ unless (isQuiet conf) $ printStats conf stats
138+ return $ all (== Success) stats
140+runShow :: Config -> IO Bool
142+ mapM_ (\t -> callProcess "cat" [t++"/output"]) (tests conf)
145+runDiff :: Config -> IO Bool
147+ mapM_ (\t -> do putStrLn $ "Differences in " ++ t ++ ":"
148+ ec <- rawSystem "diff" [t++"/output", t++"/expected"]
149+ when (ec == ExitSuccess) $ putStrLn "No differences found.")
153+whisper :: Config -> String -> IO ()
154+whisper conf s = do unless (isQuiet conf) $ putStrLn s
156+setPath :: Config -> IO ()
158+ maybeEnv <- lookupEnv "IDRIS"
159+ idrisEnv <- return $ fromMaybe "" maybeEnv
162+ idrisAbs <- makeAbsolute idrisEnv
163+ setEnv "IDRIS" idrisAbs
164+ whisper conf $ "Using " ++ idrisAbs
166+ path <- getEnv "PATH"
167+ let sandbox = "../.cabal-sandbox/bin"
168+ hasBox <- doesDirectoryExist sandbox
171+ whisper conf $ "Using Cabal sandbox at " ++ sandbox
172+ makeAbsolute sandbox
174+ stackExe <- findExecutable "stack"
177+ out <- readProcess stack ["path", "--dist-dir"] []
178+ stackDistDir <- return $ takeWhile (/= '\n') out
179+ let stackDir = "../" ++ stackDistDir ++ "/build/idris"
180+ whisper conf $ "Using stack work dir at " ++ stackDir
181+ makeAbsolute stackDir
182+ Nothing -> return ""
183+ when (bindir /= "") $ setEnv "PATH" (bindir ++ [searchPathSeparator] ++ path)
186+ hSetBuffering stdout LineBuffering
188+ conf <- parseArgs args
190+ t1 <- getCurrentTime
191+ res <- case tests conf of
193+ xs | showOutput conf -> runShow conf
194+ xs | showDiff conf -> runDiff conf
196+ t2 <- getCurrentTime
197+ when (showTime conf) $ do
198+ let dt = diffUTCTime t2 t1
199+ putStrLn $ "Duration of Entire Test Suite was " ++ show dt
200+ unless res exitFailure