From 6002f7c4d6095697a1f6a3a23b957d331579b235 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Mon, 8 Jun 2020 22:45:16 +0200 Subject: [PATCH] Lay the basis for a very simple test suite --- hablo.cabal | 33 ++++++++++++++++++--- test/Mock/Article.hs | 53 ++++++++++++++++++++++++++++++++++ test/Mock/Blog.hs | 8 ++++++ test/Tests.hs | 11 +++++++ test/XML/Card.hs | 68 ++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 169 insertions(+), 4 deletions(-) create mode 100644 test/Mock/Article.hs create mode 100644 test/Mock/Blog.hs create mode 100644 test/Tests.hs create mode 100644 test/XML/Card.hs diff --git a/hablo.cabal b/hablo.cabal index d367483..a712ee0 100644 --- a/hablo.cabal +++ b/hablo.cabal @@ -27,9 +27,8 @@ data-dir: share data-files: js/*.js defaultWording.conf -executable hablo - main-is: Main.hs - other-modules: Arguments +library hablo-internals + exposed-modules: Arguments , Article , ArticlesList , Blog @@ -66,6 +65,32 @@ executable hablo , time >= 1.8.0 && < 1.9 , SJW >= 0.1.2 && < 0.2 , unix >= 2.7.2 && < 2.8 - ghc-options: -Wall -dynamic + ghc-options: -Wall hs-source-dirs: src default-language: Haskell2010 + +executable hablo + main-is: src/Main.hs + other-modules: Paths_hablo + -- other-extensions: + build-depends: base >= 4.9.1 && < 4.13 + , hablo-internals + , mtl >= 2.2.2 && < 2.3 + ghc-options: -Wall -dynamic + default-language: Haskell2010 + +test-suite tests + type: detailed-0.9 + test-module: Tests + other-modules: Mock.Article + , Mock.Blog + , XML.Card + build-depends: base + , containers + , Cabal + , hablo-internals + , mtl + , text + hs-source-dirs: test + ghc-options: -Wall + default-language: Haskell2010 diff --git a/test/Mock/Article.hs b/test/Mock/Article.hs new file mode 100644 index 0000000..6a4d1fb --- /dev/null +++ b/test/Mock/Article.hs @@ -0,0 +1,53 @@ +module Mock.Article ( + noDescription + , noImage + , noMeta + , simple + ) where + +import Article (Article(..)) +import qualified Data.Map as Map (fromList) +import Markdown (Markdown(..)) + +simple :: Article +simple = Article (Markdown { + key = "test" + , path = "article/test" + , Markdown.title = "Some test" + , metadata = Map.fromList [ + ("summary", "It's a test") + , ("featuredImage", "test.png") + ] + , bodyOffset = 3 + , body = [] + }) + +noImage :: Article +noImage = Article (Markdown { + key = "test" + , path = "article/test" + , Markdown.title = "Some test" + , metadata = Map.fromList [("summary", "It's a test")] + , bodyOffset = 3 + , body = [] + }) + +noDescription :: Article +noDescription = Article (Markdown { + key = "test" + , path = "article/test" + , Markdown.title = "Some test" + , metadata = Map.fromList [("featuredImage", "test.png")] + , bodyOffset = 3 + , body = [] + }) + +noMeta :: Article +noMeta = Article (Markdown { + key = "test" + , path = "article/test" + , Markdown.title = "Some test" + , metadata = Map.fromList [] + , bodyOffset = 3 + , body = [] + }) diff --git a/test/Mock/Blog.hs b/test/Mock/Blog.hs new file mode 100644 index 0000000..4d471d2 --- /dev/null +++ b/test/Mock/Blog.hs @@ -0,0 +1,8 @@ +module Mock.Blog ( + simple + ) where + +import Blog (Blog) + +simple :: Blog +simple = undefined diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 index 0000000..8963e28 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,11 @@ +module Tests ( + tests + ) where + +import Distribution.TestSuite +import qualified XML.Card (test) + +tests :: IO [Test] +tests = return [ + XML.Card.test + ] diff --git a/test/XML/Card.hs b/test/XML/Card.hs new file mode 100644 index 0000000..12673d0 --- /dev/null +++ b/test/XML/Card.hs @@ -0,0 +1,68 @@ +{-# 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]