150 lines
6.5 KiB
Haskell
150 lines
6.5 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module Hledger.Utils.Test (
|
|
module Test.Tasty
|
|
,module Test.Tasty.HUnit
|
|
-- ,module QC
|
|
-- ,module SC
|
|
,assertLeft
|
|
,assertRight
|
|
,assertParse
|
|
,assertParseEq
|
|
,assertParseEqOn
|
|
,assertParseError
|
|
,assertParseE
|
|
,assertParseEqE
|
|
,assertParseErrorE
|
|
,assertParseStateOn
|
|
)
|
|
where
|
|
|
|
import Control.Monad.Except (ExceptT(..), liftEither, runExceptT, withExceptT, unless)
|
|
import Control.Monad.State.Strict (StateT, evalStateT, execStateT)
|
|
import Data.Default (Default(..))
|
|
import Data.List (isInfixOf)
|
|
import qualified Data.Text as T
|
|
import Test.Tasty hiding (defaultMain)
|
|
import Test.Tasty.HUnit
|
|
-- import Test.Tasty.QuickCheck as QC
|
|
-- import Test.Tasty.SmallCheck as SC
|
|
import Text.Megaparsec
|
|
import Text.Megaparsec.Custom
|
|
( HledgerParseErrorData,
|
|
FinalParseError,
|
|
attachSource,
|
|
customErrorBundlePretty,
|
|
finalErrorBundlePretty,
|
|
)
|
|
|
|
import Hledger.Utils.Debug (pshow)
|
|
|
|
-- * tasty helpers
|
|
|
|
-- TODO: pretty-print values in failure messages
|
|
|
|
-- | Assert any Left value.
|
|
assertLeft :: (HasCallStack, Eq b, Show b) => Either a b -> Assertion
|
|
assertLeft (Left _) = return ()
|
|
assertLeft (Right b) = assertFailure $ "expected Left, got (Right " ++ show b ++ ")"
|
|
|
|
-- | Assert any Right value.
|
|
assertRight :: (HasCallStack, Eq a, Show a) => Either a b -> Assertion
|
|
assertRight (Right _) = return ()
|
|
assertRight (Left a) = assertFailure $ "expected Right, got (Left " ++ show a ++ ")"
|
|
|
|
-- | Run a parser on the given text and display a helpful error.
|
|
parseHelper :: (HasCallStack, Default st, Monad m) =>
|
|
StateT st (ParsecT HledgerParseErrorData T.Text m) a -> T.Text -> ExceptT String m a
|
|
parseHelper parser input =
|
|
withExceptT (\e -> "\nparse error at " ++ customErrorBundlePretty e ++ "\n") . ExceptT
|
|
$ runParserT (evalStateT (parser <* eof) def) "" input
|
|
|
|
-- | Run a stateful parser in IO and process either a failure or success to
|
|
-- produce an 'Assertion'. Suitable for hledger's JournalParser parsers.
|
|
assertParseHelper :: (HasCallStack, Default st) =>
|
|
(String -> Assertion) -> (a -> Assertion)
|
|
-> StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text
|
|
-> Assertion
|
|
assertParseHelper onFailure onSuccess parser input =
|
|
either onFailure onSuccess =<< runExceptT (parseHelper parser input)
|
|
|
|
-- | Assert that this stateful parser runnable in IO successfully parses
|
|
-- all of the given input text, showing the parse error if it fails.
|
|
-- Suitable for hledger's JournalParser parsers.
|
|
assertParse :: (HasCallStack, Default st) =>
|
|
StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text -> Assertion
|
|
assertParse = assertParseHelper assertFailure (const $ return ())
|
|
|
|
-- | Assert a parser produces an expected value.
|
|
assertParseEq :: (HasCallStack, Eq a, Show a, Default st) =>
|
|
StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text -> a -> Assertion
|
|
assertParseEq parser input = assertParseEqOn parser input id
|
|
|
|
-- | Like assertParseEq, but transform the parse result with the given function
|
|
-- before comparing it.
|
|
assertParseEqOn :: (HasCallStack, Eq b, Show b, Default st) =>
|
|
StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text -> (a -> b) -> b -> Assertion
|
|
assertParseEqOn parser input f expected =
|
|
assertParseHelper assertFailure (assertEqual "" expected . f) parser input
|
|
|
|
-- | Assert that this stateful parser runnable in IO fails to parse
|
|
-- the given input text, with a parse error containing the given string.
|
|
assertParseError :: (HasCallStack, Eq a, Show a, Default st) =>
|
|
StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text -> String -> Assertion
|
|
assertParseError parser input errstr = assertParseHelper
|
|
(\e -> unless (errstr `isInfixOf` e) $ assertFailure $ "\nparse error is not as expected:" ++ e)
|
|
(\v -> assertFailure $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n")
|
|
parser input
|
|
|
|
-- | Run a stateful parser in IO like assertParse, then assert that the
|
|
-- final state (the wrapped state, not megaparsec's internal state),
|
|
-- transformed by the given function, matches the given expected value.
|
|
assertParseStateOn :: (HasCallStack, Eq b, Show b, Default st) =>
|
|
StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text -> (st -> b) -> b -> Assertion
|
|
assertParseStateOn parser input f expected = do
|
|
es <- runParserT (execStateT (parser <* eof) def) "" input
|
|
case es of
|
|
Left err -> assertFailure $ (++"\n") $ ("\nparse error at "++) $ customErrorBundlePretty err
|
|
Right s -> assertEqual "" expected $ f s
|
|
|
|
-- | These "E" variants of the above are suitable for hledger's ErroringJournalParser parsers.
|
|
parseHelperE :: (HasCallStack, Default st, Monad m) =>
|
|
StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError m)) a -> T.Text -> ExceptT String m a
|
|
parseHelperE parser input = do
|
|
withExceptT (\e -> "\nparse error at " ++ customErrorBundlePretty e ++ "\n") . liftEither
|
|
=<< withExceptT (\e -> "parse error at " ++ finalErrorBundlePretty (attachSource "" input e))
|
|
(runParserT (evalStateT (parser <* eof) def) "" input)
|
|
|
|
assertParseHelperE :: (HasCallStack, Default st) =>
|
|
(String -> Assertion) -> (a -> Assertion)
|
|
-> StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text
|
|
-> Assertion
|
|
assertParseHelperE onFailure onSuccess parser input =
|
|
either onFailure onSuccess =<< runExceptT (parseHelperE parser input)
|
|
|
|
assertParseE
|
|
:: (HasCallStack, Eq a, Show a, Default st)
|
|
=> StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text -> Assertion
|
|
assertParseE = assertParseHelperE assertFailure (const $ return ())
|
|
|
|
assertParseEqE
|
|
:: (Default st, Eq a, Show a, HasCallStack)
|
|
=> StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text -> a -> Assertion
|
|
assertParseEqE parser input = assertParseEqOnE parser input id
|
|
|
|
assertParseEqOnE
|
|
:: (HasCallStack, Eq b, Show b, Default st)
|
|
=> StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text -> (a -> b) -> b -> Assertion
|
|
assertParseEqOnE parser input f expected =
|
|
assertParseHelperE assertFailure (assertEqual "" expected . f) parser input
|
|
|
|
assertParseErrorE
|
|
:: (Default st, Eq a, Show a, HasCallStack)
|
|
=> StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text -> String -> Assertion
|
|
assertParseErrorE parser input errstr = assertParseHelperE
|
|
(\e -> unless (errstr `isInfixOf` e) $ assertFailure $ "\nparse error is not as expected:" ++ e)
|
|
(\v -> assertFailure $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n")
|
|
parser input
|