.gitignore

@@ -1,5 +1,2 @@
 /dist-newstyle/*
 .ghc.environment.*
-*.o
-*.hi
-Main

README.md

@@ -62,18 +62,6 @@ mkdir -p ~/.sjw
 cp -r src/ ~/.sjw/unitJS
 ```
 
-Then, the static data used by hablo need to be available in a XDG path. Depending on whether you are installing for your user or system-wide, you may want to perform something either
-
-```bash
-cp -R share ~/.local/share/hablo
-```
-
-or
-
-```bash
-sudo cp -R share /usr/local/share/hablo
-```
-
 ### Using hablo (tutorials)
 
 Wanna give it a try ? Start by [generating your blog](https://git.marvid.fr/Tissevert/hablo/wiki/Generating%20your%20blog)

ghc-template.scm

@@ -1,7 +1,11 @@
-(use-modules ((guix build-system haskell) #:select (hackage-uri haskell-build-system))
+(use-modules (gnu packages haskell-xyz)
-             ((guix download) #:select (url-fetch))
+             (gnu packages haskell-web)
-             ((guix licenses) #:select (bsd-3))
+             (guix build-system haskell)
-             ((guix packages) #:select (base32 origin package)))
+             (guix download)
+             (guix gexp)
+             (guix git-download)
+             (guix licenses)
+             (guix packages))
 
 (package
   (name "ghc-template")

guix.scm

@@ -1,5 +1,4 @@
-(use-modules (gnu packages haskell-check)
+(use-modules (gnu packages haskell-xyz)
-             (gnu packages haskell-xyz)
              (gnu packages haskell-web)
              (guix build-system haskell)
              (guix download)
@@ -20,11 +19,9 @@
           #:recursive? #t
           #:select? (git-predicate %source-dir)))
     (build-system haskell-build-system)
-    (propagated-inputs (list sjw-unitjs))
     (inputs
       (list ghc-aeson
             ghc-attoparsec
-            ghc-hunit
             ghc-lucid
             ghc-optparse-applicative
             ghc-parsec
@@ -32,19 +29,10 @@
             ghc-sjw
             ghc-template
             ghc-xdg-basedir))
-    (arguments
-      `(#:phases
-        (modify-phases %standard-phases
-          (add-after 'install 'copy-static-resources
-            (lambda* (#:key outputs #:allow-other-keys)
-              (let ((out (assoc-ref outputs "out")))
-                (copy-recursively "share" (string-append out "/share/hablo"))))))))
     (native-search-paths
       (list
         (search-path-specification (variable "SJW_PATH")
-                                   (files '("lib/SJW")))
+                                   (files '("lib/SJW")))))
-        (search-path-specification (variable "XDG_DATA_DIRS")
-                                   (files '("share")))))
     (home-page "https://git.marvid.fr/Tissevert/SJW")
     (synopsis "The Simple Javascript Wrench")
     (description

hablo.cabal

@@ -23,6 +23,9 @@ maintainer:          tissevert+devel@marvid.fr
 category:            Web
 extra-source-files:  CHANGELOG.md
 build-type:          Simple
+data-dir:            share
+data-files:          js/*.js
+                     defaultWording.conf
 
 library
   exposed-modules:     Arguments
@@ -43,6 +46,7 @@ library
                      , JSON
                      , Markdown
                      , Page
+                     , Paths_hablo
                      , Pretty
                      , RSS
   -- other-extensions:
@@ -61,13 +65,13 @@ library
                      , time >= 1.8.0 && < 1.12
                      , SJW >= 0.1.2 && < 0.2
                      , unix >= 2.7.2 && < 2.8
-                     , xdg-basedir >= 0.2.2 && < 0.3
   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
                      , hablo
@@ -76,8 +80,8 @@ executable hablo
   default-language:    Haskell2010
 
 test-suite tests
-  type:                exitcode-stdio-1.0
+  type:                detailed-0.9
-  main-is:             Main.hs
+  test-module:         Tests
   other-modules:       Mock.Arguments
                      , Mock.Article
                      , Mock.ArticlesList
@@ -95,11 +99,11 @@ test-suite tests
                      , XML.Card.Component
                      , XML.Card.Output
   build-depends:       base
+                     , Cabal
                      , containers
                      , directory
                      , filepath
                      , hablo
-                     , HUnit
                      , lucid
                      , mtl
                      , text

src/Arguments.hs

@@ -2,23 +2,22 @@
 module Arguments (
       Arguments(..)
     , get
-    , version
   ) where
 
 #if !MIN_VERSION_base(4,11,0)
 import Data.Monoid ((<>))
 #endif
-import Control.Applicative ((<**>), optional)
+import Data.Version (showVersion)
-import Options.Applicative
+import Control.Applicative ((<|>), (<**>), optional)
-  ( Parser, ReadM, argument, auto, eitherReader, execParser, fullDesc, header
+import Options.Applicative (
-  , help, helper, info, infoOption, long, metavar, short, str, switch, value )
+      Parser, ReadM, argument, auto, eitherReader, execParser, flag', fullDesc
+    , header, help, helper, info, long, metavar, short, str, switch, value
+  )
 import qualified Options.Applicative as Optparse (option)
+import qualified Paths_hablo as Hablo (version)
 import System.FilePath (dropTrailingPathSeparator, isValid)
 
-version :: String
+data Arguments = BlogConfig {
-version = "0.3.0.0"
-
-data Arguments = Arguments {
       sourceDir :: FilePath
     , articlesPath :: Maybe FilePath
     , bannerPath :: Maybe FilePath
@@ -36,6 +35,7 @@ data Arguments = Arguments {
     , siteURL :: Maybe String
     , wording :: Maybe FilePath
   }
+  | Version
 
 option :: ReadM a -> Char -> String -> String -> String -> Parser (Maybe a)
 option readM aShort aLong aMetavar aHelpMessage =
@@ -47,8 +47,8 @@ option readM aShort aLong aMetavar aHelpMessage =
       <> help aHelpMessage
     )
 
-arguments :: Parser Arguments
+blogConfig :: Parser Arguments
-arguments = Arguments
+blogConfig = BlogConfig
   <$> argument filePath (value "." <> metavar "INPUT_DIR")
   <*> option filePath 'a' "articles" "DIRECTORY"
         "relative path to the directory containing the articles within INPUT_DIR"
@@ -81,6 +81,16 @@ arguments = Arguments
   <*> option filePath 'u' "site-url" "URL" "URL where the blog is published"
   <*> option filePath 'w' "wording" "FILE" "path to the file containing the wording to use"
 
+version :: Parser Arguments
+version = flag' Version (
+      long "version"
+    <> short 'v'
+    <> help "print the version number"
+  )
+
+arguments :: Parser Arguments
+arguments = blogConfig <|> version
+
 filePath :: ReadM FilePath
 filePath = eitherReader $ \path ->
   if isValid path
@@ -88,10 +98,8 @@ filePath = eitherReader $ \path ->
     else Left "This string doesn't represent a valid path"
 
 get :: IO Arguments
-get = execParser
+get = do
-  (info (arguments <**> showVersion <**> helper)
+  execParser $
-        (fullDesc <> header ("Hablo v" ++ version)))
+    info
-  where
+      (arguments <**> helper)
-    showVersion = infoOption
+      (fullDesc <> header ("Hablo v" ++ showVersion Hablo.version))
-      version
-      (long "version" <> short 'v' <> help "print current version")

src/Blog/Wording.hs

@@ -12,7 +12,7 @@ import Data.Map (Map)
 import qualified Data.Map as Map (empty, fromList, keys, map, union)
 import Data.Text (Text)
 import qualified Data.Text as Text (pack)
-import Files (getXDGData)
+import Paths_hablo (getDataFileName)
 import Text.ParserCombinators.Parsec (
       Parser
     , (<|>)
@@ -64,6 +64,6 @@ wordingP = Map.map Text.pack . Map.fromList <$>
 
 build :: Arguments -> IO Wording
 build arguments = do
-  defaultWording <- getXDGData "defaultWording.conf"
+  defaultWording <- getDataFileName "defaultWording.conf"
   let wordingFiles = maybe id (:) (wording arguments) $ [defaultWording]
   Wording <$> foldM addWording Map.empty wordingFiles

src/Files.hs

@@ -3,12 +3,9 @@ module Files (
     , absoluteLink
     , filePath
     , find
-    , getXDGData
   ) where
 
-import System.Directory (doesDirectoryExist, doesFileExist, doesPathExist, listDirectory)
+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
-import System.Environment.XDG.BaseDir (getAllDataDirs)
-import System.Exit (die)
 import System.FilePath ((</>))
 
 data File = File FilePath | Dir FilePath
@@ -33,14 +30,3 @@ find path =
   filePath (Dir path) >>= emptyIfMissing (fmap ((path </>) <$>) . listDirectory)
   where
     emptyIfMissing = either (\_ -> return [])
-
-getXDGData :: FilePath -> IO FilePath
-getXDGData resource = getAllDataDirs relativePath >>= findFirst
-  where
-    relativePath = "hablo" </> resource
-    findFirst [] = die ("Install is broken: "
-                       <> relativePath
-                       <> " directory wasn't found in any of $XDG_DATA_DIRS")
-    findFirst (path:paths) = do
-      fileExists <- doesPathExist path
-      if fileExists then pure path else findFirst paths

src/JS.hs

@@ -13,8 +13,8 @@ import Data.ByteString.Lazy (
   )
 import Data.ByteString.Lazy.Char8 (pack)
 import Data.Text.Encoding (encodeUtf8)
-import Files (getXDGData)
 import JSON (exportBlog)
+import Paths_hablo (getDataDir)
 import Pretty ((.$))
 import SJW (compile, source)
 import System.Directory (createDirectoryIfMissing)
@@ -44,7 +44,7 @@ generateConfig destinationDir = do
 
 generateMain :: FilePath -> IO ()
 generateMain destinationDir = do
-  habloSources <- getXDGData "js"
+  habloSources <- (</> "js") <$> getDataDir
   compile (source [destinationDir, "unitJS", habloSources])
     >>= either abort (output . fst)
   where

src/Main.hs

@@ -1,16 +1,23 @@
 module Main where
 
-import Arguments (Arguments(..), version)
+import Arguments (Arguments(..))
 import qualified Arguments (get)
 import qualified Blog (build)
 import Control.Monad.Reader (runReaderT)
+import Data.Version (showVersion)
 import qualified HTML (generate)
 import qualified JS (generate)
+import qualified Paths_hablo as Hablo (version)
 import qualified RSS (generate)
 import System.Exit (exitSuccess)
 
 main :: IO ()
-main = Arguments.get >>= Blog.build >>= runReaderT
+main = do
-  (do HTML.generate
+  arguments <- Arguments.get
-      JS.generate
+  case arguments of
-      RSS.generate)
+    Version -> (putStrLn $ showVersion Hablo.version) >> exitSuccess
+    config@(BlogConfig {}) -> Blog.build config >>= runReaderT (do
+        HTML.generate
+        JS.generate
+        RSS.generate
+      )

src/TODO

@@ -1,6 +1,3 @@
-- dans Arguments.hs, vérifier que l'implémentation de option est pas déjà dans la lib optparse-applicative
+pre {
-		=> ah non en fait c'est une fonction locale au fichier juste mal nommée, corriger ça
+  white-space: pre-wrap;
-- le Wording, c'était quand même pas l'idée du siècle -> ça pourrait pas tout revenir dans un thème qui serait du HTML ?
+}
-- faque Template aussi
-- «Pretty» Oo ? mais c'est juste des Utils en fait
-- améliorer un peu la gestion des erreurs ? (ExceptT IO…) pas prio mais ça nuirait pas

test/Main.hs

@@ -1,10 +0,0 @@
-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 ]

test/Mock/Arguments.hs

@@ -16,7 +16,7 @@ import Arguments (Arguments(..))
 import Utils (testDataPath)
 
 defaultArticles :: Arguments
-defaultArticles = Arguments {
+defaultArticles = BlogConfig {
       sourceDir = testDataPath "Structure/defaultArticles"
     , articlesPath = Nothing
     , bannerPath = Nothing

test/Structure.hs

@@ -5,37 +5,36 @@ 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 Test.HUnit (Test(..), assertEqual)
+import Utils (simpleTest, tag)
-import Utils (labeled, testGroup)
 
-checkPath :: Arguments -> Maybe Path -> Test
+checkPath :: Arguments -> Maybe Path -> IO Progress
-checkPath input expected = TestCase . withCurrentDirectory root $
+checkPath input expected = do
-    either (\_ -> Nothing) Just <$> Path.build root input
+  withCurrentDirectory root $ do
-      >>= assertEqual "Incorrect path detected by hablo" expected
+    actual <- either (\_ -> Nothing) Just <$> Path.build root input
+    return . Finished $
+      if actual == expected
+      then Pass
+      else Fail $ "Expected " ++ show expected ++ " but got " ++ show actual
   where
     root = sourceDir input
 
 test :: Test
-test = testGroup "Blog structure" $ labeled
+test = tag "structure" . testGroup "Blog structure" $ simpleTest <$> [
-  [ ("empty structure", checkPath Arguments.emptyBlog Nothing)
+      ("empty structure", checkPath Arguments.emptyBlog Nothing)
-  , ("default articles"
+    , ("default articles", checkPath Arguments.defaultArticles $ Just Path.defaultArticles)
-    , checkPath Arguments.defaultArticles $ Just Path.defaultArticles)
+    , ("default pages", checkPath Arguments.defaultPages $ Just Path.defaultPages)
-  , ("default pages", checkPath Arguments.defaultPages $ Just Path.defaultPages)
+    , ("both default", checkPath Arguments.bothDefault $ Just Path.bothDefault)
-  , ("both default", checkPath Arguments.bothDefault $ Just Path.bothDefault)
+    , ("custom articles", checkPath Arguments.customArticles $ Just Path.customArticles)
-  , ("custom articles"
+    , ("custom pages", checkPath Arguments.customPages $ Just Path.customPages)
-    , checkPath Arguments.customArticles $ Just Path.customArticles)
+    , ("both custom", checkPath Arguments.bothCustom $ Just Path.bothCustom)
-  , ("custom pages", checkPath Arguments.customPages $ Just Path.customPages)
+    , ("custom articles, default pages"
-  , ("both custom", checkPath Arguments.bothCustom $ Just Path.bothCustom)
+        , checkPath Arguments.customArticlesDefaultPages $ Just Path.customArticlesDefaultPages)
-  , ("custom articles, default pages"
+    , ("custom pages, default articles"
-    , (checkPath
+        , checkPath Arguments.customPagesDefaultArticles $ Just Path.customPagesDefaultArticles)
-        Arguments.customArticlesDefaultPages
+    , ("bad custom articles", checkPath Arguments.badCustomArticles $ Nothing)
-        (Just Path.customArticlesDefaultPages)))
+    , ("bad custom pages", checkPath Arguments.badCustomPages $ Nothing)
-  , ("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/Tests.hs

@@ -0,0 +1,14 @@
+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
+  ]

test/Utils.hs

@@ -1,17 +1,49 @@
 {-# LANGUAGE NamedFieldPuns #-}
-module Utils
+module Utils (
-  ( labeled
+      assertAll
-  , testDataPath
+    , assertEqual
-  , testGroup ) where
+    , simpleTest
+    , tag
+    , testDataPath
+  ) where
 
+import Distribution.TestSuite
 import System.FilePath ((</>))
-import Test.HUnit (Test(..))
+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")
 
 testDataPath :: FilePath -> FilePath
 testDataPath = ("test" </>)
-
-testGroup :: String -> [Test] -> Test
-testGroup name = TestLabel name . TestList
-
-labeled :: [(String, Test)] -> [Test]
-labeled = fmap (uncurry TestLabel)

test/XML/Card.hs

@@ -2,10 +2,10 @@ module XML.Card (
     test
   ) where
 
-import Test.HUnit (Test)
+import Distribution.TestSuite
-import Utils (testGroup)
+import Utils (tag)
 import qualified XML.Card.Component as Component (test)
 import qualified XML.Card.Output as Output (test)
 
 test :: Test
-test = testGroup "Cards" [Component.test, Output.test]
+test = tag "card" $ testGroup "Cards" [Component.test, Output.test]

test/XML/Card/Component.hs

@@ -7,84 +7,83 @@ 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 Test.HUnit (Test(..), assertEqual)
+import Utils (assertAll, assertEqual, simpleTest, tag)
-import Utils (labeled, testGroup)
 
-check :: HasCard a => IO Blog -> a -> (Text, Text, Maybe String, String, String) -> IO ()
+check :: HasCard a => IO Blog -> a -> (Text, Text, Maybe String, String, String) -> IO Progress
 check getBlog input (expectedCT, expectedD, expectedI, expectedT, expectedU) =
-  getBlog >>= runReaderT checkCard
+  getBlog >>= runReaderT (
-  where
+      sequence [
-    checkCard = do
+            assertEqual "card types" expectedCT <$> cardType input
-      liftIO . assertEqual "card types" expectedCT =<< cardType input
+          , assertEqual "descriptions" expectedD <$> description input
-      liftIO . assertEqual "descriptions" expectedD =<< description input
+          , assertEqual "images" expectedI <$> image input
-      liftIO . assertEqual "images" expectedI =<< image input
+          , assertEqual "titles" expectedT <$> title input
-      liftIO . assertEqual "titles" expectedT =<< title input
+          , assertEqual "urls" expectedU <$> urlPath input
-      liftIO . assertEqual "urls" expectedU =<< urlPath input
+        ] >>= liftIO . assertAll
+    )
 
 articleCard :: Test
-articleCard = testGroup "Article cards" $ labeled
+articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
-  [ ("simple article components"
+      ("simple article components", check Blog.simple Article.simple (
-    , TestCase $ check Blog.simple Article.simple
+            "article"
-        ( "article"
+          , "It's a test"
-        , "It's a test"
+          , Just "test.png"
-        , Just "test.png"
+          , "Some test"
-        , "Some test"
+          , "articles/test.html"
-        , "articles/test.html" ))
+        ))
-  , ("article components without description"
+    , ("article components without description", check Blog.simple Article.noDescription (
-    , TestCase $ check Blog.simple Article.noDescription
+            "article"
-        ( "article"
+          , "A new article on The Test Blog"
-        , "A new article on The Test Blog"
+          , Just "test.png"
-        , Just "test.png"
+          , "Some test"
-        , "Some test"
+          , "articles/test.html"
-        , "articles/test.html" ))
+        ))
-  , ("article components without image"
+    , ("article components without image", check Blog.simple Article.noImage (
-    , TestCase $ check Blog.simple Article.noImage
+            "article"
-        ( "article"
+          , "It's a test"
-        , "It's a test"
+          , Nothing
-        , Nothing
+          , "Some test"
-        , "Some test"
+          , "articles/test.html"
-        , "articles/test.html" )) ]
+        ))
+  ]
 
 articlesListCard :: Test
-articlesListCard = testGroup "Articles list cards" $ labeled
+articlesListCard = tag "articlesList" . testGroup "Articles list cards" $ simpleTest <$> [
-  [ ("short untagged page component"
+      ("short untagged page component", ArticlesList.shortMain >>= (flip (check Blog.simple) (
-    , TestCase (ArticlesList.shortMain >>=
+            "website"
-                 (flip (check Blog.simple)
+          , "Latest articles"
-                   ( "website"
+          , Nothing
-                   , "Latest articles"
+          , "The Test Blog"
-                   , Nothing
+          , "index.html"
-                   , "The Test Blog"
+        )))
-                   , "index.html"))))
+    , ("long untagged page component", ArticlesList.longMain >>= (flip (check Blog.simple) (
-    , ("long untagged page component"
+            "website"
-      , TestCase (ArticlesList.longMain >>=
+          , "All articles"
-                   (flip (check Blog.simple)
+          , Nothing
-                     ( "website"
+          , "The Test Blog"
-                     , "All articles"
+          , "all.html"
-                     , Nothing
+        )))
-                     , "The Test Blog"
+    , ("short tagged page component", ArticlesList.shortTesting >>= (flip (check Blog.simple) (
-                     , "all.html"))))
+            "website"
-    , ("short tagged page component"
+          , "Latest articles tagged testing"
-      , TestCase (ArticlesList.shortTesting >>=
+          , Nothing
-                   (flip (check Blog.simple)
+          , "The Test Blog - testing"
-                     ( "website"
+          , "testing/index.html"
-                     , "Latest articles tagged testing"
+        )))
-                     , Nothing
+    , ("long tagged page component", ArticlesList.longTesting >>= (flip (check Blog.simple) (
-                     , "The Test Blog - testing"
+            "website"
-                     , "testing/index.html"))))
+          , "All articles tagged testing"
-    , ("long tagged page component"
+          , Nothing
-      , TestCase (ArticlesList.longTesting >>=
+          , "The Test Blog - testing"
-                   (flip (check Blog.simple)
+          , "testing/all.html"
-                     ( "website"
+        )))
-                     , "All articles tagged testing"
+  ]
-                     , Nothing
-                     , "The Test Blog - testing"
-                     , "testing/all.html")))) ]
 
 test :: Test
-test = testGroup "Cards components" [articleCard, articlesListCard]
+test = tag "component" $ testGroup "Cards components" [articleCard, articlesListCard]

test/XML/Card/Output.hs

@@ -6,6 +6,7 @@ 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)
@@ -15,47 +16,34 @@ import Mock.ArticlesList as ArticlesList (
   )
 import Pretty ((.$))
 import System.FilePath ((</>))
-import Test.HUnit (Test(..), assertEqual)
+import Utils (assertAll, assertEqual, simpleTest, tag, testDataPath)
-import Utils (labeled, testDataPath, testGroup)
 
-check :: HasCard a => IO Blog -> a -> FilePath -> IO ()
+check :: HasCard a => IO Blog -> a -> FilePath -> IO Progress
-check getBlog input expectedFile = getBlog >>= runReaderT checkHTML
+check getBlog input expectedFile =
-  where
+  getBlog >>= runReaderT (do
-    checkHTML = do
       actual <- renderTextT $ maybe (return ()) (DOM.Card.make input) =<< (asks $urls.$cards)
       expected <- liftIO . Lazy.readFile $ testDataPath "XML/Card/Output" </> expectedFile
-      liftIO $ assertEqual "card HTML output" expected actual
+      liftIO $ assertAll [
+          assertEqual "card HTML output" expected actual
+        ]
+    )
 
 articleCard :: Test 
-articleCard = testGroup "Article cards" $ labeled
+articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
-  [ ("simple article output"
+      ("simple article output", check Blog.simple Article.simple "simple.html")
-    , TestCase $ check Blog.simple Article.simple "simple.html")
+    , ("article output without description", check Blog.simple Article.noDescription "noDescription.html")
-  , ("article output without description"
+    , ("article output without image", check Blog.simple Article.noImage "noImage.html")
-    , TestCase $ check Blog.simple Article.noDescription "noDescription.html")
+    , ("no card article output", check Blog.noCards Article.simple "/dev/null")
-  , ("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 = testGroup "Article list cards" $ labeled
+articlesListCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
-  [ ("short untagged page output"
+      ("short untagged page output", ArticlesList.shortMain >>= flip (check Blog.simple) "shortMain.html")
-    , TestCase
+    , ("long untagged page output", ArticlesList.longMain >>= flip (check Blog.simple) "longMain.html")
-        (ArticlesList.shortMain >>= flip (check Blog.simple) "shortMain.html"))
+    , ("short tagged page output", ArticlesList.shortTesting >>= flip (check Blog.simple) "shortTesting.html")
-  , ("long untagged page output"
+    , ("long tagged page output", ArticlesList.longTesting >>= flip (check Blog.simple) "longTesting.html")
-    , TestCase
+    , ("no card articlesList output", ArticlesList.shortMain >>= flip (check Blog.noCards) "/dev/null")
-        (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 = testGroup "Cards outputs" [articleCard, articlesListCard]
+test = tag "output" $ testGroup "Cards outputs" [articleCard, articlesListCard]