{-# 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 :: forall b a. (HasCallStack, Eq b, Show b) => Either a b -> Assertion
assertLeft (Left a
_)  = forall (m :: * -> *) a. Monad m => a -> m a
return ()
assertLeft (Right b
b) = forall a. HasCallStack => [Char] -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$ [Char]
"expected Left, got (Right " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show b
b forall a. [a] -> [a] -> [a]
++ [Char]
")"

-- | Assert any Right value.
assertRight :: (HasCallStack, Eq a, Show a) => Either a b -> Assertion
assertRight :: forall a b. (HasCallStack, Eq a, Show a) => Either a b -> Assertion
assertRight (Right b
_) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
assertRight (Left a
a)  = forall a. HasCallStack => [Char] -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$ [Char]
"expected Right, got (Left " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
a forall a. [a] -> [a] -> [a]
++ [Char]
")"

-- | 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 :: forall st (m :: * -> *) a.
(HasCallStack, Default st, Monad m) =>
StateT st (ParsecT HledgerParseErrorData Text m) a
-> Text -> ExceptT [Char] m a
parseHelper StateT st (ParsecT HledgerParseErrorData Text m) a
parser Text
input =
  forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (\HledgerParseErrors
e -> [Char]
"\nparse error at " forall a. [a] -> [a] -> [a]
++ HledgerParseErrors -> [Char]
customErrorBundlePretty HledgerParseErrors
e forall a. [a] -> [a] -> [a]
++ [Char]
"\n") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
  forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> [Char] -> s -> m (Either (ParseErrorBundle s e) a)
runParserT (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (StateT st (ParsecT HledgerParseErrorData Text m) a
parser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) forall a. Default a => a
def) [Char]
"" Text
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 :: forall st a.
(HasCallStack, Default st) =>
([Char] -> Assertion)
-> (a -> Assertion)
-> StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text
-> Assertion
assertParseHelper [Char] -> Assertion
onFailure a -> Assertion
onSuccess StateT st (ParsecT HledgerParseErrorData Text IO) a
parser Text
input =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Assertion
onFailure a -> Assertion
onSuccess forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall st (m :: * -> *) a.
(HasCallStack, Default st, Monad m) =>
StateT st (ParsecT HledgerParseErrorData Text m) a
-> Text -> ExceptT [Char] m a
parseHelper StateT st (ParsecT HledgerParseErrorData Text IO) a
parser Text
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 :: forall st a.
(HasCallStack, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> Assertion
assertParse = forall st a.
(HasCallStack, Default st) =>
([Char] -> Assertion)
-> (a -> Assertion)
-> StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text
-> Assertion
assertParseHelper forall a. HasCallStack => [Char] -> IO a
assertFailure (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
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 :: forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq StateT st (ParsecT HledgerParseErrorData Text IO) a
parser Text
input = forall b st a.
(HasCallStack, Eq b, Show b, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> (a -> b) -> b -> Assertion
assertParseEqOn StateT st (ParsecT HledgerParseErrorData Text IO) a
parser Text
input forall a. a -> a
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 :: forall b st a.
(HasCallStack, Eq b, Show b, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> (a -> b) -> b -> Assertion
assertParseEqOn StateT st (ParsecT HledgerParseErrorData Text IO) a
parser Text
input a -> b
f b
expected =
  forall st a.
(HasCallStack, Default st) =>
([Char] -> Assertion)
-> (a -> Assertion)
-> StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text
-> Assertion
assertParseHelper forall a. HasCallStack => [Char] -> IO a
assertFailure (forall a.
(Eq a, Show a, HasCallStack) =>
[Char] -> a -> a -> Assertion
assertEqual [Char]
"" b
expected forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) StateT st (ParsecT HledgerParseErrorData Text IO) a
parser Text
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 :: forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> [Char] -> Assertion
assertParseError StateT st (ParsecT HledgerParseErrorData Text IO) a
parser Text
input [Char]
errstr = forall st a.
(HasCallStack, Default st) =>
([Char] -> Assertion)
-> (a -> Assertion)
-> StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text
-> Assertion
assertParseHelper
  (\[Char]
e -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char]
errstr forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
e) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$ [Char]
"\nparse error is not as expected:" forall a. [a] -> [a] -> [a]
++ [Char]
e)
  (\a
v -> forall a. HasCallStack => [Char] -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$ [Char]
"\nparse succeeded unexpectedly, producing:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
pshow a
v forall a. [a] -> [a] -> [a]
++ [Char]
"\n")
  StateT st (ParsecT HledgerParseErrorData Text IO) a
parser Text
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 :: forall b st a.
(HasCallStack, Eq b, Show b, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> (st -> b) -> b -> Assertion
assertParseStateOn StateT st (ParsecT HledgerParseErrorData Text IO) a
parser Text
input st -> b
f b
expected = do
  Either HledgerParseErrors st
es <- forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> [Char] -> s -> m (Either (ParseErrorBundle s e) a)
runParserT (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (StateT st (ParsecT HledgerParseErrorData Text IO) a
parser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) forall a. Default a => a
def) [Char]
"" Text
input
  case Either HledgerParseErrors st
es of
    Left HledgerParseErrors
err -> forall a. HasCallStack => [Char] -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> [a] -> [a]
++[Char]
"\n") forall a b. (a -> b) -> a -> b
$ ([Char]
"\nparse error at "forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$ HledgerParseErrors -> [Char]
customErrorBundlePretty HledgerParseErrors
err
    Right st
s  -> forall a.
(Eq a, Show a, HasCallStack) =>
[Char] -> a -> a -> Assertion
assertEqual [Char]
"" b
expected forall a b. (a -> b) -> a -> b
$ st -> b
f st
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 :: forall st (m :: * -> *) a.
(HasCallStack, Default st, Monad m) =>
StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
  a
-> Text -> ExceptT [Char] m a
parseHelperE StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
  a
parser Text
input = do
  forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (\HledgerParseErrors
e -> [Char]
"\nparse error at " forall a. [a] -> [a] -> [a]
++ HledgerParseErrors -> [Char]
customErrorBundlePretty HledgerParseErrors
e forall a. [a] -> [a] -> [a]
++ [Char]
"\n") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
  forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (\FinalParseError
e -> [Char]
"parse error at " forall a. [a] -> [a] -> [a]
++ FinalParseErrorBundle' HledgerParseErrorData -> [Char]
finalErrorBundlePretty (forall e.
[Char] -> Text -> FinalParseError' e -> FinalParseErrorBundle' e
attachSource [Char]
"" Text
input FinalParseError
e))
        (forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> [Char] -> s -> m (Either (ParseErrorBundle s e) a)
runParserT (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
  a
parser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) forall a. Default a => a
def) [Char]
"" Text
input)

assertParseHelperE :: (HasCallStack, Default st) =>
  (String -> Assertion) -> (a -> Assertion)
  -> StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text
  -> Assertion
assertParseHelperE :: forall st a.
(HasCallStack, Default st) =>
([Char] -> Assertion)
-> (a -> Assertion)
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
     a
-> Text
-> Assertion
assertParseHelperE [Char] -> Assertion
onFailure a -> Assertion
onSuccess StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
  a
parser Text
input =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Assertion
onFailure a -> Assertion
onSuccess forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall st (m :: * -> *) a.
(HasCallStack, Default st, Monad m) =>
StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
  a
-> Text -> ExceptT [Char] m a
parseHelperE StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
  a
parser Text
input)

assertParseE
  :: (HasCallStack, Eq a, Show a, Default st)
  => StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text -> Assertion
assertParseE :: forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
  a
-> Text -> Assertion
assertParseE = forall st a.
(HasCallStack, Default st) =>
([Char] -> Assertion)
-> (a -> Assertion)
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
     a
-> Text
-> Assertion
assertParseHelperE forall a. HasCallStack => [Char] -> IO a
assertFailure (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ())

assertParseEqE
  :: (Default st, Eq a, Show a, HasCallStack)
  => StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text -> a -> Assertion
assertParseEqE :: forall st a.
(Default st, Eq a, Show a, HasCallStack) =>
StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
  a
-> Text -> a -> Assertion
assertParseEqE StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
  a
parser Text
input = forall b st a.
(HasCallStack, Eq b, Show b, Default st) =>
StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
  a
-> Text -> (a -> b) -> b -> Assertion
assertParseEqOnE StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
  a
parser Text
input forall a. a -> a
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 :: forall b st a.
(HasCallStack, Eq b, Show b, Default st) =>
StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
  a
-> Text -> (a -> b) -> b -> Assertion
assertParseEqOnE StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
  a
parser Text
input a -> b
f b
expected =
  forall st a.
(HasCallStack, Default st) =>
([Char] -> Assertion)
-> (a -> Assertion)
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
     a
-> Text
-> Assertion
assertParseHelperE forall a. HasCallStack => [Char] -> IO a
assertFailure (forall a.
(Eq a, Show a, HasCallStack) =>
[Char] -> a -> a -> Assertion
assertEqual [Char]
"" b
expected forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
  a
parser Text
input

assertParseErrorE
  :: (Default st, Eq a, Show a, HasCallStack)
  => StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text -> String -> Assertion
assertParseErrorE :: forall st a.
(Default st, Eq a, Show a, HasCallStack) =>
StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
  a
-> Text -> [Char] -> Assertion
assertParseErrorE StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
  a
parser Text
input [Char]
errstr = forall st a.
(HasCallStack, Default st) =>
([Char] -> Assertion)
-> (a -> Assertion)
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
     a
-> Text
-> Assertion
assertParseHelperE
  (\[Char]
e -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char]
errstr forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
e) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$ [Char]
"\nparse error is not as expected:" forall a. [a] -> [a] -> [a]
++ [Char]
e)
  (\a
v -> forall a. HasCallStack => [Char] -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$ [Char]
"\nparse succeeded unexpectedly, producing:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
pshow a
v forall a. [a] -> [a] -> [a]
++ [Char]
"\n")
  StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError IO))
  a
parser Text
input