{-# LANGUAGE OverloadedStrings #-}
--
-- Copyright (c) 2005-2022   Stefan Wehr - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--
{- |

HTF's machine-readable output is a sequence of JSON messages. Each message is terminated
by a newline followed by two semicolons followed again by a newline.

There are four types of JSON messages. Each JSON object has a "type" attribute denoting
this type. The types are: @test-start@, @test-end@, and @test-list@, @test-results@.
Their haskell representations are 'TestStartEventObj', 'TestEndEventObj', 'TestListObj', and
'TestResultsObj'. The corresponding JSON rendering is defined in this module.

  *  The @test-start@ message denotes the start of a single test case. Example (whitespace inserted for better readability):

> {"test": {"flatName": "Main:nonEmpty",
>           "location": {"file": "Tutorial.hs", "line": 17},
>           "path": ["Main","nonEmpty"],
>           "sort": "unit-test"},
>  "type":"test-start"}

  *  The @test-end@ message denotes the end of a single test case. It contains information about the outcome of the test. Example:

> {"result": "pass",
>  "message":"",
>  "test":{"flatName": "Main:nonEmpty",
>          "location": {"file": "Tutorial.hs", "line": 17},
>          "path": ["Main","nonEmpty"],
>          "sort": "unit-test"},
>  "wallTime": 0,  // in milliseconds
>  "type": "test-end",
>  "location":null}

  *  The @test-results@ message occurs after all tests have been run and summarizes their results. Example:

> {"failures": 0,
>  "passed": 4,
>  "pending": 0,
>  "wallTime": 39, // in milliseconds
>  "errors": 0,
>  "type":"test-results"}

  *  The @test-list@ message contains all tests defined. It is used for the --list commandline options. Example:

> {"tests": [{"flatName":"Main:nonEmpty","location":{"file":"Tutorial.hs","line":17},"path":["Main","nonEmpty"],"sort":"unit-test"},
>            {"flatName":"Main:empty","location":{"file":"Tutorial.hs","line":19},"path":["Main","empty"],"sort":"unit-test"},
>            {"flatName":"Main:reverse","location":{"file":"Tutorial.hs","line":22},"path":["Main","reverse"],"sort":"quickcheck-property"},
>            {"flatName":"Main:reverseReplay","location":{"file":"Tutorial.hs","line":24},"path":["Main","reverseReplay"],"sort":"quickcheck-property"}],
>  "type":"test-list"}

For an exact specification, please have a look at the code of this module.
-}
module Test.Framework.JsonOutput (

    TestStartEventObj, TestEndEventObj, TestListObj, TestObj, TestResultsObj,

    mkTestStartEventObj, mkTestEndEventObj, mkTestListObj, mkTestResultsObj,

    decodeObj, HTFJsonObj

) where

import Test.Framework.TestTypes
import Test.Framework.Location
import Test.Framework.Colors
import Test.Framework.TestInterface

import qualified Data.Aeson as J
import Data.Aeson ((.=))

import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSLC
import qualified Data.Text as T

class J.ToJSON a => HTFJsonObj a

-- "test-start" message
data TestStartEventObj
    = TestStartEventObj
      { TestStartEventObj -> TestObj
ts_test :: TestObj }

instance J.ToJSON TestStartEventObj where
    toJSON :: TestStartEventObj -> Value
toJSON TestStartEventObj
ts =
        [Pair] -> Value
J.object [Key
"type" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
J.String Text
"test-start"
                 ,Key
"test" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= TestObj -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestStartEventObj -> TestObj
ts_test TestStartEventObj
ts)]

instance HTFJsonObj TestStartEventObj

-- "test-end" message
data TestEndEventObj
    = TestEndEventObj
      { TestEndEventObj -> TestObj
te_test :: TestObj
      , TestEndEventObj -> TestResult
te_result :: TestResult
      , TestEndEventObj -> HtfStack
te_stack :: HtfStack
      , TestEndEventObj -> Text
te_message :: T.Text
      , TestEndEventObj -> Int
te_wallTimeMs :: Int
      , TestEndEventObj -> Bool
te_timedOut :: Bool
      }

instance J.ToJSON TestEndEventObj where
    toJSON :: TestEndEventObj -> Value
toJSON TestEndEventObj
te =
        [Pair] -> Value
J.object [Key
"type" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
J.String Text
"test-end"
                 ,Key
"test" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= TestObj -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestEndEventObj -> TestObj
te_test TestEndEventObj
te)
                 ,Key
"location" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Location -> Value
forall a. ToJSON a => a -> Value
J.toJSON (HtfStack -> Maybe Location
failureLocationFromStack (TestEndEventObj -> HtfStack
te_stack TestEndEventObj
te))
                 ,Key
"callers" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=
                    [Value] -> Value
