Refactor Haskell tests to use tasty (#1577)

Author: yoonieaj

CHANGELOG.md

@@ -15,6 +15,7 @@
 ### 🔧 Internal changes
 
 - Refactored navigation bar into a React component (for the graph, grid and generate pages only - the about page navigation bar is still rendered using Blaze)
+- Refactored backend tests to use `tasty` and `tasty-hunit` instead of `HUnit`
 
 ## [0.7.1] - 2025-06-16
 

backend-test/Controllers/ControllerTests.hs

@@ -8,11 +8,11 @@ Module that contains the test suites for all the controllers.
 module Controllers.ControllerTests
 (  controllerTests  ) where
 
-import Test.HUnit (Test (..))
+import Test.Tasty (TestTree, testGroup)
 
 import Controllers.CourseControllerTests (courseControllerTestSuite)
 import Controllers.GraphControllerTests (graphControllerTestSuite)
 
 -- Single test encompassing all controller test suites
-controllerTests :: Test
-controllerTests = TestList [courseControllerTestSuite, graphControllerTestSuite]
+controllerTests :: TestTree
+controllerTests = testGroup "Controller" [courseControllerTestSuite, graphControllerTestSuite]

backend-test/Controllers/CourseControllerTests.hs

@@ -17,10 +17,12 @@ import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
 import Database.Persist.Sqlite (SqlPersistM, insert_)
-import Database.Tables (Courses(..))
+import Database.Tables (Courses (..))
 import Happstack.Server (rsBody)
-import Test.HUnit (Test(..), assertEqual)
-import TestHelpers (clearDatabase, runServerPart, runServerPartWithQuery, runServerPartWithCourseInfoQuery)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (assertEqual, testCase)
+import TestHelpers (clearDatabase, runServerPart, runServerPartWithCourseInfoQuery,
+                    runServerPartWithQuery)
 
 -- | List of test cases as (input course name, course data, expected JSON output)
 retrieveCourseTestCases :: [(String, T.Text, Map.Map T.Text T.Text, String)]
@@ -56,9 +58,9 @@ retrieveCourseTestCases =
     ]
 
 -- | Run a test case (case, input, expected output) on the retrieveCourse function.
-runRetrieveCourseTest :: String -> T.Text -> Map.Map T.Text T.Text -> String -> Test
+runRetrieveCourseTest :: String -> T.Text -> Map.Map T.Text T.Text -> String -> TestTree
 runRetrieveCourseTest label courseName courseData expected =
-    TestLabel label $ TestCase $ do
+    testCase label $ do
         let currCourseName = fromMaybe "" $ Map.lookup "name" courseData
 
         let videoUrls = case Map.lookup "videoUrls" courseData of
@@ -89,7 +91,7 @@ runRetrieveCourseTest label courseName courseData expected =
         assertEqual ("Unexpected response body for " ++ label) expected actual
 
 -- | Run all the retrieveCourse test cases
-runRetrieveCourseTests :: [Test]
+runRetrieveCourseTests :: [TestTree]
 runRetrieveCourseTests = map (\(label, courseName, courseData, expected) -> runRetrieveCourseTest label courseName courseData expected) retrieveCourseTestCases
 
 -- | Helper function to insert courses into the database
@@ -108,9 +110,9 @@ indexTestCases =
     ]
 
 -- | Run a test case (case, input, expected output) on the index function.
-runIndexTest :: String -> [T.Text] -> String -> Test
+runIndexTest :: String -> [T.Text] -> String -> TestTree
 runIndexTest label courses expected =
-    TestLabel label $ TestCase $ do
+    testCase label $ do
         runDb $ do
             clearDatabase
             insertCourses courses
@@ -119,12 +121,12 @@ runIndexTest label courses expected =
         assertEqual ("Unexpected response body for " ++ label) expected actual
 
 -- | Run all the index test cases
-runIndexTests :: [Test]
+runIndexTests :: [TestTree]
 runIndexTests = map (\(label, courses, expected) -> runIndexTest label courses expected) indexTestCases
 
 -- | List of test cases as (case, database state, input [dept], expected JSON output) for the courseInfo function
 courseInfoTestCases :: [(String, [Courses], T.Text, String)]
