{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoFieldSelectors #-}

module Skeletest.Internal.TestRunner (
  -- * Testable
  Testable (..),

  -- * TestResult
  TestResult (..),
  TestResultStatus (..),
  TestResultMessage (..),
  testResultPass,
  testResultFromAssertionFail,
  testResultFromError,
  testResultFromErrorWith,

  -- * AssertionFail
  AssertionFail (..),
  FailContext,
) where

import Control.Monad (guard)
import Control.Monad.IO.Class (MonadIO)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Typeable (typeOf)
import GHC.IO.Exception qualified as GHC
import GHC.Records (HasField (..))
import GHC.Stack (CallStack)
import GHC.Stack qualified as GHC
import Skeletest.Internal.Error (SkeletestError)
import Skeletest.Internal.Spec.Output (
  BoxSpec,
  BoxSpecContent (..),
  renderPrettyFailure,
 )
import Skeletest.Internal.TestInfo (TestInfo)
import Skeletest.Internal.Utils.Color qualified as Color
import Text.Read (readMaybe)
import UnliftIO.Exception (
  Exception,
  SomeException (..),
  displayException,
  fromException,
 )

{----- Testable -----}

class (MonadIO m) => Testable m where
  runTestable :: m () -> IO TestResult

  -- | Add any context to display if the test fails.
  --
  -- >>> (code, stdout) <- runCommand ...
  -- >>> context stdout $ code `shouldBe` ExitSuccess
  context :: String -> m a -> m a

  throwFailure :: AssertionFail -> m a

{----- TestResult -----}

data TestResult = TestResult
  { TestResult -> TestResultStatus
status :: TestResultStatus
  , TestResult -> Text
label :: Text
  , TestResult -> TestResultMessage
message :: TestResultMessage
  }

data TestResultStatus
  = TestPassed
  | TestFailed
  | TestSkipped
  | TestStatus
      { TestResultStatus -> Text
name_ :: Text
      , TestResultStatus -> Bool
success_ :: Bool
      }
  deriving (TestResultStatus -> TestResultStatus -> Bool
(TestResultStatus -> TestResultStatus -> Bool)
-> (TestResultStatus -> TestResultStatus -> Bool)
-> Eq TestResultStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestResultStatus -> TestResultStatus -> Bool
== :: TestResultStatus -> TestResultStatus -> Bool
$c/= :: TestResultStatus -> TestResultStatus -> Bool
/= :: TestResultStatus -> TestResultStatus -> Bool
Eq, Eq TestResultStatus
Eq TestResultStatus =>
(TestResultStatus -> TestResultStatus -> Ordering)
-> (TestResultStatus -> TestResultStatus -> Bool)
-> (TestResultStatus -> TestResultStatus -> Bool)
-> (TestResultStatus -> TestResultStatus -> Bool)
-> (TestResultStatus -> TestResultStatus -> Bool)
-> (TestResultStatus -> TestResultStatus -> TestResultStatus)
-> (TestResultStatus -> TestResultStatus -> TestResultStatus)
-> Ord TestResultStatus
TestResultStatus -> TestResultStatus -> Bool
TestResultStatus -> TestResultStatus -> Ordering
TestResultStatus -> TestResultStatus -> TestResultStatus
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TestResultStatus -> TestResultStatus -> Ordering
compare :: TestResultStatus -> TestResultStatus -> Ordering
$c< :: TestResultStatus -> TestResultStatus -> Bool
< :: TestResultStatus -> TestResultStatus -> Bool
$c<= :: TestResultStatus -> TestResultStatus -> Bool
<= :: TestResultStatus -> TestResultStatus -> Bool
$c> :: TestResultStatus -> TestResultStatus -> Bool
> :: TestResultStatus -> TestResultStatus -> Bool
$c>= :: TestResultStatus -> TestResultStatus -> Bool
>= :: TestResultStatus -> TestResultStatus -> Bool
$cmax :: TestResultStatus -> TestResultStatus -> TestResultStatus
max :: TestResultStatus -> TestResultStatus -> TestResultStatus
$cmin :: TestResultStatus -> TestResultStatus -> TestResultStatus
min :: TestResultStatus -> TestResultStatus -> TestResultStatus
Ord)

instance HasField "name" TestResultStatus Text where
  getField :: TestResultStatus -> Text
getField = \case
    TestResultStatus
TestPassed -> Text
"passed"
    TestResultStatus
TestFailed -> Text
"failed"
    TestResultStatus
TestSkipped -> Text
"skipped"
    TestStatus{Text
name_ :: TestResultStatus -> Text
name_ :: Text
name_} -> Text
name_
instance HasField "success" TestResultStatus Bool where
  getField :: TestResultStatus -> Bool
getField = \case
    TestResultStatus
TestPassed -> Bool
True
    TestResultStatus
TestFailed -> Bool
False
    TestResultStatus
TestSkipped -> Bool
True
    TestStatus{Bool
success_ :: TestResultStatus -> Bool
success_ :: Bool
success_} -> Bool
success_

data TestResultMessage
  = TestResultMessageNone
  | TestResultMessageInline Text
  | TestResultMessageBox BoxSpec

testResultPass :: TestResult
testResultPass :: TestResult
testResultPass =
  TestResult
    { status :: TestResultStatus
status = TestResultStatus
TestPassed
    , label :: Text
label = Text -> Text
Color.green Text
"OK"
    , message :: TestResultMessage
message = TestResultMessage
TestResultMessageNone
    }

testResultFromAssertionFail :: AssertionFail -> IO TestResult
testResultFromAssertionFail :: AssertionFail -> IO TestResult
testResultFromAssertionFail AssertionFail
e = do
  Text
msg <- AssertionFail -> IO Text
renderAssertionFail AssertionFail
e
  TestResult -> IO TestResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    TestResult
      { status :: TestResultStatus
status = TestResultStatus
TestFailed
      , label :: Text
label = Text -> Text
Color.red Text
"FAIL"
      , message :: TestResultMessage
message = BoxSpec -> TestResultMessage
TestResultMessageBox [Text -> BoxSpecContent
BoxText Text
msg]
      }

testResultFromError :: SomeException -> IO TestResult
testResultFromError :: SomeException -> IO TestResult
testResultFromError = (Text -> Text) -> SomeException -> IO TestResult
testResultFromErrorWith Text -> Text
forall a. a -> a
id

testResultFromErrorWith :: (Text -> Text) -> SomeException -> IO TestResult
testResultFromErrorWith :: (Text -> Text) -> SomeException -> IO TestResult
testResultFromErrorWith Text -> Text
f SomeException
e = do
  Text
msg <- Text -> Text
f (Text -> Text) -> IO Text -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
renderMsg
  TestResult -> IO TestResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    TestResult
      { status :: TestResultStatus
status = TestResultStatus
TestFailed
      , label :: Text
label = Text -> Text
Color.red Text
"ERROR"
      , message :: TestResultMessage
message = BoxSpec -> TestResultMessage
TestResultMessageBox [Text -> BoxSpecContent
BoxText Text
msg]
      }
 where
  renderMsg :: IO Text
renderMsg
    | Just (SkeletestError
err :: SkeletestError) <- SomeException -> Maybe SkeletestError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = do
        Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SkeletestError -> String
forall e. Exception e => e -> String
displayException SkeletestError
err
    -- Handle pattern match fail in a do-block
    | Just DoBlockFail
err <- SomeException -> Maybe DoBlockFail
parseDoBlockFail SomeException
e = do
        DoBlockFail -> IO Text
renderDoBlockFail DoBlockFail
err
    | SomeException e
err <- SomeException
e = do
        Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> ([String] -> Text) -> [String] -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip (Text -> Text) -> ([String] -> Text) -> [String] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> ([String] -> String) -> [String] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> IO Text) -> [String] -> IO Text
