-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# OPTIONS_HADDOCK not-home #-}

-- | Pretty-printers for reports in Tasty logs.
module Test.Cleveland.Tasty.Internal.Report
  ( module Test.Cleveland.Tasty.Internal.Report
  ) where

import Data.Char (isPrint, isSpace)
import Data.Ix (Ix(inRange))
import Data.List qualified as List
import Data.Text.IO.Utf8 qualified as Utf8
import Fmt (Buildable(build), Builder, indentF, padLeftF, unlinesF, (+|), (|+))
import GHC.Stack (SrcLoc(..))
import System.Directory (makeRelativeToCurrentDirectory)
import System.IO.Error
  (IOError, catchIOError, ioError, isAlreadyInUseError, isDoesNotExistError, isPermissionError)
import Unsafe qualified

-- HLint wrongfully thinks we are not using these things from universum,
-- perhaps because of morley-prelude.
{-# ANN module ("HLint: ignore Use 'getCallStack' from Universum" :: Text) #-}
{-# ANN module ("HLint: ignore Use 'prettyCallStack' from Universum" :: Text) #-}


{-
Note [Cleveland & callstacks]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Cleveland's reports are very similar to Hedgehog's. They both:
  1. Display the source code line where the error occurred and some context around it.
  2. Display the error message right below the offending line.

However, there are some notable differences:
  1. Cleveland shows (by default) 5 lines before and after the error location,
     whereas Hedgehog is smarter and displays the full top-level declaration.
      * The number of lines to display can be configured with `--cleveland-context-lines`.
      * This decision was made because tasty tests are sometimes embedded in a (much)
        larger test tree, and displaying the whole top-level declaration would add
        a lot of clutter and make the report unreadable.

  2. Cleveland displays the full callstack at the bottom, with the filepath/line/column.
     This is helpful because in some editors/terminals, you can click on the filepath
     link and have the editor jump straight to that location in the source code.

  3. Hedgehog displays the source code for all callstack frames and annotates the top-most
     frame with the error message, whereas Cleveland displays only the bottom-most frame.

-}

-- | Pretty-prints an error by displaying:
--
-- * the source code where the error occurred
-- * the expression that threw the error
-- * an associated error message below said expression
-- * the error's callstack
formatError
  :: Natural -- ^ The number of source code lines to print before and after the location of the error
  -> CallStack -- ^ The error's callstack
  -> String -- ^ The error message to display below the expression that caused the error
  -> IO Builder
formatError :: Natural -> CallStack -> [Char] -> IO Builder
formatError Natural
contextLines CallStack
cstack [Char]
errMsg = do
  case CallStack -> Maybe SrcLoc
getLocation CallStack
cstack of
    Maybe SrcLoc
Nothing -> Builder -> IO Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> IO Builder) -> Builder -> IO Builder
forall a b. (a -> b) -> a -> b
$ [Char] -> Builder
forall p. Buildable p => p -> Builder
build [Char]
errMsg
    Just SrcLoc
loc -> (IO Builder -> (IOError -> IO Builder) -> IO Builder)
-> (IOError -> IO Builder) -> IO Builder -> IO Builder
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO Builder -> (IOError -> IO Builder) -> IO Builder
forall a. IO a -> (IOError -> IO a) -> IO a
catchIOError IOError -> IO Builder
handleIOError do
      [Char]
path <- [Char] -> IO [Char]
makeRelativeToCurrentDirectory (SrcLoc -> [Char]
srcLocFile SrcLoc
loc)
      [Line]
fileLines <- [Text] -> [Line]
numbered ([Text] -> [Line]) -> (Text -> [Text]) -> Text -> [Line]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
lines (Text -> [Line]) -> IO Text -> IO [Line]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Text
forall (m :: * -> *). MonadIO m => [Char] -> m Text
Utf8.readFile [Char]
path

      let ([Line]
beforeLines, NonEmpty Line
errorLines, [Line]
afterLines) = Natural -> SrcLoc -> [Line] -> ([Line], NonEmpty Line, [Line])
linesAround Natural
contextLines SrcLoc
loc [Line]
fileLines

      -- Calculate how many digits we need to display line numbers.
      -- If we're about to display lines 9 to 101, then we need 3 digits total.
      let lineNumberPadding :: Int
lineNumberPadding =
            Text -> Int
forall t. Container t => t -> Int
length (Text -> Int) -> (NonEmpty Int -> Text) -> NonEmpty Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show @Text (Int -> Text) -> (NonEmpty Int -> Int) -> NonEmpty Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
maximum (NonEmpty Int -> Int) -> NonEmpty Int -> Int
forall a b. (a -> b) -> a -> b
$ Line -> Int
lineNumber (Line -> Int) -> NonEmpty Line -> NonEmpty Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              ([Line]
beforeLines [Line] -> NonEmpty Line -> NonEmpty Line
forall {a}. [a] -> NonEmpty a -> NonEmpty a
`appendNE` NonEmpty Line
errorLines NonEmpty Line -> [Line] -> NonEmpty Line
forall {a}. NonEmpty a -> [a] -> NonEmpty a
`prependNE` [Line]
afterLines)
          appendNE :: [a] -> NonEmpty a -> NonEmpty a
appendNE [a]
xs NonEmpty a
ys = NonEmpty a
-> (NonEmpty a -> NonEmpty a) -> Maybe (NonEmpty a) -> NonEmpty a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NonEmpty a
ys (NonEmpty a -> NonEmpty a -> NonEmpty a
forall a. Semigroup a => a -> a -> a
<> NonEmpty a
ys) (Maybe (NonEmpty a) -> NonEmpty a)
-> Maybe (NonEmpty a) -> NonEmpty a
forall a b. (a -> b) -> a -> b
$ [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [a]
xs
          prependNE :: NonEmpty a -> [a] -> NonEmpty a
prependNE (a
x :| [a]
xs) [a]
ys = a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| ([a]
xs [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
ys)

      Builder -> IO Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> IO Builder) -> Builder -> IO Builder
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$
        [ Int -> [Char] -> Builder
headerF Int
lineNumberPadding [Char]
path ]
        [Builder] -> [Builder] -> [Builder]
forall a. Semigroup a => a -> a -> a
<> (Int -> Line -> Builder
srcLineF Int
lineNumberPadding (Line -> Builder) -> [Line] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Line]
beforeLines)
        [Builder] -> [Builder] -> [Builder]
forall a. Semigroup a => a -> a -> a
<> (Int -> Line -> Builder
srcLineF Int
lineNumberPadding (Line -> Builder) -> [Line] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Line -> [Element (NonEmpty Line)]
forall t. Container t => t -> [Element t]
toList NonEmpty Line
errorLines)
        [Builder] -> [Builder] -> [Builder]
forall a. Semigroup a => a -> a -> a
<> Int -> SrcLoc -> NonEmpty Line -> [Char] -> [Builder]
errorMsgF Int
lineNumberPadding SrcLoc
loc NonEmpty Line
errorLines [Char]
errMsg
        [Builder] -> [Builder] -> [Builder]
forall a. Semigroup a => a -> a -> a
<> (Int -> Line -> Builder
srcLineF Int
lineNumberPadding (Line -> Builder) -> [Line] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Line]
afterLines)
        [Builder] -> [Builder] -> [Builder]