-courseInfoTestCases = 
+courseInfoTestCases =
     [ ("Empty Database"
     , []
     , "STA"
@@ -183,11 +185,11 @@ courseInfoTestCases =
             , coursesCoreqs = Nothing
             , coursesVideoUrls = []
             }
-    
+
 -- | Run a test case (case, database state, input [dept], expected JSON output) on the courseInfo function
-runCourseInfoTest :: String -> [Courses] -> T.Text -> String -> Test
+runCourseInfoTest :: String -> [Courses] -> T.Text -> String -> TestTree
 runCourseInfoTest label state dept expected =
-    TestLabel label $ TestCase $ do
+    testCase label $ do
         runDb $ do
             clearDatabase
             mapM_ insert_ state
@@ -196,10 +198,10 @@ runCourseInfoTest label state dept expected =
         assertEqual ("Unexpected response body for " ++ label) expected actual
 
 -- | Run all courseInfo test cases
-runCourseInfoTests :: [Test]
+runCourseInfoTests :: [TestTree]
 runCourseInfoTests = map (\(label, state, dept, expected) -> runCourseInfoTest label state dept expected) courseInfoTestCases
 
 
 -- | Test suite for Course Controller Module
-courseControllerTestSuite :: Test
-courseControllerTestSuite = TestLabel "Course Controller tests" $ TestList (runRetrieveCourseTests ++ runIndexTests ++ runCourseInfoTests)
+courseControllerTestSuite :: TestTree
+courseControllerTestSuite = testGroup "Course Controller tests" (runRetrieveCourseTests ++ runIndexTests ++ runCourseInfoTests)

backend-test/Controllers/GraphControllerTests.hs

@@ -16,7 +16,8 @@ import qualified Data.Text as T
 import Database.Persist.Sqlite (SqlPersistM, insert_)
 import Database.Tables (Graph (..))
 import Happstack.Server (rsBody)
-import Test.HUnit (Test (..), assertEqual)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (assertEqual, testCase)
 import TestHelpers (clearDatabase, runServerPart)
 
 -- | List of test cases as (label, input graphs, expected output)
@@ -44,9 +45,9 @@ insertGraphs = mapM_ insertGraph
         insertGraph title = insert_ (Graph title 0 0 False )
 
 -- | Run a test case (case, input, expected output) on the index function.
-runIndexTest :: String -> [T.Text] -> String -> Test
+runIndexTest :: String -> [T.Text] -> String -> TestTree
 runIndexTest label graphs expected =
-    TestLabel label $ TestCase $ do
+    testCase label $ do
         runDb $ do
             clearDatabase
             insertGraphs graphs
@@ -55,9 +56,9 @@ runIndexTest label graphs expected =
         assertEqual ("Unexpected response body for " ++ label) expected actual
 
 -- | Run all the index test cases
-runIndexTests :: [Test]
+runIndexTests :: [TestTree]
 runIndexTests = map (\(label, graphs, expected) -> runIndexTest label graphs expected) indexTestCases
 
 -- | Test suite for Graph Controller Module
-graphControllerTestSuite :: Test
-graphControllerTestSuite = TestLabel "Graph Controller tests" $ TestList runIndexTests
+graphControllerTestSuite :: TestTree
+graphControllerTestSuite = testGroup "Graph Controller tests" runIndexTests

backend-test/Database/CourseQueriesTests.hs

@@ -14,10 +14,11 @@ import Control.Monad.IO.Class (liftIO)
 import qualified Data.Text as T
 import Data.Time (getCurrentTime)
 import Database.CourseQueries (reqsForPost)
-import Database.DataType (PostType(..))
+import Database.DataType (PostType (..))
 import Database.Persist.Sqlite (insert_)
-import Database.Tables (Post(..))
-import Test.HUnit (Test(..), assertEqual)
+import Database.Tables (Post (..))
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (assertEqual, testCase)
 import TestHelpers (clearDatabase)
 
 -- | List of test cases as (label, requirements to insert, input program, expected output)
@@ -29,9 +30,9 @@ reqsForPostTestCases =
     ]
 
 -- | Run a test case (case, requirements, input, expected output) on the reqsForPost function.
-runReqsForPostTest :: String -> T.Text -> T.Text -> String -> Test
+runReqsForPostTest :: String -> T.Text -> T.Text -> String -> TestTree
 runReqsForPostTest label reqsToInsert program expected =
-    TestLabel label $ TestCase $ do
+    testCase label $ do
         currentTime <- liftIO getCurrentTime
         let testPost = Post Major "Computer Science" program "Sample post description" reqsToInsert currentTime currentTime
 
@@ -44,9 +45,9 @@ runReqsForPostTest label reqsToInsert program expected =
         assertEqual ("Unexpected response body for " ++ label) expected actual
 
 -- | Run all the reqsForPost test cases
