Test refactored

src/Test.hs

@@ -19,46 +19,71 @@ import qualified Parser                         as P
 import           ParserTest
 import qualified Tokenizer                      as T
 import           TokenTest
+import           Types
 import qualified Warn                           as W
 import           WarnTest                       (warnExpected)
 
-dropSuffix :: FilePath -> FilePath
-dropSuffix = reverse . drop 1 . dropWhile (/= '.') . reverse
+main :: IO ()
+main = do
+  testfiles  <- (\v -> if null v then Nothing else Just v) . filter dotMo <$> getArgs
+  runnerArgs <- filter (not . dotMo) <$> getArgs
+  tokenizer  <- mkTest testfiles tokenizerTests "Tokenizer" "tests"
+  parser     <- mkTest testfiles parserTests    "Parser"    "tests"
+  p          <- mkTest testfiles printTests     "Print"     "tests/print"
+  w          <- mkTest testfiles warnTests      "Warn"      "tests/warn"
+  defaultMainWithArgs [tokenizer, parser, p, w] runnerArgs
+
+parserTests :: FilePath -> String -> Test
+parserTests file name =
+  let expected = name `lookup` parserExpected in
+  testCase file $ do
+    fmaybe expected
+      (fail $ name ++ " is missing in parserExpected")
+      (\exp -> tokenize file name $
+        parse (eq name exp))
+
+printTests :: FilePath -> String -> Test
+printTests file name =
+  testCase file $
+    tokenize file name $
+      parse (const $ assertBool "..." True)
+
+tokenizerTests :: FilePath -> String -> Test
+tokenizerTests file name =
+  let expected = name `lookup` tokenExpected in
+  testCase file $
+    when (isJust expected) $ do
+      result <- T.parseFile <$> readFile file
+      feither result
+        (assertEqual file (show $ fromJust expected) . show)
+        (assertEqual file (fromJust expected))
+
+warnTests :: FilePath -> String -> Test
+warnTests file name =
+  testCase file $ do
+    tokenize file name $
+      parse (\r -> do
+        fmaybe (name `lookup` warnExpected)
+          (fail $ name ++ " is missing in warnExpected")
+          (\exp -> assertEqual name exp (W.check r)))
+
+mkTest :: Maybe [FilePath] -> (FilePath -> String -> Test) -> TestName -> FilePath -> IO Test
+mkTest fs p tgName dir = do
+  files <- maybe (findTestFiles dir) return fs
+  return . testGroup tgName $ map (\f -> p f (takeFileName $ dropExtension f)) files
 
-tokenizerTests :: IO Test
-tokenizerTests = do
-  files <- fmap (map ("tests" </>) . sort . filter dotMo) $ getDirectoryContents "tests"
-  return $ testGroup "Tokenizer" $ flip map files $ \file ->
-    testCase file $ do
-      let name = (reverse . drop 1 . dropWhile (/= '.') . reverse . drop 1 . dropWhile (/= '/')) file
-      let expected = name `lookup` tokenExpected
-      when (isJust expected) $ do
-        result <- T.parseFile <$> readFile file
-        feither result
-          (assertEqual file (show $ fromJust expected) . show)
-          (assertEqual file (fromJust expected))
+findTestFiles :: FilePath -> IO [FilePath]
+findTestFiles fp = fmap (map (fp </>) . sort . filter dotMo) . getDirectoryContents $ fp
 