forall a. Semigroup a => a -> a -> a
<> [Builder
"", [Char] -> Builder
forall p. Buildable p => p -> Builder
build (CallStack -> [Char]
prettyCallStack CallStack
cstack)]
  where
    handleIOError :: IOError -> IO Builder
    handleIOError :: IOError -> IO Builder
handleIOError IOError
err =
      if IOError -> Bool
isAlreadyInUseError IOError
err Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| IOError -> Bool
isDoesNotExistError IOError
err Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| IOError -> Bool
isPermissionError IOError
err
        then Builder -> IO Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> IO Builder) -> Builder -> IO Builder
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF ([[Char]] -> Builder) -> [[Char]] -> Builder
forall a b. (a -> b) -> a -> b
$
          [ [Char]
errMsg
          , [Char]
""
          , CallStack -> [Char]
prettyCallStack CallStack
cstack
          ]
        else IOError -> IO Builder
forall a. IOError -> IO a
ioError IOError
err

getLocation :: CallStack -> Maybe SrcLoc
getLocation :: CallStack -> Maybe SrcLoc
getLocation = (([Char], SrcLoc) -> SrcLoc)
-> Maybe ([Char], SrcLoc) -> Maybe SrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char], SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd (Maybe ([Char], SrcLoc) -> Maybe SrcLoc)
-> (CallStack -> Maybe ([Char], SrcLoc))
-> CallStack
-> Maybe SrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Char], SrcLoc)] -> Maybe ([Char], SrcLoc)
forall {a}. [a] -> Maybe a
safeLast ([([Char], SrcLoc)] -> Maybe ([Char], SrcLoc))
-> (CallStack -> [([Char], SrcLoc)])
-> CallStack
-> Maybe ([Char], SrcLoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> [([Char], SrcLoc)]
getCallStack
  where
    safeLast :: [a] -> Maybe a
safeLast = \case
      [] -> Maybe a
forall a. Maybe a
Nothing
      [a]
l -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall a. [a] -> a
Unsafe.last [a]
l

data Line = Line
  { Line -> Text
lineText :: Text
  , Line -> Int
lineNumber :: Int
  }

-- | Attach line numbers to each line of source code.
numbered :: [Text] -> [Line]
numbered :: [Text] -> [Line]
numbered [Text]
texts = (Text -> Int -> Line) -> (Text, Int) -> Line
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Int -> Line
Line ((Text, Int) -> Line) -> [(Text, Int)] -> [Line]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Text]
texts [Text] -> [Int] -> [(Text, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
1..])

