Port test to HUnit

.gitignore

@@ -2,3 +2,4 @@
 .ghc.environment.*
 *.o
 *.hi
+Main

guix.scm

@@ -1,4 +1,5 @@
-(use-modules (gnu packages haskell-xyz)
+(use-modules (gnu packages haskell-check)
+             (gnu packages haskell-xyz)
              (gnu packages haskell-web)
              (guix build-system haskell)
              (guix download)
@@ -23,6 +24,7 @@
     (inputs
       (list ghc-aeson
             ghc-attoparsec
+            ghc-hunit
             ghc-lucid
             ghc-optparse-applicative
             ghc-parsec

hablo.cabal

@@ -76,8 +76,8 @@ executable hablo
   default-language:    Haskell2010
 
 test-suite tests
-  type:                detailed-0.9
+  type:                exitcode-stdio-1.0
-  test-module:         Tests
+  main-is:             Main.hs
   other-modules:       Mock.Arguments
                      , Mock.Article
                      , Mock.ArticlesList
@@ -95,11 +95,11 @@ test-suite tests
                      , XML.Card.Component
                      , XML.Card.Output
   build-depends:       base
-                     , Cabal
                      , containers
                      , directory
                      , filepath
                      , hablo
+                     , HUnit
                      , lucid
                      , mtl
                      , text

test/Main.hs

@@ -0,0 +1,10 @@
+module Main where
+
+import qualified Structure (test)
+import Test.HUnit (Test(..), runTestTTAndExit)
+import qualified XML.Card (test)
+
+main :: IO ()
+main = runTestTTAndExit $ TestList
+  [ XML.Card.test
+  , Structure.test ]

test/Structure.hs

@@ -5,36 +5,37 @@ module Structure (
 import Arguments (Arguments(..))
 import Blog (Path)
 import qualified Blog.Path as Path (build)
-import Distribution.TestSuite
 import qualified Mock.Arguments as Arguments
 import qualified Mock.Blog.Path as Path
 import System.Directory (withCurrentDirectory)
-import Utils (simpleTest, tag)
+import Test.HUnit (Test(..), assertEqual)
+import Utils (labeled, testGroup)
 
-checkPath :: Arguments -> Maybe Path -> IO Progress
+checkPath :: Arguments -> Maybe Path -> Test
-checkPath input expected = do
+checkPath input expected = TestCase . withCurrentDirectory root $
-  withCurrentDirectory root $ do
+    either (\_ -> Nothing) Just <$> Path.build root input
-    actual <- either (\_ -> Nothing) Just <$> Path.build root input
+      >>= assertEqual "Incorrect path detected by hablo" expected
-    return . Finished $
-      if actual == expected
-      then Pass
-      else Fail $ "Expected " ++ show expected ++ " but got " ++ show actual
   where
     root = sourceDir input
 
 test :: Test
-test = tag "structure" . testGroup "Blog structure" $ simpleTest <$> [
+test = testGroup "Blog structure" $ labeled
-      ("empty structure", checkPath Arguments.emptyBlog Nothing)
+  [ ("empty structure", checkPath Arguments.emptyBlog Nothing)
-    , ("default articles", checkPath Arguments.defaultArticles $ Just Path.defaultArticles)
+  , ("default articles"
-    , ("default pages", checkPath Arguments.defaultPages $ Just Path.defaultPages)
+    , checkPath Arguments.defaultArticles $ Just Path.defaultArticles)
-    , ("both default", checkPath Arguments.bothDefault $ Just Path.bothDefault)
+  , ("default pages", checkPath Arguments.defaultPages $ Just Path.defaultPages)
-    , ("custom articles", checkPath Arguments.customArticles $ Just Path.customArticles)
+  , ("both default", checkPath Arguments.bothDefault $ Just Path.bothDefault)
-    , ("custom pages", checkPath Arguments.customPages $ Just Path.customPages)
+  , ("custom articles"
-    , ("both custom", checkPath Arguments.bothCustom $ Just Path.bothCustom)
+    , checkPath Arguments.customArticles $ Just Path.customArticles)
-    , ("custom articles, default pages"
+  , ("custom pages", checkPath Arguments.customPages $ Just Path.customPages)
-        , checkPath Arguments.customArticlesDefaultPages $ Just Path.customArticlesDefaultPages)
+  , ("both custom", checkPath Arguments.bothCustom $ Just Path.bothCustom)
-    , ("custom pages, default articles"
+  , ("custom articles, default pages"
-        , checkPath Arguments.customPagesDefaultArticles $ Just Path.customPagesDefaultArticles)
+    , (checkPath
-    , ("bad custom articles", checkPath Arguments.badCustomArticles $ Nothing)
+        Arguments.customArticlesDefaultPages
-    , ("bad custom pages", checkPath Arguments.badCustomPages $ Nothing)
+        (Just Path.customArticlesDefaultPages)))
-  ]
+  , ("custom pages, default articles"
+    , (checkPath
+        Arguments.customPagesDefaultArticles
+        (Just Path.customPagesDefaultArticles)))
+  , ("bad custom articles", checkPath Arguments.badCustomArticles $ Nothing)
+  , ("bad custom pages", checkPath Arguments.badCustomPages $ Nothing) ]

test/Tests.hs

@@ -1,14 +0,0 @@
-module Tests (
-    tests
-  ) where
-
-import Distribution.TestSuite
-import qualified Structure (test)
-import Utils (tag)
-import qualified XML.Card (test)
-
-tests :: IO [Test]
-tests = return $ tag "xml" <$> [
-      XML.Card.test
-    , Structure.test
-  ]

test/Utils.hs

@@ -1,49 +1,17 @@
 {-# LANGUAGE NamedFieldPuns #-}
-module Utils (
+module Utils
-      assertAll
+  ( labeled
-    , assertEqual
+  , testDataPath
-    , simpleTest
+  , testGroup ) where
-    , tag
-    , testDataPath
-  ) where
 
-import Distribution.TestSuite
 import System.FilePath ((</>))
-import Text.Printf (printf)
+import Test.HUnit (Test(..))
-
-tagInstance :: String -> TestInstance -> TestInstance
-tagInstance tagName testInstance = testInstance {
-    tags = tagName : (tags testInstance)
-  }
-
-tag :: String -> Test -> Test
-tag tagName (Test testInstance) = Test (tagInstance tagName testInstance)
-tag tagName group = group {groupTests = tag tagName <$> groupTests group}
-
-simpleTest :: (String, IO Progress) -> Test
-simpleTest (name, run) = Test testInstance
-  where
-    testInstance = TestInstance {
-          run
-        , name
-        , tags = []
-        , options = []
-        , setOption = \_ _ -> Right testInstance
-      }
-
-wrong :: Show a => String -> a -> a -> IO Progress
-wrong message expected actual = return . Finished . Fail $
-  printf "%s: %s vs. %s" message (show expected) (show actual)
-
-assertAll :: [(Bool, IO Progress, String)] -> IO Progress
-assertAll = foldr assert (return $ Finished Pass)
-  where
-    assert (bool, badIssue, checkMessage) next =
-      if bool then return $ Progress checkMessage next else badIssue
-
-assertEqual :: (Show a, Eq a) => String -> a -> a -> (Bool, IO Progress, String)
-assertEqual what a b =
-  (a == b, wrong (what ++ " do not match !") a b, what ++ " ok")
 
 testDataPath :: FilePath -> FilePath
 testDataPath = ("test" </>)
+
+testGroup :: String -> [Test] -> Test
+testGroup name = TestLabel name . TestList
+
+labeled :: [(String, Test)] -> [Test]
+labeled = fmap (uncurry TestLabel)

test/XML/Card.hs

@@ -2,10 +2,10 @@ module XML.Card (
     test
   ) where
 
-import Distribution.TestSuite
+import Test.HUnit (Test)
-import Utils (tag)
+import Utils (testGroup)
 import qualified XML.Card.Component as Component (test)
 import qualified XML.Card.Output as Output (test)
 
 test :: Test
-test = tag "card" $ testGroup "Cards" [Component.test, Output.test]
+test = testGroup "Cards" [Component.test, Output.test]

test/XML/Card/Component.hs

@@ -7,83 +7,84 @@ import Blog (Blog)
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Reader (runReaderT)
 import Data.Text (Text)
-import Distribution.TestSuite
 import DOM.Card (HasCard(..))
 import Mock.Blog as Blog (simple)
 import Mock.Article as Article (noDescription, noImage, simple)
 import Mock.ArticlesList as ArticlesList (
     longMain, longTesting, shortMain, shortTesting
   )
-import Utils (assertAll, assertEqual, simpleTest, tag)
+import Test.HUnit (Test(..), assertEqual)
+import Utils (labeled, testGroup)
 
-check :: HasCard a => IO Blog -> a -> (Text, Text, Maybe String, String, String) -> IO Progress
+check :: HasCard a => IO Blog -> a -> (Text, Text, Maybe String, String, String) -> IO ()
 check getBlog input (expectedCT, expectedD, expectedI, expectedT, expectedU) =
-  getBlog >>= runReaderT (
+  getBlog >>= runReaderT checkCard
-      sequence [
+  where
-            assertEqual "card types" expectedCT <$> cardType input
+    checkCard = do
-          , assertEqual "descriptions" expectedD <$> description input
+      liftIO . assertEqual "card types" expectedCT =<< cardType input
-          , assertEqual "images" expectedI <$> image input
+      liftIO . assertEqual "descriptions" expectedD =<< description input
-          , assertEqual "titles" expectedT <$> title input
+      liftIO . assertEqual "images" expectedI =<< image input
-          , assertEqual "urls" expectedU <$> urlPath input
+      liftIO . assertEqual "titles" expectedT =<< title input
-        ] >>= liftIO . assertAll
+      liftIO . assertEqual "urls" expectedU =<< urlPath input
-    )
 
 articleCard :: Test
-articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
+articleCard = testGroup "Article cards" $ labeled
-      ("simple article components", check Blog.simple Article.simple (
+  [ ("simple article components"
-            "article"
+    , TestCase $ check Blog.simple Article.simple
-          , "It's a test"
+        ( "article"
-          , Just "test.png"
+        , "It's a test"
-          , "Some test"
+        , Just "test.png"
-          , "articles/test.html"
+        , "Some test"
-        ))
+        , "articles/test.html" ))
-    , ("article components without description", check Blog.simple Article.noDescription (
+  , ("article components without description"
-            "article"
+    , TestCase $ check Blog.simple Article.noDescription
-          , "A new article on The Test Blog"
+        ( "article"
-          , Just "test.png"
+        , "A new article on The Test Blog"
-          , "Some test"
+        , Just "test.png"
-          , "articles/test.html"
+        , "Some test"
-        ))
+        , "articles/test.html" ))
-    , ("article components without image", check Blog.simple Article.noImage (
+  , ("article components without image"
-            "article"
+    , TestCase $ check Blog.simple Article.noImage
-          , "It's a test"
+        ( "article"
-          , Nothing
+        , "It's a test"
-          , "Some test"
+        , Nothing
-          , "articles/test.html"
+        , "Some test"
-        ))
+        , "articles/test.html" )) ]
-  ]
 
 articlesListCard :: Test
-articlesListCard = tag "articlesList" . testGroup "Articles list cards" $ simpleTest <$> [
+articlesListCard = testGroup "Articles list cards" $ labeled
-      ("short untagged page component", ArticlesList.shortMain >>= (flip (check Blog.simple) (
+  [ ("short untagged page component"
-            "website"
+    , TestCase (ArticlesList.shortMain >>=
-          , "Latest articles"
+                 (flip (check Blog.simple)
-          , Nothing
+                   ( "website"
-          , "The Test Blog"
+                   , "Latest articles"
-          , "index.html"
+                   , Nothing
-        )))
+                   , "The Test Blog"
-    , ("long untagged page component", ArticlesList.longMain >>= (flip (check Blog.simple) (
+                   , "index.html"))))
-            "website"
+    , ("long untagged page component"
-          , "All articles"
+      , TestCase (ArticlesList.longMain >>=
-          , Nothing
+                   (flip (check Blog.simple)
-          , "The Test Blog"
+                     ( "website"
-          , "all.html"
+                     , "All articles"
-        )))
+                     , Nothing
-    , ("short tagged page component", ArticlesList.shortTesting >>= (flip (check Blog.simple) (
+                     , "The Test Blog"
-            "website"
+                     , "all.html"))))
-          , "Latest articles tagged testing"
+    , ("short tagged page component"
-          , Nothing
+      , TestCase (ArticlesList.shortTesting >>=
-          , "The Test Blog - testing"
+                   (flip (check Blog.simple)
-          , "testing/index.html"
+                     ( "website"
-        )))
+                     , "Latest articles tagged testing"
-    , ("long tagged page component", ArticlesList.longTesting >>= (flip (check Blog.simple) (
+                     , Nothing
-            "website"
+                     , "The Test Blog - testing"
-          , "All articles tagged testing"
+                     , "testing/index.html"))))
-          , Nothing
+    , ("long tagged page component"
-          , "The Test Blog - testing"
+      , TestCase (ArticlesList.longTesting >>=
-          , "testing/all.html"
+                   (flip (check Blog.simple)
-        )))
+                     ( "website"
-  ]
+                     , "All articles tagged testing"
+                     , Nothing
+                     , "The Test Blog - testing"
+                     , "testing/all.html")))) ]
 
 test :: Test
-test = tag "component" $ testGroup "Cards components" [articleCard, articlesListCard]
+test = testGroup "Cards components" [articleCard, articlesListCard]

test/XML/Card/Output.hs

@@ -6,7 +6,6 @@ import Blog (Blog(..), URL(..))
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Reader (asks, runReaderT)
 import qualified Data.Text.Lazy.IO as Lazy (readFile)
-import Distribution.TestSuite
 import DOM.Card (HasCard(..), make)
 import Lucid (renderTextT)
 import Mock.Blog as Blog (noCards, simple)
@@ -16,34 +15,47 @@ import Mock.ArticlesList as ArticlesList (
   )
 import Pretty ((.$))
 import System.FilePath ((</>))
-import Utils (assertAll, assertEqual, simpleTest, tag, testDataPath)
+import Test.HUnit (Test(..), assertEqual)
+import Utils (labeled, testDataPath, testGroup)
 
-check :: HasCard a => IO Blog -> a -> FilePath -> IO Progress
+check :: HasCard a => IO Blog -> a -> FilePath -> IO ()
-check getBlog input expectedFile =
+check getBlog input expectedFile = getBlog >>= runReaderT checkHTML
-  getBlog >>= runReaderT (do
+  where
+    checkHTML = do
       actual <- renderTextT $ maybe (return ()) (DOM.Card.make input) =<< (asks $urls.$cards)
       expected <- liftIO . Lazy.readFile $ testDataPath "XML/Card/Output" </> expectedFile
-      liftIO $ assertAll [
+      liftIO $ assertEqual "card HTML output" expected actual
-          assertEqual "card HTML output" expected actual
-        ]
-    )
 
 articleCard :: Test 
-articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
+articleCard = testGroup "Article cards" $ labeled
-      ("simple article output", check Blog.simple Article.simple "simple.html")
+  [ ("simple article output"
-    , ("article output without description", check Blog.simple Article.noDescription "noDescription.html")
+    , TestCase $ check Blog.simple Article.simple "simple.html")
-    , ("article output without image", check Blog.simple Article.noImage "noImage.html")
+  , ("article output without description"
-    , ("no card article output", check Blog.noCards Article.simple "/dev/null")
+    , TestCase $ check Blog.simple Article.noDescription "noDescription.html")
-  ]
+  , ("article output without image"
+    , TestCase $ check Blog.simple Article.noImage "noImage.html")
+  , ("no card article output"
+    , TestCase $ check Blog.noCards Article.simple "/dev/null") ]
 
 articlesListCard :: Test 
-articlesListCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
+articlesListCard = testGroup "Article list cards" $ labeled
-      ("short untagged page output", ArticlesList.shortMain >>= flip (check Blog.simple) "shortMain.html")
+  [ ("short untagged page output"
-    , ("long untagged page output", ArticlesList.longMain >>= flip (check Blog.simple) "longMain.html")
+    , TestCase
-    , ("short tagged page output", ArticlesList.shortTesting >>= flip (check Blog.simple) "shortTesting.html")
+        (ArticlesList.shortMain >>= flip (check Blog.simple) "shortMain.html"))
-    , ("long tagged page output", ArticlesList.longTesting >>= flip (check Blog.simple) "longTesting.html")
+  , ("long untagged page output"
-    , ("no card articlesList output", ArticlesList.shortMain >>= flip (check Blog.noCards) "/dev/null")
+    , TestCase
-  ]
+        (ArticlesList.longMain >>= flip (check Blog.simple) "longMain.html"))
+  , ("short tagged page output"
+    , TestCase
+        (ArticlesList.shortTesting
+          >>= flip (check Blog.simple) "shortTesting.html"))
+  , ("long tagged page output"
+    , TestCase
+        (ArticlesList.longTesting
+          >>= flip (check Blog.simple) "longTesting.html"))
+  , ("no card articlesList output"
+    , TestCase
+        (ArticlesList.shortMain >>= flip (check Blog.noCards) "/dev/null")) ]
 
 test :: Test
-test = tag "output" $ testGroup "Cards outputs" [articleCard, articlesListCard]
+test = testGroup "Cards outputs" [articleCard, articlesListCard]