-runReqsForPostTests :: [Test]
+runReqsForPostTests :: [TestTree]
 runReqsForPostTests = map (\(label, reqsToInsert, program, expected) -> runReqsForPostTest label reqsToInsert program expected) reqsForPostTestCases
 
 -- | Test suite for CourseQueries Module
-courseQueriesTestSuite :: Test
-courseQueriesTestSuite = TestLabel "Course Queries tests" $ TestList runReqsForPostTests
+courseQueriesTestSuite :: TestTree
+courseQueriesTestSuite = testGroup "Course Queries tests" runReqsForPostTests

backend-test/Database/DatabaseTests.hs

@@ -8,9 +8,9 @@ Module that contains the test suites for all the database functions.
 module Database.DatabaseTests
 (  databaseTests  ) where
 
-import Test.HUnit (Test (..))
 import Database.CourseQueriesTests (courseQueriesTestSuite)
+import Test.Tasty (TestTree, testGroup)
 
 -- Single test encompassing all database test suites
-databaseTests :: Test
-databaseTests = TestList [courseQueriesTestSuite]
+databaseTests :: TestTree
+databaseTests = testGroup "Database" [courseQueriesTestSuite]

backend-test/Main.hs

@@ -7,30 +7,26 @@ Module that acts as interface for testing multiple test suites using cabal.
 
 module Main where
 
-import Control.Monad (when)
 import Config (databasePath)
-import Data.Text (unpack)
-import Database.Database(setupDatabase)
-import System.Directory (removeFile)
-import System.Environment (setEnv, unsetEnv)
-import qualified System.Exit as Exit
-import Test.HUnit (Test (..), failures, runTestTT)
-import RequirementTests.RequirementTests (requirementTests)
+import Control.Monad (when)
 import Controllers.ControllerTests (controllerTests)
+import Data.Text (unpack)
+import Database.Database (setupDatabase)
 import Database.DatabaseTests (databaseTests)
+import RequirementTests.RequirementTests (requirementTests)
 import SvgTests.SvgTests (svgTests)
-
-tests :: IO Test
-tests = do
-    return $ TestList [requirementTests, controllerTests, svgTests, databaseTests]
+import System.Directory (removeFile)
+import System.Environment (setEnv, unsetEnv)
+import Test.Tasty
 
 main :: IO ()
 main = do
     setEnv "APP_ENV" "test"
     setupDatabase
-    testSuites <- tests
-    count <- runTestTT testSuites
-    when (failures count > 0) Exit.exitFailure
+    defaultMain tests
     path <- databasePath
     removeFile $ unpack path
     unsetEnv "APP_ENV"
+
+tests :: TestTree
+tests = testGroup "Tests" [controllerTests, databaseTests, requirementTests, svgTests]

backend-test/RequirementTests/ModifierTests.hs

@@ -10,13 +10,14 @@ module RequirementTests.ModifierTests
 
 import Database.Requirement
 import DynamicGraphs.GraphNodeUtils (concatModOr, stringifyModAnd)
-import Test.HUnit (Test (..), assertEqual)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (assertEqual, testCase)
 
 -- Function to facilitate test case creation given a string, Req tuple
-createTest :: (Eq a, Show a) => (a -> String) -> String -> [(a, String)] -> Test
-createTest function label input = TestLabel label $ TestList $ map (\(x, y) ->
-                                TestCase $ assertEqual ("for (" ++ y ++ ")")
-                                y (function x)) input
+createTest :: (Eq a, Show a) => (a -> String) -> String -> [(a, String)] -> TestTree
+createTest function label input = testGroup label $ zipWith (\(x :: Int) (y, z) ->
+                                testCase ("Test " ++ show x) $ assertEqual ("for (" ++ z ++ ")")
+                                z (function y)) [0..] input
 
 -- Global FCEs value so the expected output has the same FCEs as the partial function in createTest
 globalFces :: Float
@@ -47,15 +48,15 @@ modandModOrInputs = [
     , ([ModOr [Level "300", Level "400"], ModOr [Department "CSC", Department "BCB"], Requirement (Raw "some raw text")], show globalFces ++ " CSC/BCB FCEs at the 300/400 level from some raw text")
     ]
 
-concatModOrTests :: Test
+concatModOrTests :: TestTree
 concatModOrTests = createTest concatModOr "joining ModOr with a delimiter" concatModOrInputs
 
-simpleModAndTests :: Test
+simpleModAndTests :: TestTree
 simpleModAndTests = createTest (stringifyModAnd globalFces) "ModAnd not containing ModOrs" simpleModAndInputs
 
