{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hledger.Utils.Test (
HasCallStack
,module EasyTest
,runEasytests
,tests
,_tests
,test
,_test
,it
,_it
,is
,expectEqPP
,expectParse
,expectParseError
,expectParseEq
,expectParseEqOn
)
where
import Control.Exception
import Control.Monad.State.Strict (StateT, evalStateT)
#if !(MIN_VERSION_base(4,11,0))
import Data.Monoid ((<>))
#endif
import Data.CallStack
import Data.List
import qualified Data.Text as T
import Safe
import System.Exit
import Text.Megaparsec
import Text.Megaparsec.Custom
import EasyTest hiding (char, char', tests)
import qualified EasyTest as E
import Hledger.Utils.Debug (pshow)
import Hledger.Utils.UTF8IOCompat (error')
test :: T.Text -> E.Test a -> E.Test a
test = E.scope
_test :: T.Text -> E.Test a -> E.Test a
_test _name = (E.skip >>)
it :: T.Text -> E.Test a -> E.Test a
it = test
_it :: T.Text -> E.Test a -> E.Test a
_it = _test
tests :: T.Text -> [E.Test ()] -> E.Test ()
tests name = E.scope name . E.tests
_tests :: T.Text -> [E.Test ()] -> E.Test ()
_tests _name = (E.skip >>) . E.tests
runEasytests :: [String] -> E.Test () -> IO Bool
runEasytests args tests = (do
case args of
[] -> E.run tests
[a] -> E.runOnly (T.pack a) tests
a:b:_ -> do
case readMay b :: Maybe Int of
Nothing -> error' "the second argument should be an integer (a seed for easytest)"
Just seed -> E.rerunOnly seed (T.pack a) tests
return False
)
`catch` (\(_::ExitCode) -> return True)
expectEqPP :: (Eq a, Show a, HasCallStack) => a -> a -> E.Test ()
expectEqPP expected actual = if expected == actual then E.ok else E.crash $
"\nexpected:\n" <> T.pack (pshow expected) <> "\nbut got:\n" <> T.pack (pshow actual) <> "\n"
is :: (Eq a, Show a, HasCallStack) => a -> a -> Test ()
is = flip expectEqPP
expectParse :: (Monoid st, Eq a, Show a, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> E.Test ()
expectParse parser input = do
ep <- E.io (runParserT (evalStateT (parser <* eof) mempty) "" input)
either (fail.(++"\n").("\nparse error at "++).parseErrorPretty) (const ok) ep
expectParseError :: (Monoid st, Eq a, Show a, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> String -> E.Test ()
expectParseError parser input errstr = do
ep <- E.io (runParserT (evalStateT parser mempty) "" input)
case ep of
Right v -> fail $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n"
Left e -> do
let e' = parseErrorPretty e
if errstr `isInfixOf` e'
then ok
else fail $ "\nparse error is not as expected:\n" ++ e' ++ "\n"
expectParseEq :: (Monoid st, Eq a, Show a, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> E.Test ()
expectParseEq parser input expected = expectParseEqOn parser input id expected
expectParseEqOn :: (Monoid st, Eq b, Show b, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> (a -> b) -> b -> E.Test ()
expectParseEqOn parser input f expected = do
ep <- E.io $ runParserT (evalStateT (parser <* eof) mempty) "" input
either (fail . (++"\n") . ("\nparse error at "++) . parseErrorPretty) (expectEqPP expected . f) ep