@@ -0,0 +1,213 @@
1+{-# LANGUAGE CPP #-}
2+module Main where
3+
4+import Control.Monad
5+import Data.List
6+import Data.Maybe
7+import qualified Data.Set as S
8+import Data.Time.Clock
9+import System.Directory
10+import System.Environment
11+import System.FilePath
12+import System.Exit
13+import System.Info
14+import System.IO
15+import System.Process
16+import Text.Regex
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 = (matchRegex (mkRegex "[0-9][0-9][0-9]") d /= Nothing)
50+ && (not $ isInfixOf "disabled" d)
51+
52+enumTests :: IO [String]
53+enumTests = do
54+ cd <- getCurrentDirectory
55+ dirs <- getDirectoryContents cd
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+ -- just pretend that backslashes are slashes for comparison
109+ -- purposes to avoid path problems, so don't write any tests
110+ -- that depend on that distinction in other contexts
111+ let norm s = map (\c -> if c=='\\' then '/' else c) s
112+ t1 <- getCurrentTime
113+ (exitCode, output) <- runInShell test (idrOpts conf)
114+ t2 <- getCurrentTime
115+ expected <- readFile $ inTest "expected"
116+ writeFile (inTest "output") output
117+ res <- if (norm output == norm expected)
118+ then do putStrLn $ test ++ " finished...success"
119+ return Success
120+ else if doUpdate conf
121+ then do putStrLn $ test ++ " finished...UPDATE"
122+ writeFile (inTest "expected") output
123+ return Updated
124+ else do putStrLn $ test ++ " finished...FAILURE"
125+ _ <- rawSystem "diff" [inTest "output", inTest "expected"]
126+ return Failure
127+ when (showTime conf) $ do
128+ let dt = diffUTCTime t2 t1
129+ putStrLn $ "Duration of " ++ test ++ " was " ++ show dt
130+ return res
131+
132+printStats :: Config -> [Status] -> IO ()
133+printStats conf stats = do
134+ let total = length stats
135+ let successful = length $ filter (== Success) stats
136+ let failures = length $ filter (== Failure) stats
137+ let updates = length $ filter (== Updated) stats
138+ putStrLn "\n----"
139+ putStrLn $ show total ++ " tests run: " ++ show successful ++ " succesful, "
140+ ++ show failures ++ " failed, " ++ show updates ++ " updated."
141+ let failed = map fst $ filter ((== Failure) . snd) $ zip (tests conf) stats
142+ when (failed /= []) $ do
143+ putStrLn "\nFailed tests:"
144+ mapM_ putStrLn failed
145+ putStrLn ""
146+
147+runTests :: Config -> IO Bool
148+runTests conf = do
149+ stats <- mapM (runTest conf) (tests conf)
150+ unless (isQuiet conf) $ printStats conf stats
151+ return $ all (== Success) stats
152+
153+runShow :: Config -> IO Bool
154+runShow conf = do
155+ mapM_ (\t -> callProcess "cat" [t++"/output"]) (tests conf)
156+ return True
157+
158+runDiff :: Config -> IO Bool
159+runDiff conf = do
160+ mapM_ (\t -> do putStrLn $ "Differences in " ++ t ++ ":"
161+ ec <- rawSystem "diff" [t++"/output", t++"/expected"]
162+ when (ec == ExitSuccess) $ putStrLn "No differences found.")
163+ (tests conf)
164+ return True
165+
166+whisper :: Config -> String -> IO ()
167+whisper conf s = do unless (isQuiet conf) $ putStrLn s
168+
169+setPath :: Config -> IO ()
170+setPath conf = do
171+ maybeEnv <- lookupEnv "IDRIS"
172+ idrisEnv <- return $ fromMaybe "" maybeEnv
173+ if (idrisEnv /= "")
174+ then do
175+ idrisAbs <- makeAbsolute idrisEnv
176+ setEnv "IDRIS" idrisAbs
177+ whisper conf $ "Using " ++ idrisAbs
178+ else do
179+ path <- getEnv "PATH"
180+ let sandbox = "../.cabal-sandbox/bin"
181+ hasBox <- doesDirectoryExist sandbox
182+ bindir <- if hasBox
183+ then do
184+ whisper conf $ "Using Cabal sandbox at " ++ sandbox
185+ makeAbsolute sandbox
186+ else do
187+ stackExe <- findExecutable "stack"
188+ case stackExe of
189+ Just stack -> do
190+ out <- readProcess stack ["path", "--dist-dir"] []
191+ stackDistDir <- return $ takeWhile (/= '\n') out
192+ let stackDir = "../" ++ stackDistDir ++ "/build/idris"
193+ whisper conf $ "Using stack work dir at " ++ stackDir
194+ makeAbsolute stackDir
195+ Nothing -> return ""
196+ when (bindir /= "") $ setEnv "PATH" (bindir ++ [searchPathSeparator] ++ path)
197+
198+main = do
199+ hSetBuffering stdout LineBuffering
200+ args <- getArgs
201+ conf <- parseArgs args
202+ setPath conf
203+ t1 <- getCurrentTime
204+ res <- case tests conf of
205+ [] -> return True
206+ xs | showOutput conf -> runShow conf
207+ xs | showDiff conf -> runDiff conf
208+ xs -> runTests conf
209+ t2 <- getCurrentTime
210+ when (showTime conf) $ do
211+ let dt = diffUTCTime t2 t1
212+ putStrLn $ "Duration of Entire Test Suite was " ++ show dt
213+ unless res exitFailure