69 lines
2.2 KiB
Haskell
69 lines
2.2 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module XML.Card (
|
|
test
|
|
) where
|
|
|
|
import Article (Article(..))
|
|
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, noMeta, simple)
|
|
import Text.Printf (printf)
|
|
|
|
simpleTest :: [String] -> (String, IO Progress) -> Test
|
|
simpleTest tags (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")
|
|
|
|
checkCard :: Blog -> Article -> (Text, Text, Maybe String, String, String) -> IO Progress
|
|
checkCard blog article (expectedCT, expectedD, expectedI, expectedT, expectedU) =
|
|
flip runReaderT blog $
|
|
sequence [
|
|
assertEqual "card types" expectedCT <$> cardType article
|
|
, assertEqual "descriptions" expectedD <$> description article
|
|
, assertEqual "images" expectedI <$> image article
|
|
, assertEqual "titles" expectedT <$> title article
|
|
, assertEqual "urls" expectedU <$> urlPath article
|
|
] >>= liftIO . assertAll
|
|
|
|
articleCard :: Test
|
|
articleCard =
|
|
testGroup "Article cards" $ simpleTest ["xml", "card", "article"] <$> [
|
|
("simple article", checkCard Blog.simple Article.simple (
|
|
"article"
|
|
, "It's a test"
|
|
, Just "test.png"
|
|
, "Some test"
|
|
, "https://test.net/articles/test.html"
|
|
)
|
|
)
|
|
]
|
|
|
|
test :: Test
|
|
test = testGroup "Cards" [articleCard]
|