forall a b. (a -> b) -> a -> b
$
          [ String
"Got exception of type `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> (e -> TypeRep) -> e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf) e
err String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"`:"
          , SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
          ]

{----- DoBlockFail -----}

data DoBlockFail = DoBlockFail
  { DoBlockFail -> Text
doBlockFailMessage :: Text
  , DoBlockFail -> String
doBlockFailFile :: FilePath
  , DoBlockFail -> Int
doBlockFailLine :: Int
  , DoBlockFail -> Int
doBlockFailStartCol :: Int
  , DoBlockFail -> Int
doBlockFailEndCol :: Int
  }

-- | See if the exception is from a pattern match fail in a do-block.
parseDoBlockFail :: SomeException -> Maybe DoBlockFail
parseDoBlockFail :: SomeException -> Maybe DoBlockFail
parseDoBlockFail SomeException
e = do
  GHC.IOError Maybe Handle
_ IOErrorType
GHC.UserError String
_ String
msgStr Maybe CInt
_ Maybe String
_ <- SomeException -> Maybe IOException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e
  let msg :: Text
msg = String -> Text
Text.pack String
msgStr
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Text
"Pattern match failure " Text -> Text -> Bool
`Text.isPrefixOf` Text
msg
  [Text
msgWithoutLoc, Text
locInfo] <- [Text] -> Maybe [Text]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> Maybe [Text]) -> [Text] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
" at " Text
msg
  [Text
file, Text
lineStr, Text
colSpan] <- [Text] -> Maybe [Text]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> Maybe [Text]) -> [Text] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
":" Text
locInfo
  Int