-- | Given a list of source code lines, returns:
--
-- * the @n@ lines that preceed the location of the error
-- * the line(s) where the error occurred
-- * the @n@ lines that follow the location of the error
linesAround :: Natural -> SrcLoc -> [Line] -> ([Line], NonEmpty Line, [Line])
linesAround :: Natural -> SrcLoc -> [Line] -> ([Line], NonEmpty Line, [Line])
linesAround (forall a b. (HasCallStack, Integral a, Integral b) => a -> b
Unsafe.fromIntegral @_ @Int -> Int
n) SrcLoc
loc [Line]
xs =
  ( [Line]
beforeLines
  , Maybe (NonEmpty Line) -> NonEmpty Line
forall a. HasCallStack => Maybe a -> a
Unsafe.fromJust (Maybe (NonEmpty Line) -> NonEmpty Line)
-> Maybe (NonEmpty Line) -> NonEmpty Line
forall a b. (a -> b) -> a -> b
$ [Line] -> Maybe (NonEmpty Line)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Line]
errorLines -- <- errorLines is guaranteed to always have at least 1 line
  , [Line]
afterLines
  )
  where
    beforeLines :: [Line]
beforeLines = (Line -> Bool) -> [Line] -> [Line]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Line
l -> (SrcLoc -> Int
srcLocStartLine SrcLoc
loc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n , SrcLoc -> Int
srcLocStartLine SrcLoc
loc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
`inRange` (Line -> Int
lineNumber Line
l)) [Line]
xs
    errorLines :: [Line]
errorLines  = (Line -> Bool) -> [Line] -> [Line]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Line
l -> (SrcLoc -> Int
srcLocStartLine SrcLoc
loc     , SrcLoc -> Int
srcLocEndLine SrcLoc
loc      ) (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
`inRange` (Line -> Int
lineNumber Line
l)) [Line]
xs
    afterLines :: [Line]
afterLines  = (Line -> Bool) -> [Line] -> [Line]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Line
l -> (SrcLoc -> Int
srcLocEndLine SrcLoc
loc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1   , SrcLoc -> Int
srcLocEndLine SrcLoc
loc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n  ) (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
`inRange` (Line -> Int
lineNumber Line
l)) [Line]
xs

----------------------------------------------------------------------------
-- Formatters
----------------------------------------------------------------------------

verticalBorder :: Builder
verticalBorder :: Builder
verticalBorder = Builder
" ┃ "

headerF :: Int -> FilePath -> Builder
headerF :: Int -> [Char] -> Builder
headerF Int
lineNumberPadding [Char]
path =
  Int -> Builder -> Builder