-parserTests :: Maybe [FilePath] -> IO Test
-parserTests jfiles = do
-  files <- fmaybe jfiles
-             (fmap (map ("tests" </>) . sort . filter dotMo) $ getDirectoryContents "tests")
-             return
---  let files = map ("tests" </>) ["Funcall.mo"]
-  return $ testGroup "Tests" $ flip map files $ \file ->
-    testCase file $ do
-      let name = (reverse . drop 1 . dropWhile (/= '.') . reverse . drop 1 . dropWhile (/= '/')) file
-      let expected = name `lookup` parserExpected
-      assertBool (name ++ " is missing in parserExpected") (isJust expected)
-      when (isJust expected) $ do
-        tokens <- T.parseFile <$> readFile file
-        feither tokens
-          (\err -> assertBool ("Could not tokenize " ++ name ++ ": " ++ show err) False)
-          (\toks -> do
-            r <- P.parse toks
-            case r of
-              Left (P.ParseError perr (P.ParseState { P.lastToken = lt, P.parseTokens = ts })) ->
-                error . show $ (perr, lt, take 3 ts)
-              Right res -> eq name (fromJust expected) res)
+tokenize :: FilePath -> String -> (T.Program -> IO ()) -> IO ()
+tokenize file name f = do
+  contents <- readFile file
+  let tokens = T.parseFile contents
+  either (\err -> assertBool ("Could not tokenize " ++ name ++ ": " ++ show err) False) f tokens
+
+parse :: ([AST] -> IO b) -> T.Program -> IO b
+parse f toks =
+  P.parse toks >>= either (\(P.ParseError perr (P.ParseState { P.parseTokens = ts })) -> error $ show (perr, take 3 ts)) f
 
 eq :: (Eq a, Show a) => String -> a -> a -> IO ()
 eq preface expected actual =
@@ -68,54 +93,3 @@ eq preface expected actual =
 
 fail :: String -> IO ()
 fail s = assertBool s False
-
-printTests :: IO Test
-printTests = do
-  files <- fmap (map ("tests/print" </>) . sort . filter dotMo) $ getDirectoryContents "tests/print"
-  return $ testGroup "Printing" $ flip map files $ \file ->
-    testCase file $ do
-      let name = (reverse . drop 1 . dropWhile (/= '.') . reverse . drop 1 . dropWhile (/= '/')) file
-      contents <- readFile file
-      let tokens = T.parseFile contents
-      feither tokens
-        (\err -> assertBool ("Could not tokenize " ++ name ++ ": " ++ show err) False)
-        (\toks -> do
-          res <- P.parse toks
-          feither res
-            (\(P.ParseError perr (P.ParseState { P.parseTokens = ts })) -> error $ show (perr, take 3 ts))
-            (const $ assertBool "..." True))
---            (\r -> assertEqual name contents (Print.printSrc r)))
-
-warnTests :: IO Test
-warnTests = do
-  files <- fmap (map ("tests/warn" </>) . sort . filter dotMo) $ getDirectoryContents "tests/warn"
-  return $ testGroup "Warn" $ flip map files $ \file ->
-    testCase file $ do
-      let name = (drop 1 . dropWhile (/= '/') . reverse . drop 1 . dropWhile (/= '.') . reverse . drop 1 . dropWhile (/= '/')) file
-      contents <- readFile file
-      let tokens = T.parseFile contents
-      feither tokens
-        (\err -> assertBool ("Could not tokenize " ++ name ++ ": " ++ show err) False)
-        (\toks -> do
-          res <- P.parse toks
-          feither res
-            (\(P.ParseError perr (P.ParseState { P.parseTokens = ts })) -> error $ show (perr, take 3 ts))
-            (\r -> do
-               fmaybe (name `lookup` warnExpected)
-                 (fail $ name ++ " is missing in warnExpected")
-                 (\exp -> assertEqual name exp (W.check r))))
-
-main :: IO ()
-main = do
-  testfiles <- (\v -> if null v then Nothing else Just v) . filter dotMo <$> getArgs
-  runnerArgs <- filter (not . dotMo) <$> getArgs
-  tests <- fmaybe testfiles
-    (do
-      tokenizer <- tokenizerTests
-      parser <- parserTests Nothing
-      pr <- printTests
-      w <- warnTests
-      return [tokenizer, parser, pr, w])
-    (\j -> (: []) <$> parserTests (Just j))
-
-  defaultMainWithArgs tests runnerArgs