forall a. ToJSON a => a -> Value
J.toJSON ((HtfStackEntry -> Value) -> [HtfStackEntry] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (\HtfStackEntry
entry -> [Pair] -> Value
J.object [Key
"location" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Location -> Value
forall a. ToJSON a => a -> Value
J.toJSON (HtfStackEntry -> Location
hse_location HtfStackEntry
entry)
                                                      ,Key
"message" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe String -> Value
forall a. ToJSON a => a -> Value
J.toJSON (HtfStackEntry -> Maybe String
hse_message HtfStackEntry
entry)])
                              (HtfStack -> [HtfStackEntry]
restCallStack (TestEndEventObj -> HtfStack
te_stack TestEndEventObj
te)))
                 ,Key
"result" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= TestResult -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestEndEventObj -> TestResult
te_result TestEndEventObj
te)
                 ,Key
"message" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestEndEventObj -> Text
te_message TestEndEventObj
te)
                 ,Key
"wallTime" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestEndEventObj -> Int
te_wallTimeMs TestEndEventObj
te)
                 ,Key
"timedOut" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestEndEventObj -> Bool
te_timedOut TestEndEventObj
te)]

instance HTFJsonObj TestEndEventObj

-- "test-list" message
data TestListObj
    = TestListObj
      { TestListObj -> [TestObj]
tlm_tests :: [TestObj]
      }

instance J.ToJSON TestListObj where
    toJSON :: TestListObj -> Value
toJSON TestListObj
tl =
        [Pair] -> Value
J.object [Key
"type" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
J.String Text
"test-list"
                 ,Key
"tests" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [TestObj] -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestListObj -> [TestObj]
tlm_tests TestListObj
tl)]

instance HTFJsonObj TestListObj

-- "test-results"
data TestResultsObj
    = TestResultsObj
      { TestResultsObj -> Int
tr_wallTimeMs :: Int
      , TestResultsObj -> Int
tr_passed :: Int
      , TestResultsObj -> Int
tr_pending :: Int
      , TestResultsObj -> Int
tr_failed :: Int
      , TestResultsObj -> Int
tr_errors :: Int
      , TestResultsObj -> Int
tr_timedOut :: Int
      , TestResultsObj -> Int
tr_filtered :: Int
      }

instance J.ToJSON TestResultsObj where
    toJSON :: TestResultsObj -> Value
toJSON TestResultsObj
r = [Pair] -> Value
J.object [Key
"type" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
J.String Text
"test-results"
                        ,Key
"passed" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestResultsObj -> Int
tr_passed TestResultsObj
r)
                        ,Key
"pending" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestResultsObj -> Int
tr_pending TestResultsObj
r)
                        ,Key
"failures" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestResultsObj -> Int
tr_failed TestResultsObj
r)
                        ,Key
"errors" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestResultsObj -> Int
tr_errors TestResultsObj
r)
                        ,Key
"timedOut" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestResultsObj -> Int
tr_timedOut TestResultsObj
r)
                        ,Key
"filtered" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestResultsObj -> Int
tr_filtered TestResultsObj
r)
                        ,Key
"wallTime" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestResultsObj -> Int
tr_wallTimeMs TestResultsObj
r)]

instance HTFJsonObj TestResultsObj

data TestObj
    = TestObj
      { TestObj -> String
to_flatName :: String
      , TestObj -> TestPath
to_path :: TestPath
      , TestObj -> Maybe Location
to_location :: Maybe Location
      , TestObj -> TestSort
to_sort :: TestSort
      }

instance J.ToJSON TestObj where
    toJSON :: TestObj -> Value
toJSON TestObj
t = [Pair] -> Value
J.object ([Key
"flatName" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestObj -> String
to_flatName TestObj
t)
                         ,Key
"path" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= TestPath -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestObj -> TestPath
to_path TestObj
t)
                         ,Key
"sort" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= TestSort -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestObj -> TestSort
to_sort TestObj
t)] [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++
                         (case TestObj -> Maybe Location
to_location TestObj
t of
                            Just Location
loc -> [Key
"location" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Location -> Value
forall a. ToJSON a => a -> Value
J.toJSON Location
loc]
                            Maybe Location
Nothing -> []))

instance J.ToJSON TestPath where
    toJSON :: TestPath -> Value
toJSON TestPath
p = [Maybe String] -> Value
forall a. ToJSON a => a -> Value
J.toJSON (TestPath -> [Maybe String]
testPathToList TestPath
p)

instance J.ToJSON TestSort where
    toJSON :: TestSort -> Value
toJSON TestSort
s =
        case TestSort
s of
          TestSort
UnitTest -> Text -> Value
J.String Text
"unit-test"
          TestSort
QuickCheckTest -> Text -> Value
J.String Text
"quickcheck-property"
          TestSort