line <- Text -> Maybe Int
readT Text
lineStr
  [Int
startCol, Int
endCol] <- (Text -> Maybe Int) -> [Text] -> Maybe [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Text -> Maybe Int
readT ([Text] -> Maybe [Int]) -> [Text] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"-" Text
colSpan
  DoBlockFail -> Maybe DoBlockFail
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    DoBlockFail
      { doBlockFailMessage :: Text
doBlockFailMessage = Text
msgWithoutLoc
      , doBlockFailFile :: String
doBlockFailFile = Text -> String
Text.unpack Text
file
      , doBlockFailLine :: Int
doBlockFailLine = Int
line
      , doBlockFailStartCol :: Int
doBlockFailStartCol = Int
startCol
      , -- seems like srcLocEndCol is exclusive, while the columns in the fail message are inclusive
        doBlockFailEndCol :: Int
doBlockFailEndCol = Int
endCol Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      }
 where
  readT :: Text -> Maybe Int
readT = String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> (Text -> String) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack

renderDoBlockFail :: DoBlockFail -> IO Text
renderDoBlockFail :: DoBlockFail -> IO Text
renderDoBlockFail DoBlockFail{Int
String
Text
doBlockFailMessage :: DoBlockFail -> Text
doBlockFailFile :: DoBlockFail -> String
doBlockFailLine :: DoBlockFail -> Int
doBlockFailStartCol :: DoBlockFail -> Int
doBlockFailEndCol :: DoBlockFail -> Int
doBlockFailMessage :: Text
doBlockFailFile :: String
doBlockFailLine :: Int
doBlockFailStartCol :: Int
doBlockFailEndCol :: Int
..} =
  Text -> [Text] -> [(String, Int, Int, Int)] -> IO Text
renderPrettyFailure
    Text
doBlockFailMessage
    [Text]
forall {a}. [a]
doBlockFailContext
    [ (String
doBlockFailFile, Int
doBlockFailLine, Int
doBlockFailStartCol, Int
doBlockFailEndCol)
    ]
 where
  doBlockFailContext :: [a]
doBlockFailContext = []

{----- AssertionFail -----}

data AssertionFail = AssertionFail
  { AssertionFail -> TestInfo
testInfo :: TestInfo
  , AssertionFail -> Text
testFailMessage :: Text
  , AssertionFail -> [Text]
testFailContext :: FailContext
  , AssertionFail -> CallStack
callStack :: CallStack
  }
  deriving (Int -> AssertionFail -> String -> String
[AssertionFail] -> String -> String
AssertionFail -> String
(Int -> AssertionFail -> String -> String)
-> (AssertionFail -> String)
-> ([AssertionFail] -> String -> String)
-> Show AssertionFail
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> AssertionFail -> String -> String
showsPrec :: Int -> AssertionFail -> String -> String
$cshow :: AssertionFail -> String
show :: AssertionFail -> String
$cshowList :: [AssertionFail] -> String -> String
showList :: [AssertionFail] -> String -> String
Show)

instance Exception AssertionFail

-- | Context for failures, in order of most recently added -> least recently added
type FailContext = [Text]

-- | Render a test failure like:
--
-- @
-- At test/Skeletest/Internal/TestTargetsSpec.hs:19:
-- |
-- |           parseTestTargets input `shouldBe` Right (Just expected)
-- |                                   ^^^^^^^^
--
-- Right 1 ≠ Left 1
-- @
renderAssertionFail :: AssertionFail -> IO Text
renderAssertionFail :: AssertionFail -> IO Text
renderAssertionFail AssertionFail{[Text]
CallStack
Text
TestInfo
testInfo :: AssertionFail -> TestInfo
testFailMessage :: AssertionFail -> Text
testFailContext :: AssertionFail -> [Text]
callStack :: AssertionFail -> CallStack
testInfo :: TestInfo
testFailMessage :: Text
testFailContext :: [Text]
callStack :: CallStack
..} =
  Text -> [Text] -> [(String, Int, Int, Int)] -> IO Text
renderPrettyFailure
    Text
testFailMessage
    [Text]
testFailContext
    [ (String
srcLocFile, Int
srcLocStartLine, Int
srcLocStartCol, Int
srcLocEndCol)
    | (String
_, GHC.SrcLoc{Int
String
srcLocFile :: String
srcLocStartLine :: Int
srcLocStartCol :: Int
srcLocEndCol :: Int
srcLocPackage :: String
srcLocModule :: String
srcLocEndLine :: Int
srcLocEndCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocStartLine :: SrcLoc -> Int
srcLocFile :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocPackage :: SrcLoc -> String
..}) <- CallStack -> [(String, SrcLoc)]
GHC.getCallStack CallStack
callStack
    ]