-modandModOrTests :: Test
+modandModOrTests :: TestTree
 modandModOrTests = createTest (stringifyModAnd globalFces) "ModAnd containing ModOrs" modandModOrInputs
 
 -- functions for running tests in REPL
-modifierTestSuite :: Test
-modifierTestSuite = TestLabel "ReqParser tests" $ TestList [concatModOrTests, simpleModAndTests, modandModOrTests]
+modifierTestSuite :: TestTree
+modifierTestSuite = testGroup "ReqParser tests" [concatModOrTests, simpleModAndTests, modandModOrTests]

backend-test/RequirementTests/PostParserTests.hs

@@ -11,15 +11,16 @@ module RequirementTests.PostParserTests
 import Data.Bifunctor (second)
 import qualified Data.Text as T
 import Database.DataType (PostType (..))
-import Test.HUnit (Test (..), assertEqual)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (assertEqual, testCase)
 import qualified Text.Parsec as Parsec
 import WebParsing.PostParser (getPostType, postInfoParser)
 
 -- Function to facilitate test case creation given a string, Req tuple
-createTest :: (Show a, Eq a, Show b, Eq b) => (a -> b) -> String -> [(a, b)] -> Test
-createTest function label input = TestLabel label $ TestList $ map (\(x, y) ->
-                                TestCase $ assertEqual ("for (" ++ show x ++ "),")
-                                y (function x)) input
+createTest :: (Show a, Eq a, Show b, Eq b) => (a -> b) -> String -> [(a, b)] -> TestTree
+createTest function label input = testGroup label $ zipWith (\(x :: Int) (y, z) ->
+                                testCase ("Test " ++ show x) $ assertEqual ("for (" ++ show y ++ "),")
+                                z (function y)) [0..] input
 
 -- | Input and output pair of each post
 -- | Output is in the order of (postDepartment, postCode, postName)
@@ -69,12 +70,12 @@ getPostTypeInputs = [
     , (("", "Certificate in Business"), Certificate)
     ]
 
-postInfoTests :: Test
+postInfoTests :: TestTree
 postInfoTests = createTest (Parsec.parse postInfoParser "") "Post requirements" $ map (second Right) postInfoInputs
 
-getPostTypeTests :: Test
+getPostTypeTests :: TestTree
 getPostTypeTests = createTest (uncurry getPostType) "Post requirements" getPostTypeInputs
 
 -- functions for running tests in REPL
-postTestSuite :: Test
-postTestSuite = TestLabel "PostParser tests" $ TestList [postInfoTests, getPostTypeTests]
+postTestSuite :: TestTree
+postTestSuite = testGroup "PostParser tests" [postInfoTests, getPostTypeTests]

backend-test/RequirementTests/PreProcessingTests.hs

@@ -7,14 +7,15 @@ module RequirementTests.PreProcessingTests
 ( preProcTestSuite ) where
 
 import Data.Text as T hiding (map)
-import Test.HUnit (Test (..), assertEqual)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (assertEqual, testCase)
 import Text.HTML.TagSoup (Tag (..))
 import WebParsing.PostParser (pruneHtml)
 
-createTest :: (Eq a, Show a, Eq b, Show b) => (a -> b) -> String -> [(a, b)] -> Test
-createTest function label input = TestLabel label $ TestList $ map (\(x, y) ->
-                                TestCase $ assertEqual ("for (" ++ show y ++ ")")
-                                y (function x)) input
+createTest :: (Eq a, Show a, Eq b, Show b) => (a -> b) -> String -> [(a, b)] -> TestTree
+createTest function label input = testGroup label $ Prelude.zipWith (\(x :: Int) (y, z) ->
+                                testCase ("Test " ++ show x) $ assertEqual ("for (" ++ show z ++ ")")
+                                z (function y)) [0..] input
 
 
 pruneHtmlInputs :: [([Tag T.Text], [Tag T.Text])]
@@ -33,9 +34,9 @@ pruneHtmlInputs = [
     )
     ]
 
-pruneHtmlTests :: Test
+pruneHtmlTests :: TestTree
 pruneHtmlTests = createTest pruneHtml "filtering out html attributes" pruneHtmlInputs
 
 -- functions for running tests in REPL
-preProcTestSuite :: Test
-preProcTestSuite = TestLabel "Pre-processing tests" $ TestList [pruneHtmlTests]
+preProcTestSuite :: TestTree
+preProcTestSuite = testGroup "Pre-processing tests" [pruneHtmlTests]