@@ -0,0 +1,200 @@
1+module Main where
2+
3+import Control.Monad
4+import Data.List
5+import Data.Maybe
6+import qualified Data.Set as S
7+import Data.Time.Clock
8+import System.Directory
9+import System.Environment
10+import System.FilePath
11+import System.Exit
12+import System.Info
13+import System.IO
14+import System.Process
15+import Text.Regex
16+
17+data Flag = Update | Diff | ShowOutput | Quiet | Time deriving (Eq, Show, Ord)
18+
19+type Flags = S.Set Flag
20+
21+data Status = Success | Failure | Updated deriving (Eq, Show)
22+
23+data Config = Config {
24+ flags :: Flags,
25+ idrOpts :: [String],
26+ tests :: [String]
27+} deriving (Show, Eq)
28+
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)
34+
35+checkTestName :: String -> Bool
36+checkTestName d = (matchRegex (mkRegex "[0-9][0-9][0-9]") d /= Nothing)
37+ && (not $ isInfixOf "disabled" d)
38+
39+enumTests :: IO [String]
40+enumTests = do
41+ cd <- getCurrentDirectory
42+ dirs <- getDirectoryContents cd
43+ return $ sort $ filter checkTestName dirs
44+
45+parseFlag :: String -> Maybe Flag
46+parseFlag s = case s of
47+ "-u" -> Just Update
48+ "-d" -> Just Diff
49+ "-s" -> Just ShowOutput
50+ "-t" -> Just Time
51+ "-q" -> Just Quiet
52+ _ -> Nothing
53+
54+parseFlags :: [String] -> (S.Set Flag, [String])
55+parseFlags xs = (S.fromList f, i)
56+ where
57+ f = catMaybes $ map parseFlag fl
58+ (fl, i) = partition (\s -> parseFlag s /= Nothing) xs
59+
60+parseArgs :: [String] -> IO Config
61+parseArgs args = do
62+ (tests, rest) <- case args of
63+ ("all":xs) -> do
64+ et <- enumTests
65+ return (et, xs)
66+ ("without":xs) -> do
67+ t <- enumTests
68+ (blacklist, ys) <- return $ break (== "opts") xs
69+ return (t \\ blacklist, ys \\ ["opts"])
70+ (x:xs) -> do
71+ exists <- doesDirectoryExist x
72+ return (if checkTestName x && exists then [x] else [], xs)
73+ [] -> do
74+ et <- enumTests
75+ return (et, [])
76+ let (testOpts, idOpts) = parseFlags rest
77+ return $ Config testOpts idOpts tests
78+
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
81+-- this thing.
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 })
87+ ""
88+ return (ec, output)
89+
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
99+ t1 <- getCurrentTime
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"
106+ return Success
107+ else if doUpdate conf
108+ then do putStrLn $ test ++ " finished...UPDATE"
109+ writeFile (inTest "expected") output
110+ return Updated
111+ else do putStrLn $ test ++ " finished...FAILURE"
112+ _ <- rawSystem "diff" [inTest "output", inTest "expected"]
113+ return Failure
114+ when (showTime conf) $ do
115+ let dt = diffUTCTime t2 t1
116+ putStrLn $ "Duration of " ++ test ++ " was " ++ show dt
117+ return res
118+
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
125+ putStrLn "\n----"
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
132+ putStrLn ""
133+
134+runTests :: Config -> IO Bool
135+runTests conf = do
136+ stats <- mapM (runTest conf) (tests conf)
137+ unless (isQuiet conf) $ printStats conf stats
138+ return $ all (== Success) stats
139+
140+runShow :: Config -> IO Bool
141+runShow conf = do
142+ mapM_ (\t -> callProcess "cat" [t++"/output"]) (tests conf)
143+ return True
144+
145+runDiff :: Config -> IO Bool
146+runDiff conf = do
147+ mapM_ (\t -> do putStrLn $ "Differences in " ++ t ++ ":"
148+ ec <- rawSystem "diff" [t++"/output", t++"/expected"]
149+ when (ec == ExitSuccess) $ putStrLn "No differences found.")
150+ (tests conf)
151+ return True
152+
153+whisper :: Config -> String -> IO ()
154+whisper conf s = do unless (isQuiet conf) $ putStrLn s
155+
156+setPath :: Config -> IO ()
157+setPath conf = do
158+ maybeEnv <- lookupEnv "IDRIS"
159+ idrisEnv <- return $ fromMaybe "" maybeEnv
160+ if (idrisEnv /= "")
161+ then do
162+ idrisAbs <- makeAbsolute idrisEnv
163+ setEnv "IDRIS" idrisAbs
164+ whisper conf $ "Using " ++ idrisAbs
165+ else do
166+ path <- getEnv "PATH"
167+ let sandbox = "../.cabal-sandbox/bin"
168+ hasBox <- doesDirectoryExist sandbox
169+ bindir <- if hasBox
170+ then do
171+ whisper conf $ "Using Cabal sandbox at " ++ sandbox
172+ makeAbsolute sandbox
173+ else do
174+ stackExe <- findExecutable "stack"
175+ case stackExe of
176+ Just stack -> do
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)
184+
185+main = do
186+ hSetBuffering stdout LineBuffering
187+ args <- getArgs
188+ conf <- parseArgs args
189+ setPath conf
190+ t1 <- getCurrentTime
191+ res <- case tests conf of
192+ [] -> return True
193+ xs | showOutput conf -> runShow conf
194+ xs | showDiff conf -> runDiff conf
195+ xs -> runTests 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