Report.hs

-- 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 (justifyRight)
import Data.Text.IO.Utf8 qualified as Utf8
import Fmt (Buildable(build), Doc, indentF, 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 Doc
formatError contextLines cstack errMsg = do
  case getLocation cstack of
    Nothing -> pure $ build errMsg
    Just loc -> flip catchIOError handleIOError do
      path <- makeRelativeToCurrentDirectory (srcLocFile loc)
      fileLines <- numbered . lines <$> Utf8.readFile path

      let (beforeLines, errorLines, afterLines) = linesAround contextLines loc 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 =
            length . show @Text . maximum $ lineNumber <$>
              (beforeLines `appendNE` errorLines `prependNE` afterLines)
          appendNE xs ys = maybe ys (<> ys) $ nonEmpty xs
          prependNE (x :| xs) ys = x :| (xs <> ys)

      pure $ unlinesF $
        [ headerF lineNumberPadding path ]
        <> (srcLineF lineNumberPadding <$> beforeLines)
        <> (srcLineF lineNumberPadding <$> toList errorLines)
        <> errorMsgF lineNumberPadding loc errorLines errMsg
        <> (srcLineF lineNumberPadding <$> afterLines)
        <> ["", build (prettyCallStack cstack)]
  where
    handleIOError :: IOError -> IO Doc
    handleIOError err =
      if isAlreadyInUseError err || isDoesNotExistError err || isPermissionError err
        then pure $ unlinesF $
          [ errMsg
          , ""
          , prettyCallStack cstack
          ]
        else ioError err

getLocation :: CallStack -> Maybe SrcLoc
getLocation = fmap snd . safeLast . getCallStack
  where
    safeLast = \case
      [] -> Nothing
      l -> Just $ Unsafe.last l

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

-- | Attach line numbers to each line of source code.
numbered :: [Text] -> [Line]
numbered texts = uncurry Line <$> (texts `zip` [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 (Unsafe.fromIntegral @_ @Int -> n) loc xs =
  ( beforeLines
  , Unsafe.fromJust $ nonEmpty errorLines -- <- errorLines is guaranteed to always have at least 1 line
  , afterLines
  )
  where
    beforeLines = filter (\l -> (srcLocStartLine loc - n , srcLocStartLine loc - 1) `inRange` (lineNumber l)) xs
    errorLines  = filter (\l -> (srcLocStartLine loc     , srcLocEndLine loc      ) `inRange` (lineNumber l)) xs
    afterLines  = filter (\l -> (srcLocEndLine loc + 1   , srcLocEndLine loc + n  ) `inRange` (lineNumber l)) xs

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

verticalBorder :: Doc
verticalBorder = " ┃ "

headerF :: Int -> FilePath -> Doc
headerF lineNumberPadding path =
  indentF lineNumberPadding $
    " ┏━━ " +| path |+ " ━━━"

srcLineF :: Int -> Line -> Doc
srcLineF lineNumberPadding line =
  justifyRight lineNumberPadding ' ' (show $ lineNumber line)
     |+ verticalBorder +| build (lineText line)

errorMsgF :: Int -> SrcLoc -> NonEmpty Line -> String -> [Doc]
errorMsgF lineNumberPadding loc errorLines errMsg =
  indentF lineNumberPadding . addPadding <$>
    (carets : errLines)
  where
    (startColumn, endColumn) = caretColumns loc errorLines

    addPadding :: Doc -> Doc
    addPadding line =
      verticalBorder +| indentF (startColumn - 1) line

    carets :: Doc
    carets = build $ replicate (endColumn - startColumn) '^'

    errLines :: [Doc]
    errLines = List.lines errMsg <&> \line ->
      "| " +| build 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 loc errorLines =
  ( minimum (srcLocStartCol loc :| fmap lineStartColumn (tail errorLines))
  , maximum (srcLocEndCol loc :| fmap lineEndColumn (init errorLines))
  )
  where
    lineEndColumn :: Line -> Int
    lineEndColumn (Line text _) =
      1 + length (filter isPrint (toString text))

    lineStartColumn :: Line -> Int
    lineStartColumn (Line text _) =
      1 + length (takeWhile isSpace (toString text))