content: {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  --
  -- Copyright (c) 2009-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 function for running a set of tests. Furthermore,
  it provides functionality for organzing tests into a hierarchical
  structure.
  
  This functionality is mainly used internally in the code
  generated by the @hftpp@ pre-processor.
  -}
  
  module Test.Framework.TestManager (
  
    -- * Re-exports
    module Test.Framework.TestTypes,
  
    -- * Running tests
    htfMain, htfMainWithArgs, runTest, runTest', runTestWithArgs, runTestWithArgs',
    runTestWithOptions, runTestWithOptions', runTestWithConfig, runTestWithConfig',
  
    -- * Organzing tests
    TestableHTF,
    WrappableHTF(..),
  
    makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite,
    makeAnonTestSuite,
    addToTestSuite, testSuiteAsTest,
  
    flattenTest,
  
    -- * Tests (for internal use)
    wrappableTests
  ) where
  
  import Control.Monad.RWS
  import System.Exit (ExitCode(..), exitWith)
  import System.Environment (getArgs)
  import qualified Control.Exception as Exc
  import Data.Maybe
  import Data.Time
  import qualified Data.List as List
  import qualified Data.ByteString as BS
  import Data.IORef
  import Control.Concurrent
  
  import System.IO
  
  import Test.Framework.Utils
  import Test.Framework.TestInterface
  import Test.Framework.TestTypes
  import Test.Framework.CmdlineOptions
  import Test.Framework.TestReporter
  import Test.Framework.Location
  import Test.Framework.Colors
  import Test.Framework.ThreadPool
  import Test.Framework.History
  
  import qualified Test.HUnit as HU
  -- | Construct a test where the given 'Assertion' checks a quick check property.
  -- Mainly used internally by the htfpp preprocessor.
  makeQuickCheckTest :: TestID -> Location -> Assertion -> Test
  makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) defaultTestOptions ass
  
  -- | Construct a unit test from the given 'IO' action.
  -- Mainly used internally by the htfpp preprocessor.
  makeUnitTest :: AssertionWithTestOptions a => TestID -> Location -> a -> Test
  makeUnitTest id loc ass =
      BaseTest UnitTest id (Just loc) (testOptions ass) (assertion ass)
  
  -- | Construct a black box test from the given 'Assertion'.
  -- Mainly used internally.
  makeBlackBoxTest :: TestID -> Assertion -> Test
  makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing defaultTestOptions ass
  
  -- | Create a named 'TestSuite' from a list of 'Test' values.
  makeTestSuite :: TestID -> [Test] -> TestSuite
  makeTestSuite = TestSuite
  
  -- | Create an unnamed 'TestSuite' from a list of 'Test' values.
  makeAnonTestSuite :: [Test] -> TestSuite
  makeAnonTestSuite = AnonTestSuite
  
  -- | Turn a 'TestSuite' into a proper 'Test'.
  testSuiteAsTest :: TestSuite -> Test
  testSuiteAsTest = CompoundTest
  
  -- | Extend a 'TestSuite' with a list of 'Test' values
  addToTestSuite :: TestSuite -> [Test] -> TestSuite
  addToTestSuite (TestSuite id ts) ts' = TestSuite id (ts ++ ts')
  addToTestSuite (AnonTestSuite ts) ts' = AnonTestSuite (ts ++ ts')
  
  -- | Kind of specialised 'Functor' type class for tests, which allows you to
  -- modify the 'Assertion's of the 'WrappableHTF'-thing without changing any
  -- test code.
  --
  -- E.g. if you want to add timeouts to all tests of a module, you could write:
  --
  -- > addTimeout test = timeout 100 test >>= assertJustVerbose "Timeout exceeded"
  -- > testsWithTimeouts = wrap addTimeout htf_thisModulesTests
  class WrappableHTF t where
      wrap :: (Assertion -> Assertion) -> t -> t
  
  instance WrappableHTF TestSuite where
      wrap wrapper (TestSuite tid tests) = TestSuite tid $ map (wrap wrapper) tests
      wrap wrapper (AnonTestSuite tests) = AnonTestSuite $ map (wrap wrapper) tests
  
  instance WrappableHTF Test where
      wrap wrapper (BaseTest ts tid loc topt assertion) =
          BaseTest ts tid loc topt (wrapper assertion)
      wrap wrapper (CompoundTest suite) = CompoundTest $ wrap wrapper suite
  
  -- | A type class for things that can be run as tests.
  -- Mainly used internally.
  class TestableHTF t where
      flatten :: t -> [FlatTest]
  
  instance TestableHTF Test where
      flatten = flattenTest
  
  instance TestableHTF TestSuite where
      flatten = flattenTestSuite
  
  instance TestableHTF t => TestableHTF [t] where
      flatten = concatMap flatten
  
  instance TestableHTF (IO a) where
      flatten action = flatten (makeUnitTest "unnamed test" unknownLocation action)
  
  flattenTest :: Test -> [FlatTest]
  flattenTest (BaseTest sort id mloc opts x) =
      [FlatTest sort (TestPathBase id) mloc (WithTestOptions opts x)]
  flattenTest (CompoundTest ts) =
      flattenTestSuite ts
  
  flattenTestSuite :: TestSuite -> [FlatTest]
  flattenTestSuite (TestSuite id ts) =
      let fts = concatMap flattenTest ts
      in map (\ft -> ft { ft_path = TestPathCompound (Just id) (ft_path ft) }) fts
  flattenTestSuite (AnonTestSuite ts) =
      let fts = concatMap flattenTest ts
      in map (\ft -> ft { ft_path = TestPathCompound Nothing (ft_path ft) }) fts
  
  maxRunTime :: TestConfig -> FlatTest -> Maybe Milliseconds
  maxRunTime tc ft =
      let mt1 = tc_maxSingleTestTime tc
          mt2 =
              case tc_prevFactor tc of
                Nothing -> Nothing
                Just d ->
                    case max (fmap htr_timeMs (findHistoricSuccessfulTestResult (historyKey ft) (tc_history tc)))
                             (fmap htr_timeMs (findHistoricTestResult (historyKey ft) (tc_history tc)))
                    of
                      Nothing -> Nothing
                      Just t -> Just $ ceiling (fromInteger (toInteger t) * d)
      in case (mt1, mt2) of
           (Just t1, Just t2) -> Just (min t1 t2)
           (_, Nothing) -> mt1
           (Nothing, _) -> mt2
  
  -- | HTF uses this function to execute the given assertion as a HTF test.
  performTestHTF :: Assertion -> IO FullTestResult
  performTestHTF action =
      do action
         return (mkFullTestResult Pass Nothing)
       `Exc.catches`
        [Exc.Handler (\(HTFFailure res) -> return res)
        ,Exc.Handler handleUnexpectedException]
      where
        handleUnexpectedException exc =
            case Exc.fromException exc of
              Just (async :: Exc.AsyncException) ->
                  case async of
                    Exc.StackOverflow -> exceptionAsError exc
                    _ -> Exc.throwIO exc
              _ -> exceptionAsError exc
        exceptionAsError exc =
            return (mkFullTestResult Error (Just $ show (exc :: Exc.SomeException)))
  
  data TimeoutResult a
      = TimeoutResultOk a
      | TimeoutResultException Exc.SomeException
      | TimeoutResultTimeout
  
  timeout :: Int -> IO a -> IO (Maybe a)
  timeout microSecs action
      | microSecs < 0 = fmap Just action
      | microSecs == 0 = return Nothing
      | otherwise =
          do resultChan <- newChan
             finishedVar <- newIORef False
             workerTid <- forkIO (wrappedAction resultChan finishedVar)
             _ <- forkIO (threadDelay microSecs >> writeChan resultChan TimeoutResultTimeout)
             res <- readChan resultChan
             case res of
               TimeoutResultTimeout ->
                   do atomicModifyIORef finishedVar (\_ -> (True, ()))
                      killThread workerTid
                      return Nothing
               TimeoutResultOk x ->
                   return (Just x)
               TimeoutResultException exc ->
                   Exc.throwIO exc
      where
        wrappedAction resultChan finishedVar =
            Exc.mask $ \restore ->
                     (do x <- restore action
                         writeChan resultChan (TimeoutResultOk x))
                     `Exc.catch`
                     (\(exc::Exc.SomeException) ->
                          do b <- shouldReraiseException exc finishedVar
                             if b then Exc.throwIO exc else writeChan resultChan (TimeoutResultException exc))
        shouldReraiseException exc finishedVar =
            case Exc.fromException exc of
              Just (async :: Exc.AsyncException) ->
                  case async of
                    Exc.ThreadKilled -> atomicModifyIORef finishedVar (\old -> (old, old))
                    _ -> return False
              _ -> return False
  
  data PrimTestResult
      = PrimTestResultNoTimeout FullTestResult
      | PrimTestResultTimeout
  
  mkFlatTestRunner :: TestConfig -> FlatTest -> ThreadPoolEntry TR () (PrimTestResult, Milliseconds)
  mkFlatTestRunner tc ft = (pre, action, post)
      where
        pre = reportTestStart ft
        action _ =
            let run = performTestHTF (wto_payload (ft_payload ft))
                runWithTimeout =
                    case maxRunTime tc ft of
                      Nothing ->
                          do (res, time) <- measure run
                             return (PrimTestResultNoTimeout res, time)
                      Just maxMs ->
                           do mx <- timeout (1000 * maxMs) $ measure run
                              case mx of
                                Nothing -> return (PrimTestResultTimeout, maxMs)
                                Just (res, time) ->
                                    return (PrimTestResultNoTimeout res, time)
                isPass primTestRes =
                    case primTestRes of
                      PrimTestResultNoTimeout fullTestRes ->
                          ftr_result fullTestRes == Just Pass
                      PrimTestResultTimeout -> False
                iterRunWithTimeout i =
                    do (primTestRes, time) <- runWithTimeout
                       if isPass primTestRes && i >= 2
                         then iterRunWithTimeout (i-1)
                         else return (primTestRes, time)
            in iterRunWithTimeout (tc_repeat tc)
        post excOrResult =
            let (testResult, time) =
                   case excOrResult of
                     Left exc ->
                         (FullTestResult
                          { ftr_stack = emptyHtfStack
                          , ftr_message = Just $ noColor ("Running test unexpectedly failed: " ++ show exc)
                          , ftr_result = Just Error
                          }
                         ,(-1))
                     Right (res, time) ->
                         case res of
                           PrimTestResultTimeout ->
                               (FullTestResult
                                { ftr_stack = emptyHtfStack
                                , ftr_message = Just $ colorize warningColor "timeout"
                                , ftr_result = Nothing
                                }
                               ,time)
                           PrimTestResultNoTimeout res ->
                               let res' =
                                       if isNothing (ftr_message res) && isNothing (ftr_result res)
                                       then res { ftr_message = Just (colorize warningColor "timeout") }
                                       else res
                               in (res', time)
                (sumRes, isTimeout) =
                    case ftr_result testResult of
                      Just x -> (x, False)
                      Nothing -> (if tc_timeoutIsSuccess tc then Pass else Error, True)
                rr = FlatTest
                       { ft_sort = ft_sort ft
                       , ft_path = ft_path ft
                       , ft_location = ft_location ft
                       , ft_payload = RunResult sumRes (ftr_stack testResult)
                                                (fromMaybe emptyColorString (ftr_message testResult))
                                                time isTimeout
                       }
            in do modify (\s -> s { ts_results = rr : ts_results s })
                  reportTestResult rr
                  return (stopFlag sumRes)
        stopFlag result =
            if not (tc_failFast tc)
            then DoNotStop
            else case result of
                   Pass -> DoNotStop
                   Pending -> DoNotStop
                   Fail -> DoStop
                   Error -> DoStop
  
  runAllFlatTests :: [FlatTest] -> TR ()
  runAllFlatTests tests' =
      do tc <- ask
         tests <- orderTests tc tests'
         reportGlobalStart tests
         case tc_threads tc of
           Nothing ->
               let entries = map (mkFlatTestRunner tc) tests
               in tp_run sequentialThreadPool entries
           Just i ->
               let (ptests, stests) = List.partition (\t -> to_parallel (wto_options (ft_payload t))) tests
                   pentries = map (mkFlatTestRunner tc) ptests
                   sentries = map (mkFlatTestRunner tc) stests
               in do tp <- parallelThreadPool i
                     tp_run tp pentries
                     tp_run sequentialThreadPool sentries
      where
        orderTests tc ts
            | tc_sortByPrevTime tc = return $ sortByPrevTime tc ts
            | tc_shuffle tc = shuffleTests ts
            | otherwise = return ts
        shuffleTests = liftIO . shuffleIO
        sortByPrevTime tc ts =
                map snd $ List.sortBy (compareTests tc) (map (\t -> (historyKey t, t)) ts)
        compareTests tc (t1, _) (t2, _) =
            case (max (fmap htr_timeMs (findHistoricSuccessfulTestResult t1 (tc_history tc)))
                      (fmap htr_timeMs (findHistoricTestResult t1 (tc_history tc)))
                 ,max (fmap htr_timeMs (findHistoricSuccessfulTestResult t2 (tc_history tc)))
                      (fmap htr_timeMs (findHistoricTestResult t2 (tc_history tc))))
            of
              (Just t1, Just t2) -> compare t1 t2
              (Just _, Nothing) -> GT
              (Nothing, Just _) -> LT
              (Nothing, Nothing) -> EQ
  
  -- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'.
  runTest :: TestableHTF t => t              -- ^ Testable thing
                           -> IO ExitCode    -- ^ See 'runTestWithOptions' for a specification of the 'ExitCode' result
  runTest = runTestWithOptions defaultCmdlineOptions
  
  -- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'.
  runTest' :: TestableHTF t => t              -- ^ Testable thing
                           -> IO (IO (), ExitCode)    -- ^ 'IO' action for printing the overall test results, and exit code for the test run. See 'runTestWithOptions' for a specification of the 'ExitCode' result
  runTest' = runTestWithOptions' defaultCmdlineOptions
  
  -- | Run something testable, parse the 'CmdlineOptions' from the given commandline arguments.
  -- Does not print the overall test results but returns an 'IO' action for doing so.
  runTestWithArgs :: TestableHTF t => [String]        -- ^ Commandline arguments
                                   -> t               -- ^ Testable thing
                                   -> IO ExitCode     -- ^ See 'runTestWithConfig' for a specification of the 'ExitCode' result.
  runTestWithArgs args t =
      do (printSummary, ecode) <- runTestWithArgs' args t
         printSummary
         return ecode
  
  
  -- | Run something testable, parse the 'CmdlineOptions' from the given commandline arguments.
  runTestWithArgs' :: TestableHTF t => [String]        -- ^ Commandline arguments
                                   -> t               -- ^ Testable thing
                                   -> IO (IO (), ExitCode)  -- ^ 'IO' action for printing the overall test results, and exit code for the test run. See 'runTestWithConfig' for a specification of the 'ExitCode' result.
  runTestWithArgs' args t =
      case parseTestArgs args of
        Left err ->
            do hPutStrLn stderr err
               return $ (return (), ExitFailure 1)
        Right opts ->
            runTestWithOptions' opts t
  
  -- | Runs something testable with the given 'CmdlineOptions'.
  -- See 'runTestWithConfig' for a specification of the 'ExitCode' result.
  runTestWithOptions :: TestableHTF t => CmdlineOptions -> t -> IO ExitCode
  runTestWithOptions opts t =
      do (printSummary, ecode) <- runTestWithOptions' opts t
         printSummary
         return ecode
  
  -- | Runs something testable with the given 'CmdlineOptions'. Does not
  -- print the overall test results but returns an 'IO' action for doing so.
  -- See 'runTestWithConfig' for a specification of the 'ExitCode' result.
  runTestWithOptions' :: TestableHTF t => CmdlineOptions -> t -> IO (IO (), ExitCode)
  runTestWithOptions' opts t =
      if opts_help opts
         then do hPutStrLn stderr helpString
                 return $ (return (), ExitFailure 1)
         else do tc <- testConfigFromCmdlineOptions opts
                 (printSummary, ecode) <-
                     (if opts_listTests opts
                        then let fts = filter (opts_filter opts) (flatten t)
                             in return (runRWST (reportAllTests fts) tc initTestState >> return (), ExitSuccess)
                        else do (printSummary, ecode, history) <- runTestWithConfig' tc t
                                storeHistory (tc_historyFile tc) history
                                return (printSummary, ecode))
                 return (printSummary `Exc.finally` cleanup tc, ecode)
      where
        cleanup tc =
            case tc_output tc of
              TestOutputHandle h True -> hClose h
              _ -> return ()
        storeHistory file history =
            BS.writeFile file (serializeTestHistory history)
            `Exc.catch` (\(e::Exc.IOException) ->
                            hPutStrLn stderr ("Error storing HTF history into file " ++ file ++ ": " ++ show e))
  
  -- | Runs something testable with the given 'TestConfig'.
  -- The result is 'ExitSuccess' if all tests were executed successfully,
  -- 'ExitFailure' otherwise. In the latter case, an error code of @1@ indicates
  -- that failures but no errors occurred, otherwise the error code @2@ is used.
  --
  -- A test is /successful/ if the test terminates and no assertion fails.
  -- A test is said to /fail/ if an assertion fails but no other error occur.
  runTestWithConfig :: TestableHTF t => TestConfig -> t -> IO (ExitCode, TestHistory)
  runTestWithConfig tc t =
      do (printSummary, ecode, history) <- runTestWithConfig' tc t
         printSummary
         return (ecode, history)
  
  -- | Runs something testable with the given 'TestConfig'. Does not
  -- print the overall test results but returns an 'IO' action for doing so.
  -- See 'runTestWithConfig' for a specification of the 'ExitCode' result.
  runTestWithConfig' :: TestableHTF t => TestConfig -> t -> IO (IO (), ExitCode, TestHistory)
  runTestWithConfig' tc t =
       do let allTests = flatten t
              activeTests = filter (tc_filter tc) allTests
              filteredTests = filter (not . tc_filter tc) allTests
          startTime <- getCurrentTime
          ((_, s, _), time) <-
              measure $
              runRWST (runAllFlatTests activeTests) tc initTestState
          let results = reverse (ts_results s)
              passed = filter (\ft -> (rr_result . ft_payload) ft == Pass) results
              pending = filter (\ft -> (rr_result . ft_payload) ft == Pending) results
              failed = filter (\ft -> (rr_result . ft_payload) ft == Fail) results
              error = filter (\ft -> (rr_result . ft_payload) ft == Error) results
              timedOut = filter (\ft -> (rr_timeout . ft_payload) ft) results
              arg = ReportGlobalResultsArg
                    { rgra_timeMs = time
                    , rgra_passed = passed
                    , rgra_pending = pending
                    , rgra_failed = failed
                    , rgra_errors = error
                    , rgra_timedOut = timedOut
                    , rgra_filtered = filteredTests
      }
          let printSummary =
                  runRWST (reportGlobalResults arg) tc (TestState [] (ts_index s)) -- keep index from run
              !newHistory = updateHistory startTime results (tc_history tc)
          return (printSummary >> return (),
                  case () of
                     _| length failed == 0 && length error == 0 -> ExitSuccess
                      | length error == 0 -> ExitFailure 1
                      | otherwise -> ExitFailure 2
                 ,newHistory)
      where
        updateHistory :: UTCTime -> [FlatTestResult] -> TestHistory -> TestHistory
        updateHistory time results history =
            let runHistory = mkTestRunHistory time (map (\res -> HistoricTestResult {
                                                                   htr_testId = historyKey res
                                                                 , htr_result = rr_result (ft_payload res)
                                                                 , htr_timedOut = rr_timeout (ft_payload res)
                                                                 , htr_timeMs = rr_wallTimeMs (ft_payload res)
                                                                 })
                                                        results)
            in updateTestHistory runHistory history
  
  -- | Runs something testable by parsing the commandline arguments as test options
  -- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'.
  -- This function is the main entry point for running tests.
  htfMain :: TestableHTF t => t -> IO ()
  htfMain tests =
      do args <- getArgs
         htfMainWithArgs args tests
  
  -- | Runs something testable by parsing the commandline arguments as test options
  -- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'.
  htfMainWithArgs :: TestableHTF t => [String] -> t -> IO ()
  htfMainWithArgs args tests =
      do ecode <- runTestWithArgs args tests
         exitWith ecode
  
  testWrapCanCauseFailure :: IO ()
  testWrapCanCauseFailure =
      do HU.assertEqual "plain unit test passes" ExitSuccess =<< runTest unitTest
         HU.assertEqual "wrapped unit test fails" (ExitFailure 2) =<< runTest wrappedUnitTest
      where
        unitTest = BaseTest UnitTest "unitTest" Nothing defaultTestOptions (return ())
        wrappedUnitTest = wrap wrapper unitTest
        wrapper test = HU.assertFailure "Fail" >> test
  
  wrappableTests = [("testWrapCanCauseFailure", testWrapCanCauseFailure)]
  