{-# LANGUAGE StrictData #-}
{-# LANGUAGE OverloadedStrings #-}

-- | This module is internal! Use at your own risk. Breaking changes to
-- this module will not necessarily be reflected in PVP versions.
module Test.Hspec.Formatters.GithubAction.Internal where

import Prelude
import Control.Applicative
import Test.Hspec.Core.Util (joinPath)
import Test.Hspec.Api.Formatters.V2

-- | This option enhances a given 'Formatter' with annotations that will
-- show up on the correct test item failure. This allows you to use the
-- test output you want, and additionally get Github Action annotations.
withGithubActionFormatter :: Formatter -> Formatter
withGithubActionFormatter :: Formatter -> Formatter
withGithubActionFormatter Formatter
fmtr = Formatter
fmtr
  { formatterItemDone :: Path -> Item -> FormatM ()
formatterItemDone = \Path
path Item
item -> do
      Formatter -> Path -> Item -> FormatM ()
formatterItemDone Formatter
fmtr Path
path Item
item
      Path -> Item -> FormatM ()
emitGithubActionAnnotation Path
path Item
item
  }

-- | A representation of the Github Actions error format.
data ErrorCommand = ErrorCommand
    { ErrorCommand -> Maybe String
title   :: Maybe String
    , ErrorCommand -> Maybe String
file    :: Maybe String
    , ErrorCommand -> Maybe Int
line    :: Maybe Int
    , ErrorCommand -> Maybe Int
col     :: Maybe Int
    , ErrorCommand -> String
message :: String
    }

-- | Make a suitable error annotation from an hspec failure.
--
-- Not clear what to do with the Maybe Location here: do we use the one from
-- the Item, or this one? What if both or neither are available?
-- Also not clear whether to use itemInfo.
errorCommandFor :: Path -> Item -> Maybe Location -> FailureReason -> ErrorCommand
errorCommandFor :: Path -> Item -> Maybe Location -> FailureReason -> ErrorCommand
errorCommandFor specPath :: Path
specPath@([String]
_nesting, String
requirement) Item
item Maybe Location
mFailureLocation FailureReason
reason = ErrorCommand
    { -- requirement is used because it should always be non-empty and meaningful
      title :: Maybe String
title = forall a. a -> Maybe a
Just String
requirement
    , file :: Maybe String
file = Location -> String
locationFile   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Location
mloc
    , line :: Maybe Int
line = Location -> Int
locationLine   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Location
mloc
    , col :: Maybe Int
col  = Location -> Int
locationColumn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Location
mloc
    , message :: String
message = [String] -> String
unlines ([String]
messageHeaderLines forall a. [a] -> [a] -> [a]
++ [String]
messageBodyLines)
    }
  where
    -- prefer the location of the actual failure. if that is not present,
    -- fall  back to the test definition location
    mloc :: Maybe Location
mloc = Maybe Location
mFailureLocation forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Item -> Maybe Location
itemLocation Item
item
    -- Use the path to give a message header, so that the message is never empty.
    -- Empty messages seem to cause github actions to ignore the annotation.
    messageHeaderLines :: [String]
    messageHeaderLines :: [String]
messageHeaderLines = Path -> String
joinPath Path
specPath forall a. a -> [a] -> [a]
: if Item -> String
itemInfo Item
item forall a. Eq a => a -> a -> Bool
== String
"" then [] else [Item -> String
itemInfo Item
item]

    messageBodyLines :: [String]
    messageBodyLines :: [String]
messageBodyLines = case FailureReason
reason of
        FailureReason
NoReason -> []
        Reason String
str -> [String
str]
        ExpectedButGot Maybe String
preface String
expected String
actual ->
            let bodyLines :: [String]
bodyLines =
                    [ forall a. Monoid a => [a] -> a
mconcat [String
"expected: ", String
expected]
                    , forall a. Monoid a => [a] -> a
mconcat [String
"     got: ", String
actual  ]
                    ]
                headerLines :: [String]
headerLines = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\String
x -> [String
x]) Maybe String
preface
            in  [String]
headerLines forall a. [a] -> [a] -> [a]
++ [String]
bodyLines
        Error Maybe String
preface SomeException
err ->
            let bodyLines :: [String]
bodyLines = [forall a. Show a => a -> String
show SomeException
err]
                headerLines :: [String]
headerLines = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\String
x -> [String
x]) Maybe String
preface
            in  [String]
headerLines forall a. [a] -> [a] -> [a]
++ [String]
bodyLines

-- | The github actions command format.
formatErrorCommand :: ErrorCommand -> String
formatErrorCommand :: ErrorCommand -> String
formatErrorCommand ErrorCommand
ec = forall a. Monoid a => [a] -> a
mconcat
    [ String
"\n::error "
    , String
"title=", forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" String -> String
escapeProperty (ErrorCommand -> Maybe String
title ErrorCommand
ec), String
","
    , String
"file=", forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" String -> String
escapeProperty (ErrorCommand -> Maybe String
file ErrorCommand
ec), String
","
    , String
"line=", forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" forall a. Show a => a -> String
show (ErrorCommand -> Maybe Int
line ErrorCommand
ec), String
","
    , String
"col=", forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" forall a. Show a => a -> String
show (ErrorCommand -> Maybe Int
col ErrorCommand
ec)
    , String
"::"
    , String -> String
escapeData (ErrorCommand -> String
message ErrorCommand
ec)
    -- FIXME should check if on windows and use \r\n, as this is what the
    -- github library does.
    , String
"\n"
    ]

{-
function escapeData(s: any): string {
  return toCommandValue(s)
    .replace(/%/g, '%25')
    .replace(/\r/g, '%0D')
    .replace(/\n/g, '%0A')
}
function escapeProperty(s: any): string {
  return toCommandValue(s)
    .replace(/%/g, '%25')
    .replace(/\r/g, '%0D')
    .replace(/\n/g, '%0A')
    .replace(/:/g, '%3A')
    .replace(/,/g, '%2C')
}
-}

escapeData :: String -> String
escapeData :: String -> String
escapeData = (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Char -> String
replace)
  where
    replace :: Char -> String
replace Char
'%'  = String
"%25"
    replace Char
'\r' = String
"%0D"
    replace Char
'\n' = String
"%0A"
    replace Char
c    = [Char
c]

escapeProperty :: String -> String
escapeProperty :: String -> String
escapeProperty = (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Char -> String
replace)
  where
    replace :: Char -> String
replace Char
'%'  = String
"%25"
    replace Char
'\r' = String
"%0D"
    replace Char
'\n' = String
"%0A"
    replace Char
':'  = String
"%3A"
    replace Char
','  = String
"%2C"
    replace Char
c    = [Char
c]

-- | If you want to extend
emitGithubActionAnnotation :: Path -> Item -> FormatM ()
emitGithubActionAnnotation :: Path -> Item -> FormatM ()
emitGithubActionAnnotation Path
path Item
item = case Item -> Result
itemResult Item
item of
    Result
Success -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Pending Maybe Location
_ Maybe String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Failure Maybe Location
mLoc FailureReason
reason -> String -> FormatM ()
write forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorCommand -> String
formatErrorCommand forall a b. (a -> b) -> a -> b
$ Path -> Item -> Maybe Location -> FailureReason -> ErrorCommand
errorCommandFor Path
path Item
item Maybe Location
mLoc FailureReason
reason