{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}
module VtUtils.HUnit
( HUnitGroupLabelNotSpecifiedException
, HUnitDuplicateGroupLabelException
, HUnitLabelNotFoundException
, HUnitNonListGroupException
, HUnitExpectedExceptionNotThrown
, hunitCatchException
, HUnitMainException
, hunitMain
, hunitRun
, hunitRunGroup
, hunitRunSingle
) where
import Prelude (Either(..), Int, IO, Maybe(..), Show(..), (+), ($), (>=), (<$>), fmap, otherwise, return)
import Control.Exception (Exception, throwIO, try)
import Data.HashMap.Strict (lookup)
import Data.Monoid ((<>))
import Data.Text (Text, pack)
import Data.Vector (Vector, (!), fromList, length, toList, singleton)
import qualified Data.Vector as Vector
import Test.HUnit (Test(..), runTestTT, testCasePaths)
import System.Environment (getArgs)
import VtUtils.Error (errorShow)
import VtUtils.Map (mapFromVector)
import VtUtils.Text (textShow)
import VtUtils.Vector (vectorFirstDuplicate)
findNonLabeled :: Vector Test -> Maybe Int
findNonLabeled vec =
fun 0
where
fun idx
| idx >= Vector.length vec = Nothing
| otherwise =
let el = vec ! idx in
case el of
(TestLabel _ _) -> fun (idx + 1)
_ -> Just idx
labelKeyFun :: Int -> Test -> Text
labelKeyFun _ ts =
case ts of
(TestLabel lab _) -> pack lab
(TestCase _) -> "NO_LABEL"
(TestList _) -> "NO_LABEL"
data HUnitGroupLabelNotSpecifiedException = HUnitGroupLabelNotSpecifiedException
{ groupIdx :: Int
, group :: Test
}
instance Exception HUnitGroupLabelNotSpecifiedException
instance Show HUnitGroupLabelNotSpecifiedException where
show e@(HUnitGroupLabelNotSpecifiedException {groupIdx, group}) = errorShow e $
"Invalid test group,"
<> " index: [" <> textShow groupIdx <> "],"
<> " paths: [" <> textShow (testCasePaths group) <> "]"
data HUnitDuplicateGroupLabelException = HUnitDuplicateGroupLabelException
{ label :: Text
, group1Idx :: Int
, group1 :: Test
, group2Idx :: Int
, group2 :: Test
}
instance Exception HUnitDuplicateGroupLabelException
instance Show HUnitDuplicateGroupLabelException where
show e@(HUnitDuplicateGroupLabelException {label, group1Idx, group1, group2Idx, group2}) = errorShow e $
"Invalid duplicate test label specified,"
<> " label: [" <> label <>"],"
<> " group1 index: [" <> textShow group1Idx <> "],"
<> " group1: [" <> textShow (testCasePaths group1) <> "],"
<> " group2 index: [" <> textShow group2Idx <> "],"
<> " group2: [" <> textShow (testCasePaths group2) <> "]"
data HUnitLabelNotFoundException = HUnitLabelNotFoundException
{ label :: Text
}
instance Exception HUnitLabelNotFoundException
instance Show HUnitLabelNotFoundException where
show e@(HUnitLabelNotFoundException {label}) = errorShow e $
"Test group not found, label: [" <> label <> "]"
data HUnitNonListGroupException = HUnitNonListGroupException
{ label :: Text
, group :: Test
}
instance Exception HUnitNonListGroupException
instance Show HUnitNonListGroupException where
show e@(HUnitNonListGroupException {label, group}) = errorShow e $
"Group does not contain a list of tests,"
<> " label: [" <> label <> "],"
<> " group: [" <> textShow (testCasePaths group) <> "]"
findLabeledTest :: Vector Test -> Text -> IO Test
findLabeledTest tests label = do
case findNonLabeled tests of
Just idx -> throwIO $ HUnitGroupLabelNotSpecifiedException idx (tests ! idx)
Nothing -> return ()
case vectorFirstDuplicate tests labelKeyFun of
Just (idx1, idx2) -> throwIO $ HUnitDuplicateGroupLabelException
{ label = labelKeyFun idx1 (tests ! idx1)
, group1Idx = idx1
, group1 = tests ! idx1
, group2Idx = idx2
, group2 = tests ! idx2
}
Nothing -> return ()
case lookup label (mapFromVector tests labelKeyFun) of
Nothing -> throwIO $ HUnitLabelNotFoundException label
Just group -> return group
hunitRun :: Vector Test -> IO ()
hunitRun tests = do
_ <- runTestTT (TestList (toList tests))
return ()
hunitRunGroup :: Vector Test -> Text -> IO ()
hunitRunGroup tests label = do
group <- findLabeledTest tests label
hunitRun $ singleton group
hunitRunSingle :: Vector Test -> Text -> Text -> IO ()
hunitRunSingle tests grlabel tslabel = do
group <- findLabeledTest tests grlabel
case group of
(TestLabel _ (TestList li)) -> do
test <- findLabeledTest (fromList li) tslabel
hunitRun $ singleton test
_ -> throwIO $ HUnitNonListGroupException grlabel group
data HUnitMainException = HUnitMainException
{ numberOfArgs :: Int
}
instance Exception HUnitMainException
instance Show HUnitMainException where
show e@(HUnitMainException {numberOfArgs}) = errorShow e $
"Invalid test arguments, "
<> " number: [" <> (textShow numberOfArgs) <> "],"
<> " expected: [stack test [--ta \"group_name [test_name]\"]"
hunitMain :: Vector Test -> IO ()
hunitMain tests = do
args <- (fmap pack) <$> fromList <$> getArgs
case (length args) of
0 -> hunitRun tests
1 -> hunitRunGroup tests (args ! 0)
2 -> hunitRunSingle tests (args ! 0) (args ! 1)
n -> throwIO $ HUnitMainException n
return ()
data HUnitExpectedExceptionNotThrown = HUnitExpectedExceptionNotThrown Text
deriving Show
instance Exception HUnitExpectedExceptionNotThrown
hunitCatchException :: Exception e => Text -> IO a -> IO e
hunitCatchException msg action = do
outcome <- try $ action
case outcome of
Right _ -> throwIO $ HUnitExpectedExceptionNotThrown msg
Left exc -> return exc