Tissevert/hablo
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Port test to HUnit

Browse source
This commit is contained in:
Tissevert 2023-08-20 22:24:58 +02:00
parent 111c6ca3f7
commit feb647bcb4
10 changed files with 159 additions and 178 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

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

4
guix.scm
View file

@ -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

6
hablo.cabal
View file

@ -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

10
test/Main.hs Normal file
View file

@ -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 ]

37
test/Structure.hs
View file

@ -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)
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 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)
, (checkPath
Arguments.customArticlesDefaultPages
(Just Path.customArticlesDefaultPages)))
, ("custom pages, default articles"
, checkPath Arguments.customPagesDefaultArticles $ Just Path.customPagesDefaultArticles)
, (checkPath
Arguments.customPagesDefaultArticles
(Just Path.customPagesDefaultArticles)))
, ("bad custom articles", checkPath Arguments.badCustomArticles $ Nothing)
, ("bad custom pages", checkPath Arguments.badCustomPages $ Nothing)
]
, ("bad custom pages", checkPath Arguments.badCustomPages $ Nothing) ]

14
test/Tests.hs
View file

@ -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
]

52
test/Utils.hs
View file

@ -1,49 +1,17 @@
{-# LANGUAGE NamedFieldPuns #-}
module Utils (
assertAll
, assertEqual
, simpleTest
, tag
module Utils
( labeled
, testDataPath
) where
, 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)

6
test/XML/Card.hs
View file

@ -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]

91
test/XML/Card/Component.hs
View file

@ -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"
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", check Blog.simple Article.noDescription (
"article"
, "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", check Blog.simple Article.noImage (
"article"
, "articles/test.html" ))
, ("article components without image"
, TestCase $ check Blog.simple Article.noImage
( "article"
, "It's a test"
, Nothing
, "Some test"
, "articles/test.html"
))
]
, "articles/test.html" )) ]
articlesListCard :: Test
articlesListCard = tag "articlesList" . testGroup "Articles list cards" $ simpleTest <$> [
("short untagged page component", ArticlesList.shortMain >>= (flip (check Blog.simple) (
"website"
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", ArticlesList.longMain >>= (flip (check Blog.simple) (
"website"
, "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", ArticlesList.shortTesting >>= (flip (check Blog.simple) (
"website"
, "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", ArticlesList.longTesting >>= (flip (check Blog.simple) (
"website"
, "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"
)))
]
, "testing/all.html")))) ]
test :: Test
test = tag "component" $ testGroup "Cards components" [articleCard, articlesListCard]
test = testGroup "Cards components" [articleCard, articlesListCard]

58
test/XML/Card/Output.hs
View file

@ -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]