Add more article card tests and articlesList card tests

hablo.cabal

@@ -83,10 +83,20 @@ test-suite tests
   type:                detailed-0.9
   test-module:         Tests
   other-modules:       Mock.Article
+                     , Mock.ArticlesList
                      , Mock.Blog
+                     , Mock.Blog.Path
+                     , Mock.Blog.Skin
+                     , Mock.Blog.Template
+                     , Mock.Blog.URL
+                     , Mock.Blog.Wording
+                     , Mock.Collection
+                     , Mock.Markdown
+                     , Utils
                      , XML.Card
   build-depends:       base
                      , containers
+                     , filepath
                      , Cabal
                      , hablo-internals
                      , mtl

test/Mock/Article.hs

@@ -8,46 +8,16 @@ module Mock.Article (
 import Article (Article(..))
 import qualified Data.Map as Map (fromList)
 import Markdown (Markdown(..))
+import Mock.Markdown (article)
 
 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 = []
-  })
+simple = Article article
 
 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 = []
-  })
+noImage = Article $ article {metadata = Map.fromList [("summary", "It's a test")]}
 
 noDescription :: Article
-noDescription = Article (Markdown {
-      key = "test"
-    , path = "article/test"
-    , Markdown.title = "Some test"
-    , metadata = Map.fromList [("featuredImage", "test.png")]
-    , bodyOffset = 3
-    , body = []
-  })
+noDescription = Article $ article {metadata = Map.fromList [("featuredImage", "test.png")]}
 
 noMeta :: Article
-noMeta = Article (Markdown {
-      key = "test"
-    , path = "article/test"
-    , Markdown.title = "Some test"
-    , metadata = Map.fromList []
-    , bodyOffset = 3
-    , body = []
-  })
+noMeta = Article $ article {metadata = Map.fromList []}

test/Mock/ArticlesList.hs

@@ -0,0 +1,22 @@
+module Mock.ArticlesList (
+      longMain
+    , longTesting
+    , shortMain
+    , shortTesting
+  ) where
+
+import ArticlesList (ArticlesList(..))
+import Mock.Collection (main, testing)
+import Prelude hiding (all)
+
+shortMain :: IO ArticlesList
+shortMain = ArticlesList False <$> main
+
+shortTesting :: IO ArticlesList
+shortTesting = ArticlesList False <$> testing
+
+longMain :: IO ArticlesList
+longMain = ArticlesList True <$> main
+
+longTesting :: IO ArticlesList
+longTesting = ArticlesList True <$> testing

test/Mock/Blog.hs

