hablo/test/Utils.hs

{-# LANGUAGE NamedFieldPuns #-}
module Utils (
      assertAll
    , assertEqual
    , simpleTest
    , tag
    , testDataPath
  ) 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")

testDataPath :: FilePath -> FilePath
testDataPath = ("test" </>)