BlackBoxTest -> Text -> Value
J.String Text
"blackbox-test"


instance J.ToJSON Location where
    toJSON :: Location -> Value
toJSON Location
loc = [Pair] -> Value
J.object [Key
"file" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Value
forall a. ToJSON a => a -> Value
J.toJSON (Location -> String
fileName Location
loc)
                          ,Key
"line" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
J.toJSON (Location -> Int
lineNumber Location
loc)]


mkTestObj :: GenFlatTest a -> String -> TestObj
mkTestObj :: GenFlatTest a -> String -> TestObj
mkTestObj GenFlatTest a
ft String
flatName =
    String -> TestPath -> Maybe Location -> TestSort -> TestObj
TestObj String
flatName (GenFlatTest a -> TestPath
forall a. GenFlatTest a -> TestPath
ft_path GenFlatTest a
ft) (GenFlatTest a -> Maybe Location
forall a. GenFlatTest a -> Maybe Location
ft_location GenFlatTest a
ft) (GenFlatTest a -> TestSort
forall a. GenFlatTest a -> TestSort
ft_sort GenFlatTest a
ft)

mkTestStartEventObj :: FlatTest -> String -> TestStartEventObj
mkTestStartEventObj :: FlatTest -> String -> TestStartEventObj
mkTestStartEventObj FlatTest
ft String
flatName =
    TestObj -> TestStartEventObj
TestStartEventObj (FlatTest -> String -> TestObj
forall a. GenFlatTest a -> String -> TestObj
mkTestObj FlatTest
ft String
flatName)

mkTestEndEventObj :: FlatTestResult -> String -> TestEndEventObj
mkTestEndEventObj :: FlatTestResult -> String -> TestEndEventObj
mkTestEndEventObj FlatTestResult
ftr String
flatName =
    let r :: RunResult
r = FlatTestResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload FlatTestResult
ftr
        msg :: Text
msg = ColorString -> Bool -> Text
renderColorString (RunResult -> ColorString
rr_message RunResult
r) Bool
False
    in TestObj
-> TestResult -> HtfStack -> Text -> Int -> Bool -> TestEndEventObj
TestEndEventObj (FlatTestResult -> String -> TestObj
forall a. GenFlatTest a -> String -> TestObj
mkTestObj FlatTestResult
ftr String
flatName) (RunResult -> TestResult
rr_result RunResult
r) (RunResult -> HtfStack
rr_stack RunResult
r)
                       Text
msg (RunResult -> Int
rr_wallTimeMs RunResult
r) (RunResult -> Bool
rr_timeout RunResult
r)

mkTestListObj :: [(FlatTest, String)] -> TestListObj
mkTestListObj :: [(FlatTest, String)] -> TestListObj
mkTestListObj [(FlatTest, String)]
l =
    [TestObj] -> TestListObj
TestListObj (((FlatTest, String) -> TestObj)
-> [(FlatTest, String)] -> [TestObj]
forall a b. (a -> b) -> [a] -> [b]
map (\(FlatTest
ft, String
flatName) -> FlatTest -> String -> TestObj
forall a. GenFlatTest a -> String -> TestObj
mkTestObj FlatTest
ft String
flatName) [(FlatTest, String)]
l)

mkTestResultsObj :: ReportGlobalResultsArg -> TestResultsObj
mkTestResultsObj :: ReportGlobalResultsArg -> TestResultsObj
mkTestResultsObj ReportGlobalResultsArg
arg =
    TestResultsObj :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> TestResultsObj
TestResultsObj
    { tr_wallTimeMs :: Int
tr_wallTimeMs = ReportGlobalResultsArg -> Int
rgra_timeMs ReportGlobalResultsArg
arg
    , tr_passed :: Int
tr_passed = [FlatTestResult] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_passed ReportGlobalResultsArg
arg)
    , tr_pending :: Int
tr_pending = [FlatTestResult] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_pending ReportGlobalResultsArg
arg)
    , tr_failed :: Int
tr_failed = [FlatTestResult] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_failed ReportGlobalResultsArg
arg)
    , tr_errors :: Int
tr_errors = [FlatTestResult] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_errors ReportGlobalResultsArg
arg)
    , tr_timedOut :: Int
tr_timedOut = [FlatTestResult] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_timedOut ReportGlobalResultsArg
arg)
    , tr_filtered :: Int
tr_filtered = [FlatTest] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReportGlobalResultsArg -> [FlatTest]
rgra_filtered ReportGlobalResultsArg
arg)
    }

decodeObj :: HTFJsonObj a => a -> BSL.ByteString
decodeObj :: a -> ByteString
decodeObj a
x =
    a -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode a
x ByteString -> ByteString -> ByteString
`BSL.append` (String -> ByteString
BSLC.pack String
"\n;;\n")