content: {-# 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
  --
  {-|
  
  This module defines functions for notifying all test reporters registered about
  particular events in the lifecycle of a test run.
  
  Further, it defines the standard test reporters for HTF's various output formats.
  
  -}
  module Test.Framework.TestReporter (
  
      IsParallel(..), isParallelFromBool, IsJsonOutput(..), IsXmlOutput(..),
      reportAllTests, reportGlobalStart, reportTestStart, reportTestResult,
      reportGlobalResults, defaultTestReporters
  
  ) where
  
  import Test.Framework.TestTypes
  import Test.Framework.Location
  import Test.Framework.Colors
  import Test.Framework.JsonOutput
  import Test.Framework.XmlOutput
  
  import System.IO
  import Control.Monad
  import Control.Monad.RWS
  import Text.PrettyPrint
  
  import qualified Data.Text.IO as T
  import qualified Data.ByteString.Lazy as BSL
  
  -- | Invokes 'tr_reportAllTests' on all test reporters registered.
  reportAllTests :: ReportAllTests
  reportAllTests tests =
      do reps <- asks tc_reporters
         mapM_ (\r -> tr_reportAllTests r tests) reps
  
  -- | Invokes 'tr_reportGlobalStart' on all test reporters registered.
  reportGlobalStart :: ReportGlobalStart
  reportGlobalStart tests =
      do reps <- asks tc_reporters
         mapM_ (\r -> tr_reportGlobalStart r tests) reps
  
  -- | Invokes 'tr_reportTestStart' on all test reporters registered.
  reportTestStart :: ReportTestStart
  reportTestStart t =
      do reps <- asks tc_reporters
         mapM_ (\r -> tr_reportTestStart r t) reps
  
  -- | Invokes 'tr_reportTestResult' on all test reporters registered.
  reportTestResult :: ReportTestResult
  reportTestResult t =
      do reps <- asks tc_reporters
         mapM_ (\r -> tr_reportTestResult r t) reps
  
  -- | Invokes 'tr_reportGlobalResults' on all test reporters registered.
  reportGlobalResults :: ReportGlobalResults
  reportGlobalResults arg =
      do reps <- asks tc_reporters
         mapM_ (\r -> tr_reportGlobalResults r arg) reps
  
  data IsParallel = Parallel | NonParallel
  
  isParallelFromBool :: Bool -> IsParallel
  isParallelFromBool True = Parallel
  isParallelFromBool False = NonParallel
  
  data IsJsonOutput = JsonOutput | NoJsonOutput
  data IsXmlOutput = XmlOutput | NoXmlOutput
  
  -- | The default test reporters for HTF.
  defaultTestReporters :: IsParallel
                       -> IsJsonOutput
                       -> IsXmlOutput
                       -> [TestReporter]
  defaultTestReporters inParallel forMachine doXml =
      case (inParallel, forMachine) of
        (NonParallel, NoJsonOutput) ->
            [TestReporter
             { tr_id = "rep_seq_human"
             , tr_reportAllTests = reportAllTestsH
             , tr_reportGlobalStart = reportGlobalStartHS
             , tr_reportTestStart = reportTestStartHS
             , tr_reportTestResult = reportTestResultHS
             , tr_reportGlobalResults = reportGlobalResultsH
             }] ++ xmlReporters
        (Parallel, NoJsonOutput) ->
            [TestReporter
             { tr_id = "rep_par_human"
             , tr_reportAllTests = reportAllTestsH
             , tr_reportGlobalStart = reportGlobalStartHP
             , tr_reportTestStart = reportTestStartHP
             , tr_reportTestResult = reportTestResultHP
             , tr_reportGlobalResults = reportGlobalResultsH
             }] ++ xmlReporters
        (NonParallel, JsonOutput) ->
            [TestReporter
             { tr_id = "rep_seq_machine"
             , tr_reportAllTests = reportAllTestsM
             , tr_reportGlobalStart = reportGlobalStartMS
             , tr_reportTestStart = reportTestStartMS
             , tr_reportTestResult = reportTestResultMS
             , tr_reportGlobalResults = reportGlobalResultsM
             }] ++ xmlReporters
        (Parallel, JsonOutput) ->
            [TestReporter
             { tr_id = "rep_par_machine"
             , tr_reportAllTests = reportAllTestsM
             , tr_reportGlobalStart = reportGlobalStartMP
             , tr_reportTestStart = reportTestStartMP
             , tr_reportTestResult = reportTestResultMP
             , tr_reportGlobalResults = reportGlobalResultsM
             }] ++ xmlReporters
      where
        xmlReporters =
            case doXml of
              NoXmlOutput -> []
              XmlOutput -> [(emptyTestReporter "rep_xml") {
                              tr_reportGlobalResults = reportGlobalResultsXml
                            }]
  
  --
  -- output for humans
  --
  
  humanTestName :: GenFlatTest a -> String
  humanTestName ft =
      flatName (ft_path ft) ++
      case ft_location ft of
        Nothing -> ""
        Just loc -> " (" ++ showLoc loc ++ ")"
  
  reportHumanTestStartMessage :: ReportLevel -> GenFlatTest a -> TR ()
  reportHumanTestStartMessage level ft =
      do let t = colorize testStartColor "[TEST] "
         reportTR level (t +++ noColor (humanTestName ft))
  
  -- sequential
  reportGlobalStartHS :: ReportGlobalStart
  reportGlobalStartHS _ = return ()
  
  reportTestStartHS :: ReportTestStart
  reportTestStartHS ft = reportHumanTestStartMessage Debug ft
  
  reportTestResultHS :: ReportTestResult
  reportTestResultHS ftr =
      let res = rr_result (ft_payload ftr)
          msg = attachCallStack (rr_message (ft_payload ftr)) (rr_stack (ft_payload ftr))
      in case res of
           Pass ->
               reportMessage Debug msg okSuffix
           Pending ->
               do reportHumanTestStartMessageIfNeeded
                  reportMessage Info msg pendingSuffix
           Fail ->
               do reportHumanTestStartMessageIfNeeded
                  reportMessage Info msg failureSuffix
           Error ->
               do reportHumanTestStartMessageIfNeeded
                  reportMessage Info msg errorSuffix
     where
       reportHumanTestStartMessageIfNeeded =
           do tc <- ask
              when (tc_quiet tc) (reportHumanTestStartMessage Info ftr)
       reportMessage level msg suffix =
           reportTR level (ensureNewlineColorString msg +++ suffix +++ noColor timeStr)
       timeStr = " (" ++ show (rr_wallTimeMs (ft_payload ftr)) ++ "ms)\n"
       failureSuffix = colorize warningColor "*** Failed!"
       errorSuffix = colorize warningColor "@@@ Error!"
       pendingSuffix = colorize pendingColor "^^^ Pending!"
       okSuffix = colorize testOkColor  "+++ OK"
  
  -- parallel
  reportGlobalStartHP :: ReportGlobalStart
  reportGlobalStartHP _ = return ()
  
  reportTestStartHP :: ReportTestStart
  reportTestStartHP ft =
       do reportStringTR Debug ("Starting " ++ (humanTestName ft))
  
  reportTestResultHP :: ReportTestResult
  reportTestResultHP ftr =
      do reportHumanTestStartMessage Debug ftr
         reportTestResultHS ftr
  
  -- results and all tests
  reportAllTestsH :: ReportAllTests
  reportAllTestsH l =
      reportStringTR Info (render (renderTestNames l))
  
  reportGlobalResultsH :: ReportGlobalResults
  reportGlobalResultsH arg =
      do let passed = length (rgra_passed arg)
             pending = length (rgra_pending arg)
             failed = length (rgra_failed arg)
             error = length (rgra_errors arg)
             timedOut = length (rgra_timedOut arg)
             filtered = length (rgra_filtered arg)
             total = passed + failed + error + pending
         let pendings = (if pending > 0 then colorize pendingColor else noColor) "* Pending:"
             failures = (if failed > 0 then colorize warningColor else noColor) "* Failures:"
             errors = (if error > 0 then colorize warningColor else noColor) "* Errors:"
         reportTR Info ("* Tests:     " +++ showC total +++ "\n" +++
                        "* Passed:    " +++ showC passed +++ "\n" +++
                        pendings +++ "   " +++ showC pending +++ "\n" +++
                        failures +++ "  " +++ showC failed +++ "\n" +++
                        errors +++ "    " +++ showC error +++ "\n" +++
                        "* Timed out: " +++ showC timedOut +++ "\n" +++
                        "* Filtered:  " +++ showC filtered)
         when (timedOut > 0) $
              if timedOut < 10
              then
                  reportTR Info
                      ("\n" +++ noColor "* Timed out:" +++ "\n" +++ renderTestNames' (reverse (rgra_timedOut arg)))
              else
                  reportTR Info
                    ("\n" +++ noColor "* Timed out: (" +++ showC timedOut +++ noColor ", too many to list)")
         when (filtered > 0) $
              if filtered < 10
              then
                  reportTR Info
                    ("\n" +++ noColor "* Filtered:" +++ "\n" +++ renderTestNames' (reverse (rgra_filtered arg)))
              else
                  reportTR Info
                    ("\n" +++ noColor "* Filtered: (" +++ showC filtered +++ noColor ", too many to list)")
         when (pending > 0) $
            reportTR Info
                ("\n" +++ pendings +++ "\n" +++ renderTestNames' (reverse (rgra_pending arg)))
         when (failed > 0) $
            reportTR Info
                ("\n" +++ failures +++ "\n" +++ renderTestNames' (reverse (rgra_failed arg)))
         when (error > 0) $
            reportTR Info
                ("\n" +++ errors +++ "\n" +++ renderTestNames' (reverse (rgra_errors arg)))
         reportStringTR Info ("\nTotal execution time: " ++ show (rgra_timeMs arg) ++ "ms")
      where
        showC x = noColor (show x)
        renderTestNames' rrs =
            noColor $ render $ nest 2 $ renderTestNames rrs
  
  renderTestNames :: [GenFlatTest a] -> Doc
  renderTestNames l =
      vcat (map (\ft -> text "*" <+>
                        text (humanTestName ft)) l)
  
  --
  -- output for machines
  --
  
  -- sequential
  reportGlobalStartMS :: ReportGlobalStart
  reportGlobalStartMS _ = return ()
  
  reportTestStartMS :: ReportTestStart
  reportTestStartMS ft =
      let json = mkTestStartEventObj ft (flatName (ft_path ft))
      in reportJsonTR json
  
  reportTestResultMS :: ReportTestResult
  reportTestResultMS ftr =
      let json = mkTestEndEventObj ftr (flatName (ft_path ftr))
      in reportJsonTR json
  
  -- parallel
  reportGlobalStartMP :: ReportGlobalStart
  reportGlobalStartMP _ = return ()
  
  reportTestStartMP :: ReportTestStart
  reportTestStartMP = reportTestStartMS
  
  reportTestResultMP :: ReportTestResult
  reportTestResultMP = reportTestResultMS
  
  -- results and all tests
  reportAllTestsM :: ReportAllTests
  reportAllTestsM l =
      let json = mkTestListObj (map (\ft -> (ft, flatName (ft_path ft))) l)
      in reportJsonTR json
  
  reportGlobalResultsM :: ReportGlobalResults
  reportGlobalResultsM arg =
      let json = mkTestResultsObj arg
      in reportJsonTR json
  
  reportGlobalResultsXml :: ReportGlobalResults
  reportGlobalResultsXml arg =
      do let xml = mkGlobalResultsXml arg
         tc <- ask
         case tc_outputXml tc of
           Just fname -> liftIO $ withFile fname WriteMode $ \h -> BSL.hPut h xml
           Nothing -> liftIO $ BSL.putStr xml
  
  --
  -- General reporting routines
  --
  
  reportTR :: ReportLevel -> ColorString -> TR ()
  reportTR level msg =
      do tc <- ask
         let s = renderColorString msg (tc_useColors tc)
         reportGen tc level (\h -> T.hPutStrLn h s)
  
  reportStringTR :: ReportLevel -> String -> TR ()
  reportStringTR level msg =
      do tc <- ask
         reportGen tc level (\h -> hPutStrLn h msg)
  
  reportLazyBytesTR :: ReportLevel -> BSL.ByteString -> TR ()
  reportLazyBytesTR level msg =
      do tc <- ask
         reportGen tc level (\h -> BSL.hPut h msg)
  
  reportJsonTR :: HTFJsonObj a => a -> TR ()
  reportJsonTR x = reportLazyBytesTR Info (decodeObj x)
  
  data ReportLevel = Debug | Info
                   deriving (Eq,Ord)
  
  reportGen :: TestConfig -> ReportLevel -> (Handle -> IO ()) -> TR ()
  reportGen tc level fun =
      unless (tc_quiet tc && level < Info) $
      case tc_output tc of
        TestOutputHandle h _ -> liftIO (fun h)
        TestOutputSplitted fp ->
            do -- split mode: one file for each result to avoid locking on windows
               ix <- gets ts_index
               let realFp = fp ++ (show ix) -- just append the index at the end of the file given as output parameter
               modify (\x -> x { ts_index = ts_index x + 1 })
               liftIO $ withFile realFp WriteMode fun
  