indentF Int
lineNumberPadding (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
    Builder
" ┏━━ " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| [Char]
path [Char] -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" ━━━"

srcLineF :: Int -> Line -> Builder
srcLineF :: Int -> Line -> Builder
srcLineF Int
lineNumberPadding Line
line =
  Int -> Char -> Int -> Builder
forall a. Buildable a => Int -> Char -> a -> Builder
padLeftF Int
lineNumberPadding Char
' ' (Line -> Int
lineNumber Line
line) Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Builder
verticalBorder Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Text -> Builder
forall p. Buildable p => p -> Builder
build (Line -> Text
lineText Line
line)

errorMsgF :: Int -> SrcLoc -> NonEmpty Line -> String -> [Builder]
errorMsgF :: Int -> SrcLoc -> NonEmpty Line -> [Char] -> [Builder]
errorMsgF Int
lineNumberPadding SrcLoc
loc NonEmpty Line
errorLines [Char]
errMsg =
  Int -> Builder -> Builder
indentF Int
lineNumberPadding (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder
addPadding (Builder -> Builder) -> [Builder] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (Builder
carets Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: [Builder]
errLines)
  where
    (Int
startColumn, Int
endColumn) = SrcLoc -> NonEmpty Line -> (Int, Int)
caretColumns SrcLoc
loc NonEmpty Line
errorLines

    addPadding :: Builder -> Builder
    addPadding :: Builder -> Builder
addPadding Builder
line =
      Builder
verticalBorder Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Int -> Builder -> Builder
indentF (Int
startColumn Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Builder
line

    carets :: Builder
    carets :: Builder
carets = [Char] -> Builder
forall p. Buildable p => p -> Builder
build ([Char] -> Builder) -> [Char] -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
endColumn Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
startColumn) Char
'^'

    errLines :: [Builder]
    errLines :: [Builder]
errLines = [Char] -> [[Char]]
List.lines [Char]
errMsg [[Char]] -> ([Char] -> Builder) -> [Builder]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \[Char]
line ->
      Builder
"| " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| [Char] -> Builder
forall p. Buildable p => p -> Builder
build [Char]
line

-- | Calculates the start and end columns for drawing carets (^).
--
-- If the expression that caused the error is in a single line,
-- then we can simply use the column numbers from 'SrcLoc'.
--
-- However, if the expression spans 2 or more lines, then it's a bit more complicated.
-- For example, say we have this expression:
--
-- > someFunc
-- >  arg
--
-- Then 'SrcLoc'\'s start column will be 1 and end column will be 5.
-- However, we actually want the carets to be displayed from columns 1 to 9, like so:
--
-- > someFunc
-- >  arg
-- > ^^^^^^^^
--
-- See more examples in the @TestSuite.Cleveland.Tasty.Report.Examples@ module.
caretColumns :: SrcLoc -> NonEmpty Line -> (Int, Int)
caretColumns :: SrcLoc -> NonEmpty Line -> (Int, Int)
caretColumns SrcLoc
loc NonEmpty Line
errorLines =
  ( NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
minimum (SrcLoc -> Int
srcLocStartCol SrcLoc
loc Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| (Line -> Int) -> [Line] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Line -> Int
lineStartColumn (NonEmpty Line -> [Line]
forall a. NonEmpty a -> [a]
tail NonEmpty Line
errorLines))
  , NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
maximum (SrcLoc -> Int
srcLocEndCol SrcLoc
loc Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| (Line -> Int) -> [Line] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Line -> Int
lineEndColumn (NonEmpty Line -> [Line]
forall a. NonEmpty a -> [a]
init NonEmpty Line
errorLines))
  )
  where
    lineEndColumn :: Line -> Int
    lineEndColumn :: Line -> Int
lineEndColumn (Line Text
text Int
_) =
      Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Char] -> Int
forall t. Container t => t -> Int
length ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isPrint (Text -> [Char]
forall a. ToString a => a -> [Char]
toString Text
text))

    lineStartColumn :: Line -> Int
    lineStartColumn :: Line -> Int
lineStartColumn (Line Text
text Int
_) =
      Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Char] -> Int
forall t. Container t => t -> Int
length ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isSpace (Text -> [Char]
forall a. ToString a => a -> [Char]
toString Text
text))