JsonOutput.hs

{-# 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
      { ts_test :: TestObj }

instance J.ToJSON TestStartEventObj where
    toJSON ts =
        J.object ["type" .= J.String "test-start"
                 ,"test" .= J.toJSON (ts_test ts)]

instance HTFJsonObj TestStartEventObj

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

instance J.ToJSON TestEndEventObj where
    toJSON te =
        J.object ["type" .= J.String "test-end"
                 ,"test" .= J.toJSON (te_test te)
                 ,"location" .= J.toJSON (failureLocationFromStack (te_stack te))
                 ,"callers" .=
                    J.toJSON (map (\entry -> J.object ["location" .= J.toJSON (hse_location entry)
                                                      ,"message" .= J.toJSON (hse_message entry)])
                              (restCallStack (te_stack te)))
                 ,"result" .= J.toJSON (te_result te)
                 ,"message" .= J.toJSON (te_message te)
                 ,"wallTime" .= J.toJSON (te_wallTimeMs te)
                 ,"timedOut" .= J.toJSON (te_timedOut te)]

instance HTFJsonObj TestEndEventObj

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

instance J.ToJSON TestListObj where
    toJSON tl =
        J.object ["type" .= J.String "test-list"
                 ,"tests" .= J.toJSON (tlm_tests tl)]

instance HTFJsonObj TestListObj

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

instance J.ToJSON TestResultsObj where
    toJSON r = J.object ["type" .= J.String "test-results"
                        ,"passed" .= J.toJSON (tr_passed r)
                        ,"pending" .= J.toJSON (tr_pending r)
                        ,"failures" .= J.toJSON (tr_failed r)
                        ,"errors" .= J.toJSON (tr_errors r)
                        ,"timedOut" .= J.toJSON (tr_timedOut r)
                        ,"filtered" .= J.toJSON (tr_filtered r)
                        ,"wallTime" .= J.toJSON (tr_wallTimeMs r)]

instance HTFJsonObj TestResultsObj

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

instance J.ToJSON TestObj where
    toJSON t = J.object (["flatName" .= J.toJSON (to_flatName t)
                         ,"path" .= J.toJSON (to_path t)
                         ,"sort" .= J.toJSON (to_sort t)] ++
                         (case to_location t of
                            Just loc -> ["location" .= J.toJSON loc]
                            Nothing -> []))

instance J.ToJSON TestPath where
    toJSON p = J.toJSON (testPathToList p)

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


instance J.ToJSON Location where
    toJSON loc = J.object ["file" .= J.toJSON (fileName loc)
                          ,"line" .= J.toJSON (lineNumber loc)]


mkTestObj :: GenFlatTest a -> String -> TestObj
mkTestObj ft flatName =
    TestObj flatName (ft_path ft) (ft_location ft) (ft_sort ft)

mkTestStartEventObj :: FlatTest -> String -> TestStartEventObj
mkTestStartEventObj ft flatName =
    TestStartEventObj (mkTestObj ft flatName)

mkTestEndEventObj :: FlatTestResult -> String -> TestEndEventObj
mkTestEndEventObj ftr flatName =
    let r = ft_payload ftr
        msg = renderColorString (rr_message r) False
    in TestEndEventObj (mkTestObj ftr flatName) (rr_result r) (rr_stack r)
                       msg (rr_wallTimeMs r) (rr_timeout r)

mkTestListObj :: [(FlatTest, String)] -> TestListObj
mkTestListObj l =
    TestListObj (map (\(ft, flatName) -> mkTestObj ft flatName) l)

mkTestResultsObj :: ReportGlobalResultsArg -> TestResultsObj
mkTestResultsObj arg =
    TestResultsObj
    { tr_wallTimeMs = rgra_timeMs arg
    , tr_passed = length (rgra_passed arg)
    , tr_pending = length (rgra_pending arg)
    , tr_failed = length (rgra_failed arg)
    , tr_errors = length (rgra_errors arg)
    , tr_timedOut = length (rgra_timedOut arg)
    , tr_filtered = length (rgra_filtered arg)
    }

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