hledger/hledger-lib/Hledger/Utils/Test.hs

{-# 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 (unless)
import Control.Monad.Except (ExceptT(..), liftEither, runExceptT, withExceptT)
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.IO (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