@@ -1,8 +1,35 @@
+{-# LANGUAGE NamedFieldPuns #-}
 module Mock.Blog (
-    simple
+      simple
+    , noRSS
   ) where
 
-import Blog (Blog)
+import Blog (Blog(..))
+import qualified Data.Map as Map (fromList)
+import qualified Data.Set as Set (fromList)
+import qualified Mock.Article (simple)
+import qualified Mock.Blog.Path (simple)
+import qualified Mock.Blog.Skin (simple)
+import qualified Mock.Blog.Template (simple)
+import qualified Mock.Blog.URL (simple)
+import qualified Mock.Blog.Wording (defaultWording)
 
-simple :: Blog
-simple = undefined
+simple :: IO Blog
+simple =
+  let wording = Mock.Blog.Wording.defaultWording in do
+  templates <- Mock.Blog.Template.simple
+  return $ Blog {
+        articles = Map.fromList [("test", Mock.Article.simple)]
+      , hasRSS = True
+      , name = "The Test Blog"
+      , pages = Map.fromList []
+      , path = Mock.Blog.Path.simple
+      , skin = Mock.Blog.Skin.simple
+      , tags = Map.fromList [("testing", Set.fromList ["test"])]
+      , templates
+      , urls = Mock.Blog.URL.simple
+      , wording
+    }
+
+noRSS :: IO Blog
+noRSS = (\b -> b {hasRSS = False}) <$> simple

test/Mock/Blog/Path.hs

@@ -0,0 +1,13 @@
+module Mock.Blog.Path (
+    simple
+  ) where
+
+import Blog.Path (Path(..))
+
+simple :: Path
+simple = Path {
+      articlesPath = "articles"
+    , pagesPath = Nothing
+    , remarkableConfig = Nothing
+    , root = "/home/test/blog"
+  }

test/Mock/Blog/Skin.hs

@@ -0,0 +1,16 @@
+module Mock.Blog.Skin (
+    simple
+  ) where
+
+import Blog.Skin (Skin(..))
+import Prelude hiding (head)
+
+simple :: Skin
+simple = Skin {
+      banner = Nothing
+    , cardImage = Nothing
+    , favicon = Nothing
+    , head = Nothing
+    , previewArticlesCount = 3
+    , previewLinesCount = 10
+  }

test/Mock/Blog/Template.hs

@@ -0,0 +1,9 @@
+module Mock.Blog.Template (
+    simple
+  ) where
+
+import Blog.Template (Templates, build)
+import Mock.Blog.Wording (defaultWording)
+
+simple :: IO Templates
+simple = build Mock.Blog.Wording.defaultWording

test/Mock/Blog/URL.hs

@@ -0,0 +1,12 @@
+module Mock.Blog.URL (
+    simple
+  ) where
+
+import Blog.URL (URL(..))
+
+simple :: URL
+simple = URL {
+      cards = Nothing
+    , comments = Nothing
+    , rss = Nothing
+  }

test/Mock/Blog/Wording.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Mock.Blog.Wording (
+    defaultWording
+  ) where
+
+import Blog.Wording (Wording(..))
+import qualified Data.Map as Map (fromList)
+
+defaultWording :: Wording
+defaultWording = Wording $ Map.fromList [
+      ("allLink", "See all")
+    , ("allPage", "All articles{? tagged ${tag}?}")
+    , ("commentsLink", "Comment on the fediverse")
+    , ("commentsSection", "Comments")
+    , ("dateFormat", "en-US")
+    , ("latestLink", "See only latest")
+    , ("latestPage", "Latest articles{? tagged ${tag}?}")
+    , ("metadata", "{?by ${author} ?}on ${date}{? tagged ${tags}?}")
+    , ("rssLink", "Subscribe")
+    , ("rssTitle", "Follow all articles{? tagged ${tag}?}")
+    , ("tagsList", "Tags")
+  ]

test/Mock/Collection.hs

@@ -0,0 +1,28 @@
+module Mock.Collection (
+      main
+    , testing
+  ) where
+
+import Blog (Blog(..), Path(..))
+import Collection (Collection(..))
+import Data.Map as Map (elems)
+import qualified Mock.Blog (simple)
+import System.FilePath ((</>))
+
+main :: IO Collection
+main = do
+  blog <- Mock.Blog.simple
+  return $ Collection {
+      featured = Map.elems $ articles blog
+    , basePath = root $ path blog
+    , tag = Nothing
+  }
+
+testing :: IO Collection
+testing = do
+  blog <- Mock.Blog.simple
+  return $ Collection {
+      featured = Map.elems $ articles blog
+    , basePath = root (path blog) </> "testing"
+    , tag = Just "testing"
+  }

test/Mock/Markdown.hs

@@ -0,0 +1,33 @@
+module Mock.Markdown (
+      article
+    , page
+  ) where
+
+import qualified Data.Map as Map (fromList)
+import Markdown (Markdown(..))
+
+article :: Markdown
+article = Markdown {
+      key = "test"
+    , path = "articles/test"
+    , Markdown.title = "Some test"
+    , metadata = Map.fromList [
+            ("summary", "It's a test")
+          , ("featuredImage", "test.png")
+        ]
+    , bodyOffset = 3
+    , body = []
+  }
+
+page :: Markdown
+page = Markdown {
+      key = "test"
+    , path = "pages/test"
+    , Markdown.title = "A test page"
+    , metadata = Map.fromList [
+            ("summary", "Tests are useful")
+          , ("featuredImage", "test.png")
+        ]
+    , bodyOffset = 3
+    , body = []
+  }

test/Tests.hs

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

test/Utils.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Utils (
+      assertAll
+    , assertEqual
+    , simpleTest
+    , tag
+  ) where
+
+import Distribution.TestSuite
+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")
+

test/XML/Card.hs

@@ -1,10 +1,8 @@
-{-# 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)
@@ -12,57 +10,87 @@ 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)
+import Mock.Article as Article (noDescription, noImage, simple)
+import Mock.ArticlesList as ArticlesList (
+    longMain, longTesting, shortMain, shortTesting
+  )
+import Utils (assertAll, assertEqual, simpleTest, tag)
 
-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
+checkCard :: HasCard a => IO Blog -> a -> (Text, Text, Maybe String, String, String) -> IO Progress
+checkCard 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
+    )
 
 articleCard :: Test
-articleCard =
-  testGroup "Article cards" $ simpleTest ["xml", "card", "article"] <$> [
+articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
       ("simple article", checkCard Blog.simple Article.simple (
               "article"
             , "It's a test"
             , Just "test.png"
             , "Some test"
-            , "https://test.net/articles/test.html"
+            , "articles/test.html"
           )
         )
-    ]
+    , ("article without description", checkCard Blog.simple Article.noDescription (
+              "article"
+            , "A new article on The Test Blog"
+            , Just "test.png"
+            , "Some test"
+            , "articles/test.html"
+          )
+        )
+    , ("article without image", checkCard 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", ArticlesList.shortMain >>= (flip (checkCard Blog.simple) (
+              "website"
+            , "Latest articles"
+            , Nothing
+            , "The Test Blog"
+            , "index.html"
+          )
+        ))
+    , ("long untagged page", ArticlesList.longMain >>= (flip (checkCard Blog.simple) (
+              "website"
+            , "All articles"
+            , Nothing
+            , "The Test Blog"
+            , "all.html"
+          )
+        ))
+    , ("short tagged page", ArticlesList.shortTesting >>= (flip (checkCard Blog.simple) (
+              "website"
+            , "Latest articles tagged testing"
+            , Nothing
+            , "The Test Blog - testing"
+            , "testing/index.html"
+          )
+        ))
+    , ("long tagged page", ArticlesList.longTesting >>= (flip (checkCard Blog.simple) (
+              "website"
+            , "All articles tagged testing"
+            , Nothing
+            , "The Test Blog - testing"
+            , "testing/all.html"
+          )
+        ))
+  ]
 
 test :: Test
-test = testGroup "Cards" [articleCard]
+test = tag "card" $ testGroup "Cards" [articleCard, articlesListCard]