From feb647bcb4bcecf631ec6eca822c3557ac12b3eb Mon Sep 17 00:00:00 2001 From: Tissevert Date: Sun, 20 Aug 2023 22:24:58 +0200 Subject: [PATCH] Port test to HUnit --- .gitignore | 1 + guix.scm | 4 +- hablo.cabal | 6 +- test/Main.hs | 10 +++ test/Structure.hs | 51 +++++++------- test/Tests.hs | 14 ---- test/Utils.hs | 54 +++------------ test/XML/Card.hs | 6 +- test/XML/Card/Component.hs | 133 +++++++++++++++++++------------------ test/XML/Card/Output.hs | 58 +++++++++------- 10 files changed, 159 insertions(+), 178 deletions(-) create mode 100644 test/Main.hs delete mode 100644 test/Tests.hs diff --git a/.gitignore b/.gitignore index c71fc18..6bfb3cc 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,4 @@ .ghc.environment.* *.o *.hi +Main diff --git a/guix.scm b/guix.scm index f594d8d..4f97a76 100644 --- a/guix.scm +++ b/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 diff --git a/hablo.cabal b/hablo.cabal index 9af0ddf..8c2ce19 100644 --- a/hablo.cabal +++ b/hablo.cabal @@ -76,8 +76,8 @@ executable hablo default-language: Haskell2010 test-suite tests - type: detailed-0.9 - test-module: Tests + type: exitcode-stdio-1.0 + 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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..c609657 --- /dev/null +++ b/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 ] diff --git a/test/Structure.hs b/test/Structure.hs index 1d77af4..b3f9884 100644 --- a/test/Structure.hs +++ b/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 input expected = do - withCurrentDirectory root $ do - actual <- either (\_ -> Nothing) Just <$> Path.build root input - return . Finished $ - if actual == expected - then Pass - else Fail $ "Expected " ++ show expected ++ " but got " ++ show actual +checkPath :: Arguments -> Maybe Path -> Test +checkPath input expected = TestCase . withCurrentDirectory root $ + either (\_ -> Nothing) Just <$> Path.build root input + >>= assertEqual "Incorrect path detected by hablo" expected where root = sourceDir input test :: Test -test = tag "structure" . testGroup "Blog structure" $ simpleTest <$> [ - ("empty structure", checkPath Arguments.emptyBlog Nothing) - , ("default articles", checkPath Arguments.defaultArticles $ Just Path.defaultArticles) - , ("default pages", checkPath Arguments.defaultPages $ Just Path.defaultPages) - , ("both default", checkPath Arguments.bothDefault $ Just Path.bothDefault) - , ("custom articles", checkPath Arguments.customArticles $ Just Path.customArticles) - , ("custom pages", checkPath Arguments.customPages $ Just Path.customPages) - , ("both custom", checkPath Arguments.bothCustom $ Just Path.bothCustom) - , ("custom articles, default pages" - , checkPath Arguments.customArticlesDefaultPages $ 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 = testGroup "Blog structure" $ labeled + [ ("empty structure", checkPath Arguments.emptyBlog Nothing) + , ("default articles" + , checkPath Arguments.defaultArticles $ Just Path.defaultArticles) + , ("default pages", checkPath Arguments.defaultPages $ Just Path.defaultPages) + , ("both default", checkPath Arguments.bothDefault $ Just Path.bothDefault) + , ("custom articles" + , checkPath Arguments.customArticles $ Just Path.customArticles) + , ("custom pages", checkPath Arguments.customPages $ Just Path.customPages) + , ("both custom", checkPath Arguments.bothCustom $ Just Path.bothCustom) + , ("custom articles, default pages" + , (checkPath + Arguments.customArticlesDefaultPages + (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) ] diff --git a/test/Tests.hs b/test/Tests.hs deleted file mode 100644 index 1be31f5..0000000 --- a/test/Tests.hs +++ /dev/null @@ -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 - ] diff --git a/test/Utils.hs b/test/Utils.hs index a4b2a9f..ea10894 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -1,49 +1,17 @@ {-# LANGUAGE NamedFieldPuns #-} -module Utils ( - assertAll - , assertEqual - , simpleTest - , tag - , testDataPath - ) where +module Utils + ( labeled + , testDataPath + , testGroup ) where -import Distribution.TestSuite import System.FilePath (()) -import Text.Printf (printf) - -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") +import Test.HUnit (Test(..)) testDataPath :: FilePath -> FilePath testDataPath = ("test" ) + +testGroup :: String -> [Test] -> Test +testGroup name = TestLabel name . TestList + +labeled :: [(String, Test)] -> [Test] +labeled = fmap (uncurry TestLabel) diff --git a/test/XML/Card.hs b/test/XML/Card.hs index 315ade7..c3aace4 100644 --- a/test/XML/Card.hs +++ b/test/XML/Card.hs @@ -2,10 +2,10 @@ module XML.Card ( test ) where -import Distribution.TestSuite -import Utils (tag) +import Test.HUnit (Test) +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] diff --git a/test/XML/Card/Component.hs b/test/XML/Card/Component.hs index db5a4bc..f4a771f 100644 --- a/test/XML/Card/Component.hs +++ b/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 ( - sequence [ - assertEqual "card types" expectedCT <$> cardType input - , assertEqual "descriptions" expectedD <$> description input - , assertEqual "images" expectedI <$> image input - , assertEqual "titles" expectedT <$> title input - , assertEqual "urls" expectedU <$> urlPath input - ] >>= liftIO . assertAll - ) + getBlog >>= runReaderT checkCard + where + checkCard = do + liftIO . assertEqual "card types" expectedCT =<< cardType input + liftIO . assertEqual "descriptions" expectedD =<< description input + liftIO . assertEqual "images" expectedI =<< image input + liftIO . assertEqual "titles" expectedT =<< title input + liftIO . assertEqual "urls" expectedU =<< urlPath input articleCard :: Test -articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [ - ("simple article components", check Blog.simple Article.simple ( - "article" - , "It's a test" - , Just "test.png" - , "Some test" - , "articles/test.html" - )) - , ("article components without description", check Blog.simple Article.noDescription ( - "article" - , "A new article on The Test Blog" - , Just "test.png" - , "Some test" - , "articles/test.html" - )) - , ("article components without image", check Blog.simple Article.noImage ( - "article" - , "It's a test" - , Nothing - , "Some test" - , "articles/test.html" - )) - ] +articleCard = testGroup "Article cards" $ labeled + [ ("simple article components" + , TestCase $ check Blog.simple Article.simple + ( "article" + , "It's a test" + , Just "test.png" + , "Some test" + , "articles/test.html" )) + , ("article components without description" + , TestCase $ check Blog.simple Article.noDescription + ( "article" + , "A new article on The Test Blog" + , Just "test.png" + , "Some test" + , "articles/test.html" )) + , ("article components without image" + , TestCase $ check Blog.simple Article.noImage + ( "article" + , "It's a test" + , Nothing + , "Some test" + , "articles/test.html" )) ] articlesListCard :: Test -articlesListCard = tag "articlesList" . testGroup "Articles list cards" $ simpleTest <$> [ - ("short untagged page component", ArticlesList.shortMain >>= (flip (check Blog.simple) ( - "website" - , "Latest articles" - , Nothing - , "The Test Blog" - , "index.html" - ))) - , ("long untagged page component", ArticlesList.longMain >>= (flip (check Blog.simple) ( - "website" - , "All articles" - , Nothing - , "The Test Blog" - , "all.html" - ))) - , ("short tagged page component", ArticlesList.shortTesting >>= (flip (check Blog.simple) ( - "website" - , "Latest articles tagged testing" - , Nothing - , "The Test Blog - testing" - , "testing/index.html" - ))) - , ("long tagged page component", ArticlesList.longTesting >>= (flip (check Blog.simple) ( - "website" - , "All articles tagged testing" - , Nothing - , "The Test Blog - testing" - , "testing/all.html" - ))) - ] +articlesListCard = testGroup "Articles list cards" $ labeled + [ ("short untagged page component" + , TestCase (ArticlesList.shortMain >>= + (flip (check Blog.simple) + ( "website" + , "Latest articles" + , Nothing + , "The Test Blog" + , "index.html")))) + , ("long untagged page component" + , TestCase (ArticlesList.longMain >>= + (flip (check Blog.simple) + ( "website" + , "All articles" + , Nothing + , "The Test Blog" + , "all.html")))) + , ("short tagged page component" + , TestCase (ArticlesList.shortTesting >>= + (flip (check Blog.simple) + ( "website" + , "Latest articles tagged testing" + , Nothing + , "The Test Blog - testing" + , "testing/index.html")))) + , ("long tagged page component" + , TestCase (ArticlesList.longTesting >>= + (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] diff --git a/test/XML/Card/Output.hs b/test/XML/Card/Output.hs index c3fb71a..266831f 100644 --- a/test/XML/Card/Output.hs +++ b/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 getBlog input expectedFile = - getBlog >>= runReaderT (do +check :: HasCard a => IO Blog -> a -> FilePath -> IO () +check getBlog input expectedFile = getBlog >>= runReaderT checkHTML + 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 [ - assertEqual "card HTML output" expected actual - ] - ) + liftIO $ assertEqual "card HTML output" expected actual articleCard :: Test -articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [ - ("simple article output", check Blog.simple Article.simple "simple.html") - , ("article output without description", check Blog.simple Article.noDescription "noDescription.html") - , ("article output without image", check Blog.simple Article.noImage "noImage.html") - , ("no card article output", check Blog.noCards Article.simple "/dev/null") - ] +articleCard = testGroup "Article cards" $ labeled + [ ("simple article output" + , TestCase $ check Blog.simple Article.simple "simple.html") + , ("article output without description" + , 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 <$> [ - ("short untagged page output", ArticlesList.shortMain >>= flip (check Blog.simple) "shortMain.html") - , ("long untagged page output", ArticlesList.longMain >>= flip (check Blog.simple) "longMain.html") - , ("short tagged page output", ArticlesList.shortTesting >>= flip (check Blog.simple) "shortTesting.html") - , ("long tagged page output", ArticlesList.longTesting >>= flip (check Blog.simple) "longTesting.html") - , ("no card articlesList output", ArticlesList.shortMain >>= flip (check Blog.noCards) "/dev/null") - ] +articlesListCard = testGroup "Article list cards" $ labeled + [ ("short untagged page output" + , TestCase + (ArticlesList.shortMain >>= flip (check Blog.simple) "shortMain.html")) + , ("long untagged page output" + , 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]