module Test.Fluent.Tasty.TestCase (fluentTestCase) where

import Control.Exception (try)
import Data.Data (Typeable)
import Data.List (intercalate)
import GHC.Exception (SrcLoc (srcLocFile, srcLocStartLine))
import Test.Fluent.Assertions
  ( FluentTestFailure (FluentTestFailure),
  )
import Test.Tasty.Providers
  ( IsTest (..),
    TestName,
    TestTree,
    singleTest,
    testFailedDetails,
    testPassed,
  )
import Test.Tasty.Providers.ConsoleFormat
  ( ResultDetailsPrinter (..),
    failFormat,
  )

newtype FluentTestCase = FluentTestCase (IO String)
  deriving (Typeable)

failedAssertionResultPrinter :: Int -> Int -> ResultDetailsPrinter
failedAssertionResultPrinter :: Int -> Int -> ResultDetailsPrinter
failedAssertionResultPrinter Int
errors Int
successes = (Int -> ConsoleFormatPrinter -> IO ()) -> ResultDetailsPrinter
ResultDetailsPrinter ((Int -> ConsoleFormatPrinter -> IO ()) -> ResultDetailsPrinter)
-> (Int -> ConsoleFormatPrinter -> IO ()) -> ResultDetailsPrinter
forall a b. (a -> b) -> a -> b
$ \Int
ident ConsoleFormatPrinter
formater ->
  ConsoleFormatPrinter
formater ConsoleFormat
failFormat (String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
ident Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"passed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
successes String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
errors String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", total: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
errors Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
successes))

instance IsTest FluentTestCase where
  run :: OptionSet -> FluentTestCase -> (Progress -> IO ()) -> IO Result
run OptionSet
_ (FluentTestCase IO String
assertions) Progress -> IO ()
_ = do
    Either FluentTestFailure String
result <- IO String -> IO (Either FluentTestFailure String)
forall e a. Exception e => IO a -> IO (Either e a)
try IO String
assertions
    Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$
      case Either FluentTestFailure String
result of
        Right String
info -> String -> Result
testPassed String
info
        Left (FluentTestFailure Maybe SrcLoc
_ [(String, Maybe SrcLoc)]
msg Int
errors Int
successes) -> String -> ResultDetailsPrinter -> Result
testFailedDetails ([(String, Maybe SrcLoc)] -> String
prependLocation [(String, Maybe SrcLoc)]
msg) (Int -> Int -> ResultDetailsPrinter
failedAssertionResultPrinter Int
errors Int
successes)
  testOptions :: Tagged FluentTestCase [OptionDescription]
testOptions = [OptionDescription] -> Tagged FluentTestCase [OptionDescription]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

prependLocation :: [(String, Maybe SrcLoc)] -> String
prependLocation :: [(String, Maybe SrcLoc)] -> String
prependLocation [(String, Maybe SrcLoc)]
assertionErrors = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((String, Maybe SrcLoc) -> String)
-> [(String, Maybe SrcLoc)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, Maybe SrcLoc) -> String
toLine [(String, Maybe SrcLoc)]
assertionErrors
  where
    toLine :: (String, Maybe SrcLoc) -> String
toLine (String
s, Maybe SrcLoc
mbloc) = case Maybe SrcLoc
mbloc of
      Maybe SrcLoc
Nothing -> String
s
      Just SrcLoc
loc -> String
"(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SrcLoc -> String
srcLocFile SrcLoc
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (SrcLoc -> Int
srcLocStartLine SrcLoc
loc) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"): \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s

-- | transform assert4hs assertion into tasty TestTree
fluentTestCase :: TestName ->  IO () ->   TestTree
fluentTestCase :: String -> IO () -> TestTree
fluentTestCase String
name = String -> FluentTestCase -> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest String
name (FluentTestCase -> TestTree)
-> (IO () -> FluentTestCase) -> IO () -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO String -> FluentTestCase
FluentTestCase (IO String -> FluentTestCase)
-> (IO () -> IO String) -> IO () -> FluentTestCase
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() -> String) -> IO () -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> () -> String
forall a b. a -> b -> a
const String
"")