{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

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

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

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

import Control.Monad.IO.Class (MonadIO)
import Data.Maybe (listToMaybe)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import GHC.Stack (CallStack)
import GHC.Stack qualified as GHC
import UnliftIO.Exception (
  Exception,
  SomeException,
  displayException,
  fromException,
  try,
 )

import Skeletest.Internal.Error (SkeletestError)
import Skeletest.Internal.TestInfo (TestInfo)
import Skeletest.Internal.Utils.Color qualified as Color

{----- 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 -> Bool
testResultSuccess :: Bool
  , TestResult -> Text
testResultLabel :: Text
  , TestResult -> TestResultMessage
testResultMessage :: TestResultMessage
  }

data TestResultMessage
  = TestResultMessageNone
  | TestResultMessageInline Text
  | TestResultMessageSection Text

testResultPass :: TestResult
testResultPass :: TestResult
testResultPass =
  TestResult
    { testResultSuccess :: Bool
testResultSuccess = Bool
True
    , testResultLabel :: Text
testResultLabel = Text -> Text
Color.green Text
"OK"
    , testResultMessage :: TestResultMessage
testResultMessage = TestResultMessage
TestResultMessageNone
    }

testResultFromAssertionFail :: AssertionFail -> IO TestResult
testResultFromAssertionFail :: AssertionFail -> IO TestResult
testResultFromAssertionFail AssertionFail
e = do
  msg <- AssertionFail -> IO Text
renderAssertionFail AssertionFail
e
  pure
    TestResult
      { testResultSuccess = False
      , testResultLabel = Color.red "FAIL"
      , testResultMessage = TestResultMessageSection msg
      }

testResultFromError :: SomeException -> TestResult
testResultFromError :: SomeException -> TestResult
testResultFromError SomeException
e =
  TestResult
    { testResultSuccess :: Bool
testResultSuccess = Bool
False
    , testResultLabel :: Text
testResultLabel = Text -> Text
Color.red Text
"ERROR"
    , testResultMessage :: TestResultMessage
testResultMessage = Text -> TestResultMessage
TestResultMessageInline (Text -> TestResultMessage) -> Text -> TestResultMessage
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
msg
    }
  where
    msg :: String
msg =
      case SomeException -> Maybe SkeletestError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
        -- In GHC 9.10+, SomeException shows the callstack, which we don't
        -- want to see for known Skeletest errors
        Just (SkeletestError
err :: SkeletestError) -> SkeletestError -> String
forall e. Exception e => e -> String
displayException SkeletestError
err
        Maybe SkeletestError
Nothing -> SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e

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

data AssertionFail = AssertionFail
  { AssertionFail -> TestInfo
testInfo :: TestInfo
  , AssertionFail -> Text
testFailMessage :: Text
  , AssertionFail -> FailContext
testFailContext :: FailContext
  , AssertionFail -> CallStack
callStack :: CallStack
  }
  deriving (Int -> AssertionFail -> ShowS
[AssertionFail] -> ShowS
AssertionFail -> String
(Int -> AssertionFail -> ShowS)
-> (AssertionFail -> String)
-> ([AssertionFail] -> ShowS)
-> Show AssertionFail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AssertionFail -> ShowS
showsPrec :: Int -> AssertionFail -> ShowS
$cshow :: AssertionFail -> String
show :: AssertionFail -> String
$cshowList :: [AssertionFail] -> ShowS
showList :: [AssertionFail] -> ShowS
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{FailContext
CallStack
Text
TestInfo
testInfo :: AssertionFail -> TestInfo
testFailMessage :: AssertionFail -> Text
testFailContext :: AssertionFail -> FailContext
callStack :: AssertionFail -> CallStack
testInfo :: TestInfo
testFailMessage :: Text
testFailContext :: FailContext
callStack :: CallStack
..} = do
  prettyStackTrace <- ((String, SrcLoc) -> IO Text)
-> [(String, SrcLoc)] -> IO FailContext
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 (String, SrcLoc) -> IO Text
forall {a}. (a, SrcLoc) -> IO Text
renderCallLine ([(String, SrcLoc)] -> IO FailContext)
-> ([(String, SrcLoc)] -> [(String, SrcLoc)])
-> [(String, SrcLoc)]
-> IO FailContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, SrcLoc)] -> [(String, SrcLoc)]
forall a. [a] -> [a]
reverse ([(String, SrcLoc)] -> IO FailContext)
-> [(String, SrcLoc)] -> IO FailContext
forall a b. (a -> b) -> a -> b
$ CallStack -> [(String, SrcLoc)]
GHC.getCallStack CallStack
callStack
  pure . Text.intercalate "\n\n" . concat $
    [ prettyStackTrace
    , if null testFailContext
        then []
        else [Text.intercalate "\n" $ reverse testFailContext]
    , [testFailMessage]
    ]
  where
    renderCallLine :: (a, SrcLoc) -> IO Text
renderCallLine (a
_, SrcLoc
loc) = do
      let
        path :: String
path = SrcLoc -> String
GHC.srcLocFile SrcLoc
loc
        lineNum :: Int
lineNum = SrcLoc -> Int
GHC.srcLocStartLine SrcLoc
loc
        startCol :: Int
startCol = SrcLoc -> Int
GHC.srcLocStartCol SrcLoc
loc
        endCol :: Int
endCol = SrcLoc -> Int
GHC.srcLocEndCol SrcLoc
loc

      mLine <-
        IO Text -> IO (Either SomeException Text)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (String -> IO Text
Text.readFile String
path) IO (Either SomeException Text)
-> (Either SomeException Text -> IO (Maybe Text))
-> IO (Maybe Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Right Text
srcFile -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Maybe Text
getLineNum Int
lineNum Text
srcFile
          Left (SomeException
_ :: SomeException) -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
      let (srcLine, pointerLine) =
            case mLine of
              Just Text
line ->
                ( Text
line
                , Int -> Text -> Text
Text.replicate (Int
startCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.replicate (Int
endCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
startCol) Text
"^"
                )
              Maybe Text
Nothing ->
                ( Text
"<unknown line>"
                , Text
""
                )

      pure . Text.intercalate "\n" $
        [ Text.pack path <> ":" <> (Text.pack . show) lineNum <> ":"
        , "|"
        , "| " <> srcLine
        , "| " <> pointerLine
        ]

    getLineNum :: Int -> Text -> Maybe Text
getLineNum Int
n = FailContext -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe (FailContext -> Maybe Text)
-> (Text -> FailContext) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FailContext -> FailContext
forall a. Int -> [a] -> [a]
take Int
1 (FailContext -> FailContext)
-> (Text -> FailContext) -> Text -> FailContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FailContext -> FailContext
forall a. Int -> [a] -> [a]
drop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (FailContext -> FailContext)
-> (Text -> FailContext) -> Text -> FailContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FailContext
Text.lines