diff options
Diffstat (limited to 'test/runTests.hs')
-rw-r--r-- | test/runTests.hs | 114 |
1 files changed, 59 insertions, 55 deletions
diff --git a/test/runTests.hs b/test/runTests.hs index 78a03fd6..b8478f64 100644 --- a/test/runTests.hs +++ b/test/runTests.hs | |||
@@ -115,11 +115,14 @@ main = do | |||
115 | let testSet = map head $ group $ sort [d | d <- testData, s <- if null samplesToTest then [""] else samplesToTest, s `isInfixOf` d] | 115 | let testSet = map head $ group $ sort [d | d <- testData, s <- if null samplesToTest then [""] else samplesToTest, s `isInfixOf` d] |
116 | 116 | ||
117 | when (null testSet) $ do | 117 | when (null testSet) $ do |
118 | liftIO $ putStrLn $ "test files not found: " ++ show samplesToTest | 118 | putStrLn $ "test files not found: " ++ show samplesToTest |
119 | exitFailure | 119 | exitFailure |
120 | 120 | ||
121 | liftIO $ putStrLn $ "------------------------------------ Running " ++ show (length testSet) ++ " tests" | 121 | putStrLn $ "------------------------------------ Running " ++ show (length testSet) ++ " tests" |
122 | resultDiffs <- acceptTests cfg testSet | 122 | |
123 | (Right resultDiffs, _) | ||
124 | <- runMM (ioFetch $ nub $ [".",testDataPath] ++ [takeDirectory f | f <- testSet, takeFileName f /= f]) | ||
125 | $ forM (zip [1..] testSet) $ doTest cfg | ||
123 | 126 | ||
124 | let sh b ty = [(if erroneous ty then "!" else "") ++ show noOfResult ++ " " ++ pad 10 (b ++ plural ++ ": ") ++ "\n" ++ unlines ss | 127 | let sh b ty = [(if erroneous ty then "!" else "") ++ show noOfResult ++ " " ++ pad 10 (b ++ plural ++ ": ") ++ "\n" ++ unlines ss |
125 | | not $ null ss] | 128 | | not $ null ss] |
@@ -128,7 +131,7 @@ main = do | |||
128 | noOfResult = length ss | 131 | noOfResult = length ss |
129 | plural = ['s' | noOfResult > 1] | 132 | plural = ['s' | noOfResult > 1] |
130 | 133 | ||
131 | unless (null resultDiffs) $ putStrLn $ unlines $ concat | 134 | putStrLn $ unlines $ concat |
132 | [ ["------------------------------------ Summary"] | 135 | [ ["------------------------------------ Summary"] |
133 | , sh "crashed test" ErrorCatched | 136 | , sh "crashed test" ErrorCatched |
134 | , sh "failed test" Failed | 137 | , sh "failed test" Failed |
@@ -145,58 +148,59 @@ main = do | |||
145 | when (or [erroneous r | ((_, r), f) <- zip resultDiffs testSet, isWip f]) $ | 148 | when (or [erroneous r | ((_, r), f) <- zip resultDiffs testSet, isWip f]) $ |
146 | putStrLn "Only work in progress test cases are failing." | 149 | putStrLn "Only work in progress test cases are failing." |
147 | 150 | ||
148 | acceptTests Config{..} tests | 151 | doTest Config{..} (i, fn) = do |
149 | = fmap (either (error "impossible") id . fst) | 152 | liftIO $ putStr $ n ++ " " |
150 | $ runMM (ioFetch $ nub $ [".",testDataPath] ++ [takeDirectory f | f <- tests, takeFileName f /= f]) | 153 | (runtime, res) <- mapMMT (timeOut cfgTimeout $ Left ("!Timed Out", TimedOut)) |
151 | $ forM (zip [1..] tests) mkTest | 154 | $ catchErr (\e -> return $ Left (tab "!Crashed" e, ErrorCatched)) |
155 | $ liftIO . evaluate =<< (force <$> action n) | ||
156 | liftIO $ putStr $ "(" ++ showTime runtime ++ ")" ++ " " | ||
157 | (msg, result) <- case res of | ||
158 | Left x -> return x | ||
159 | Right (op, x) -> liftIO $ compareResult (pad 15 op) (dropExtension fn ++ ".out") x | ||
160 | liftIO $ putStrLn msg | ||
161 | return (runtime, result) | ||
152 | where | 162 | where |
153 | mkTest (i, fn) = do | 163 | n = dropExtension fn |
154 | let n = dropExtension fn | 164 | |
155 | let er e = return (tab "!Crashed" e, ErrorCatched) | 165 | action n = f <$> (Right <$> getDef n "main" Nothing) `catchMM` (return . Left . show) |
156 | (runtime, (msg, result)) <- mapMMT (timeOut cfgTimeout ("!Timed Out", TimedOut)) $ catchErr er $ do | 166 | |
157 | result <- liftIO . evaluate =<< (force <$> action n) | 167 | f | not $ isReject fn = \case |
158 | liftIO $ case result of | 168 | Left e -> Left (tab "!Failed" e, Failed) |
159 | Left e -> return (tab "!Failed" e, Failed) | 169 | Right (fname, Left e, i) |
160 | Right (op, x) -> compareResult (pad 15 op) (dropExtension fn ++ ".out") x | 170 | -> Right ("typechecked module" |
161 | liftIO $ putStrLn $ n ++" (" ++ showTime runtime ++ ")" ++ " " ++ msg | 171 | , unlines $ e: "tooltips:": [ showRange (b, e) ++ " " ++ intercalate " | " m |
162 | return (runtime, result) | 172 | | (b, e, m) <- listInfos i, sourceName b == fname]) |
163 | where | 173 | Right (fname, Right e, i) |
164 | f | not $ isReject fn = \case | 174 | | True <- i `deepseq` False -> error "impossible" |
165 | Left e -> Left e | 175 | | tyOf e == outputType -> Right ("compiled pipeline", show . compilePipeline OpenGL33 $ e) |
166 | Right (fname, Left e, i) -> Right ("typechecked module", unlines $ e: "tooltips:": [showRange (b, e) ++ " " ++ intercalate " | " m | (b, e, m) <- listInfos i, sourceName b == fname]) | 176 | | e == trueExp -> Right ("reducted main", ppShow e) |
167 | Right (fname, Right e, i) | 177 | | tyOf e == boolType -> Left (tab "!Failed" $ "main should be True but it is \n" ++ ppShow e, Failed) |
168 | | True <- i `deepseq` False -> error "impossible" | 178 | | otherwise -> Right ("reduced main " ++ ppShow (tyOf e), ppShow e) |
169 | | tyOf e == outputType -> Right ("compiled pipeline", show . compilePipeline OpenGL33 $ e) | 179 | | otherwise = \case |
170 | | e == trueExp -> Right ("reducted main", ppShow e) | 180 | Left e -> Right ("error message", e) |
171 | | tyOf e == boolType -> Left $ "main should be True but it is \n" ++ ppShow e | 181 | Right _ -> Left (tab "!Failed" "failed to catch error", Failed) |
172 | | otherwise -> Right ("reduced main " ++ ppShow (tyOf e), ppShow e) | 182 | |
173 | | otherwise = \case | 183 | tab msg |
174 | Left e -> Right ("error message", e) | 184 | | isWip fn && cfgReject = const msg |
175 | Right _ -> Left "failed to catch error" | 185 | | otherwise = ((msg ++ "\n") ++) . unlines . map (" " ++) . lines |
176 | 186 | ||
177 | action n = f <$> (Right <$> getDef n "main" Nothing) `catchMM` (return . Left . show) | 187 | compareResult msg ef e = doesFileExist ef >>= \b -> case b of |
178 | 188 | False | |
179 | tab msg | 189 | | cfgReject -> return ("!Missing .out file", Rejected) |
180 | | isWip fn && cfgReject = const msg | 190 | | otherwise -> writeFile ef e >> return ("New .out file", New) |
181 | | otherwise = ((msg ++ "\n") ++) . unlines . map (" " ++) . lines | 191 | True -> do |
182 | 192 | e' <- readFileStrict ef | |
183 | compareResult msg ef e = doesFileExist ef >>= \b -> case b of | 193 | case map fst $ filter snd $ zip [0..] $ zipWith (/=) e e' ++ replicate (abs $ length e - length e') True of |
184 | False | 194 | [] -> return ("OK", Passed) |
185 | | cfgReject -> return ("!Missing .out file", Rejected) | 195 | rs | cfgReject-> return ("!Different .out file", Rejected) |
186 | | otherwise -> writeFile ef e >> return ("New .out file", New) | 196 | | otherwise -> do |
187 | True -> do | 197 | printOldNew msg (showRanges ef rs e') (showRanges ef rs e) |
188 | e' <- readFileStrict ef | 198 | putStrLn $ ef ++ " has changed." |
189 | case map fst $ filter snd $ zip [0..] $ zipWith (/=) e e' ++ replicate (abs $ length e - length e') True of | 199 | putStr $ "Accept new " ++ msg ++ " (y/n)? " |
190 | [] -> return ("OK", Passed) | 200 | c <- length e' `seq` getYNChar |
191 | rs | cfgReject-> return ("!Different .out file", Rejected) | 201 | if c |
192 | | otherwise -> do | 202 | then writeFile ef e >> return ("Accepted .out file", Accepted) |
193 | printOldNew msg (showRanges ef rs e') (showRanges ef rs e) | 203 | else return ("!Rejected .out file", Rejected) |
194 | putStrLn $ ef ++ " has changed." | ||
195 | putStr $ "Accept new " ++ msg ++ " (y/n)? " | ||
196 | c <- length e' `seq` getYNChar | ||
197 | if c | ||
198 | then writeFile ef e >> return ("Accepted .out file", Accepted) | ||
199 | else return ("!Rejected .out file", Rejected) | ||
200 | 204 | ||
201 | printOldNew msg old new = do | 205 | printOldNew msg old new = do |
202 | putStrLn $ msg ++ " has changed." | 206 | putStrLn $ msg ++ " has changed." |