{-# OPTIONS_HADDOCK not-home #-}
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
{-# ANN module ("HLint: ignore Use 'getCallStack' from Universum" :: Text) #-}
{-# ANN module ("HLint: ignore Use 'prettyCallStack' from Universum" :: Text) #-}
formatError
:: Natural
-> CallStack
-> String
-> 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
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
}
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..])
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
, [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
verticalBorder :: Builder
verticalBorder :: Builder
verticalBorder = Builder
" ┃ "
headerF :: Int -> FilePath -> Builder
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
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))