Port the test suite to tasty

Test/Runner.hs

@@ -1,10 +1,12 @@
 -- | Use "runhaskell Setup.hs test" or "cabal test" to run these tests.
--- Particular files may be selected by supplying their names as arguments.
 module Main where
 
+import Test.Tasty
+import Test.Tasty.HUnit
 import Language.Haskell.Exts.Annotated
 import System.IO
 import Control.Monad
+import Control.Applicative
 import Data.List
 import Data.Char
 import System.Directory
@@ -14,44 +16,52 @@ import System.FilePath
 
 
 main :: IO ()
-main = go =<< getArgs
-
-
--- | Run the selected tests - or all of them if the supplied list is empty
-go :: [FilePath] -> IO ()
-go testsToRun = do
-    hSetBuffering stdout NoBuffering
-    files <- if null testsToRun then getDirectoryContents examplesDir else return testsToRun
-    putStrLn "Testing parser:"
-    src <- liftM (map (head . words) . lines) . readFile $ "Test" </> "failing.txt"
-    results <- sequence [check (x `elem` src) (examplesDir </> x) | x <- files, not $ "." `isPrefixOf` x]
-    putStrLn "\nAll parsing tests completed!\n"
-    putStrLn "Testing exact printer:"
-    pSrc <- liftM (map (head . words) . lines) . readFile $ "Test" </> "printFail.txt"
-    pResults <- sequence [roundTrip (x `elem` pSrc) (examplesDir </> x)
-                            | x <- files, x `notElem` src, not $ "." `isPrefixOf` x]
-    putStrLn "\nAll printing tests completed!\n"
-    unless (all id $ results ++ pResults) exitFailure
+main = do
+    files <- getDirectoryContents examplesDir
+    defaultMain . testGroup "Tests" =<<
+        sequence [ parserTests files, printerTests files ]
 
 
 -- | Where all the tests are to be found
 examplesDir :: FilePath
 examplesDir = "Test" </> "examples"
 
 
--- | Runs the test, and returns True unless there is an unexpected result
-check :: Bool -> FilePath -> IO Bool
-check expected file = do
+getParserFailing, getPrinterFailing :: IO [FilePath]
+(getParserFailing, getPrinterFailing) = (get "failing.txt", get "printFail.txt")
+    where
+    get fname = liftM (map (head . words) . lines) . readFile $ "Test" </> fname
+
+
+parserTests :: [FilePath] -> IO TestTree
+parserTests files = testGroup "Parser tests" <$> do
+    failing <- getParserFailing
+    return [check (x `elem` failing) (examplesDir </> x) | x <- files, not $ "." `isPrefixOf` x]
+
+
+check :: Bool -> FilePath -> TestTree
+check expected file = testCase file $ do
     res <- parseFile file
     case res of
-        ParseOk x | expected -> putStrLn ("\n<unexpected pass for " ++ file ++ ">") >> return False
-                  | otherwise -> putChar '.' >> return True
-        err | expected -> putChar '!' >> return True
-            | otherwise -> putStrLn ("\nFailure when parsing " ++ show file ++ "\n" ++ show err) >> return False
+        ParseOk x | expected -> assertFailure $ "Unexpected pass for " ++ file
+                  | otherwise -> return ()
+        err | expected -> return ()
+            | otherwise -> assertFailure $ "Failure when parsing " ++ show file ++ "\n" ++ show err
+
+
+printerTests :: [FilePath] -> IO TestTree
+printerTests files = testGroup "Exact printer tests" <$> do
+    parserFailing <- getParserFailing
+    printerFailing <- getPrinterFailing
+    return
+        [ roundTrip (x `elem` printerFailing) (examplesDir </> x)
+        | x <- files
+        , not $ "." `isPrefixOf` x
+        , not $ x `elem` parserFailing ]
 
 
-roundTrip :: Bool -> FilePath -> IO Bool
-roundTrip expected file = do
+roundTrip :: Bool -> FilePath -> TestTree
+roundTrip expected file = testCase file $ do
     fc <- readFile file
     pr <- parseFileWithComments (defaultParseMode { parseFilename = file }) file
     case pr of
@@ -61,14 +71,14 @@ roundTrip expected file = do
                         $ zip (map (reverse . dropWhile isSpace . reverse) $ lines fc)
                               (map (reverse . dropWhile isSpace . reverse) $ lines res)
       case xs of
-       [] | expected  -> putStrLn ("\n<unexpected pass for " ++ file ++ ">") >> return False
-          | otherwise -> putChar '.' >> return True
+       [] | expected  -> assertFailure $ "Unexpected pass for " ++ file
+          | otherwise -> return ()
        (lfc, lres):_
-          | expected  -> putChar '!' >> return True
-          | otherwise -> do
-              putStrLn $ "Result of print does not match input when printing " ++ show file
-              putStrLn $ "First unmatching lines are (line length):"
-              putStrLn $ "  Input  (" ++ show (length lfc)  ++ "): " ++ lfc
-              putStrLn $ "  Result (" ++ show (length lres) ++ "): " ++ lres
-              return False
-     err -> putStrLn ("\nFailure when parsing " ++ show file ++ "\n" ++ show err) >> return False
+          | expected  -> return ()
+          | otherwise -> assertFailure $ unlines
+              [ "Result of print does not match input when printing " ++ show file
+              , "First unmatching lines are (line length):"
+              , "  Input  (" ++ show (length lfc)  ++ "): " ++ lfc
+              , "  Result (" ++ show (length lres) ++ "): " ++ lres
+              ]
+     err -> assertFailure $ "Failure when parsing " ++ show file ++ "\n" ++ show err