content: {-# LANGUAGE FlexibleInstances #-}
  --
  -- 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 types (and small auxiliary functions)
  for organizing tests, for configuring the execution of
  tests, and for representing and reporting their results.
  
  This functionality is mainly used internally in the code
  generated by the @hftpp@ pre-processor.
  -}
  module Test.Framework.TestTypes (
  
    -- * Organizing tests
    TestID, Test(..), TestOptions(..), AssertionWithTestOptions(..), WithTestOptions(..),
    TestSuite(..), TestSort(..),
    TestPath(..), GenFlatTest(..), FlatTest, TestFilter,
    testPathToList, flatName, finalName, prefixName, defaultTestOptions, withOptions, historyKey,
  
    -- * Executing tests
    TR, TestState(..), initTestState, TestConfig(..), TestOutput(..),
  
    -- * Reporting results
    ReportAllTests, ReportGlobalStart, ReportTestStart, ReportTestResult, ReportGlobalResults, ReportGlobalResultsArg(..),
    TestReporter(..), emptyTestReporter, attachCallStack, CallStack,
  
    -- * Specifying results.
    TestResult(..), FlatTestResult, Milliseconds, RunResult(..)
  
  ) where
  
  import Test.Framework.Location
  import Test.Framework.Colors
  import Test.Framework.History
  import Test.Framework.TestInterface
  
  import Control.Monad.RWS
  import System.IO
  import Data.Maybe
  import qualified Data.List as List
  import qualified Data.Text as T
  
  -- | Type for naming tests.
  type TestID = String
  
  -- | Type for distinguishing different sorts of tests.
  data TestSort = UnitTest | QuickCheckTest | BlackBoxTest
                deriving (Eq,Show,Read)
  
  -- | General options for tests
  data TestOptions = TestOptions {
        to_parallel :: Bool
      }
      deriving (Eq,Show,Read)
  
  -- | The default 'TestOptions'
  defaultTestOptions :: TestOptions
  defaultTestOptions = TestOptions {
                         to_parallel = True
                       }
  
  -- | Something with 'TestOptions'
  data WithTestOptions a = WithTestOptions {
        wto_options :: TestOptions
      , wto_payload :: a
      }
      deriving (Eq,Show,Read)
  
  -- | Shortcut for constructing a 'WithTestOptions' value.
  withOptions :: (TestOptions -> TestOptions) -> a -> WithTestOptions a
  withOptions f x = WithTestOptions (f defaultTestOptions) x
  
  -- | A type class for an assertion with 'TestOptions'.
  class AssertionWithTestOptions a where
      testOptions :: a -> TestOptions
      assertion :: a -> Assertion
  
  instance AssertionWithTestOptions (IO a) where
      testOptions _ = defaultTestOptions
      assertion io = io >> return ()
  
  instance AssertionWithTestOptions (WithTestOptions (IO a)) where
      testOptions (WithTestOptions opts _) = opts
      assertion (WithTestOptions _ io) = io >> return ()
  
  -- | Abstract type for tests and their results.
  data Test = BaseTest TestSort TestID (Maybe Location) TestOptions Assertion
            | CompoundTest TestSuite
  
  -- | Abstract type for test suites and their results.
  data TestSuite = TestSuite TestID [Test]
                 | AnonTestSuite [Test]
  
  -- | A type denoting the hierarchical name of a test.
  data TestPath = TestPathBase TestID
                | TestPathCompound (Maybe TestID) TestPath
                  deriving (Show)
  
  -- | Splits a 'TestPath' into a list of test identifiers.
  testPathToList :: TestPath -> [Maybe TestID]
  testPathToList (TestPathBase i) = [Just i]
  testPathToList (TestPathCompound mi p) =
      mi : testPathToList p
  
  -- | Creates a string representation from a 'TestPath'.
  flatName :: TestPath -> String
  flatName p =
      flatNameFromList (testPathToList p)
  
  flatNameFromList :: [Maybe TestID] -> String
  flatNameFromList l =
      List.intercalate ":" (map (fromMaybe "") l)
  
  -- | Returns the final name of a 'TestPath'
  finalName :: TestPath -> String
  finalName (TestPathBase i) = i
  finalName (TestPathCompound _ p) = finalName p
  
  -- | Returns the name of the prefix of a test path. The prefix is everything except the
  --   last element.
  prefixName :: TestPath -> String
  prefixName path =
      let l = case reverse (testPathToList path) of
                [] -> []
                (_:xs) -> reverse xs
      in flatNameFromList l
  
  -- | Generic type for flattened tests and their results.
  data GenFlatTest a
      = FlatTest
        { ft_sort :: TestSort           -- ^ The sort of the test.
        , ft_path :: TestPath           -- ^ Hierarchival path.
        , ft_location :: Maybe Location -- ^ Place of definition.
        , ft_payload :: a               -- ^ A generic payload.
        }
  
  -- | Key of a flat test for the history database.
  historyKey :: GenFlatTest a -> T.Text
  historyKey ft = T.pack (flatName (ft_path ft))
  
  -- | Flattened representation of tests.
  type FlatTest = GenFlatTest (WithTestOptions Assertion)
  
  -- | A filter is a predicate on 'FlatTest'. If the predicate is 'True', the flat test is run.
  type TestFilter = FlatTest -> Bool
  
  -- | A type for call-stacks
  type CallStack = [(Maybe String, Location)]
  
  -- | The result of a test run.
  data RunResult
      = RunResult
        { rr_result :: TestResult       -- ^ The summary result of the test.
        , rr_stack :: HtfStack          -- ^ The stack leading to the test failure
        , rr_message :: ColorString     -- ^ A message describing the result.
        , rr_wallTimeMs :: Milliseconds -- ^ Execution time in milliseconds.
        , rr_timeout :: Bool            -- ^ 'True' if the execution took too long
        }
  
  attachCallStack :: ColorString -> HtfStack -> ColorString
  attachCallStack msg stack =
      let fstack = formatHtfStack stack
      in if fstack == ""
         then msg
         else ensureNewlineColorString msg +++ noColor fstack
  
  -- | The result of running a 'FlatTest'
  type FlatTestResult = GenFlatTest RunResult
  
  -- | The state type for the 'TR' monad.
  data TestState = TestState { ts_results :: [FlatTestResult] -- ^ Results collected so far.
                             , ts_index :: Int                -- ^ Current index for splitted output.
                             }
  
  -- | The initial test state.
  initTestState :: TestState
  initTestState = TestState [] 0
  
  -- | The 'TR' (test runner) monad.
  type TR = RWST TestConfig () TestState IO
  
  -- | The destination of progress and result messages from HTF.
  data TestOutput = TestOutputHandle Handle Bool -- ^ Output goes to 'Handle', boolean flag indicates whether the handle should be closed at the end.
                  | TestOutputSplitted FilePath  -- ^ Output goes to files whose names are derived from 'FilePath' by appending a number to it. Numbering starts at zero.
                    deriving (Show, Eq)
  
  -- | Configuration of test execution.
  data TestConfig
      = TestConfig
        { tc_quiet :: Bool                -- ^ If set, displays messages only for failed tests.
        , tc_threads :: Maybe Int         -- ^ Use @Just i@ for parallel execution with @i@ threads, @Nothing@ for sequential execution.
        , tc_shuffle :: Bool              -- ^ Shuffle tests before parallel execution
        , tc_output :: TestOutput         -- ^ Output destination of progress and result messages.
        , tc_outputXml :: Maybe FilePath  -- ^ Output destination of XML result summary
        , tc_filter :: TestFilter         -- ^ Filter for the tests to run.
        , tc_reporters :: [TestReporter]  -- ^ Test reporters to use.
        , tc_useColors :: Bool            -- ^ Whether to use colored output
        , tc_historyFile :: FilePath      -- ^ Path to history file
        , tc_history :: TestHistory       -- ^ History of previous test runs
        , tc_sortByPrevTime :: Bool       -- ^ Sort ascending by previous execution times
        , tc_failFast :: Bool             -- ^ Stop test run as soon as one test fails
        , tc_timeoutIsSuccess :: Bool     -- ^ Do not regard timeout as an error
        , tc_maxSingleTestTime :: Maybe Milliseconds -- ^ Maximum time in milliseconds a single test is allowed to run
        , tc_prevFactor :: Maybe Double   -- ^ Maximum factor a single test is allowed to run slower than its previous execution
        , tc_repeat :: Int                -- ^ Number of times to repeat tests selected on the command line before reporting them as a success.
        }
  
  instance Show TestConfig where
      showsPrec prec tc =
          showParen (prec > 0) $
          showString "TestConfig { " .
          showString "tc_quiet=" . showsPrec 1 (tc_quiet tc) .
          showString ", tc_threads=" . showsPrec 1 (tc_threads tc) .
          showString ", tc_shuffle=" . showsPrec 1 (tc_shuffle tc) .
          showString ", tc_output=" . showsPrec 1 (tc_output tc) .
          showString ", tc_outputXml=" . showsPrec 1 (tc_outputXml tc) .
          showString ", tc_filter=<filter>" .
          showString ", tc_reporters=" . showsPrec 1 (tc_reporters tc) .
          showString ", tc_useColors=" . showsPrec 1 (tc_useColors tc) .
          showString ", tc_historyFile=" . showsPrec 1 (tc_historyFile tc) .
          showString ", tc_history=" . showsPrec 1 (tc_history tc) .
          showString ", tc_sortByPrevTime=" . showsPrec 1 (tc_sortByPrevTime tc) .
          showString ", tc_failFast=" . showsPrec 1 (tc_failFast tc) .
          showString ", tc_timeoutIsSuccess=" . showsPrec 1 (tc_timeoutIsSuccess tc) .
          showString ", tc_maxSingleTestTime=" . showsPrec 1 (tc_maxSingleTestTime tc) .
          showString ", tc_prevFactor=" . showsPrec 1 (tc_prevFactor tc) .
          showString ", tc_repeat=" . showsPrec 1 (tc_repeat tc) .
          showString " }"
  
  -- | A 'TestReporter' provides hooks to customize the output of HTF.
  data TestReporter
      = TestReporter
        { tr_id :: String
        , tr_reportAllTests :: ReportAllTests        -- ^ Called to report the IDs of all tests available.
        , tr_reportGlobalStart :: ReportGlobalStart  -- ^ Called to report the start of test execution.
        , tr_reportTestStart :: ReportTestStart      -- ^ Called to report the start of a single test.
        , tr_reportTestResult :: ReportTestResult    -- ^ Called to report the result of a single test.
        , tr_reportGlobalResults :: ReportGlobalResults  -- ^ Called to report the overall results of all tests.
        }
  
  emptyTestReporter :: String -> TestReporter
  emptyTestReporter id =
      TestReporter
        { tr_id = id
        , tr_reportAllTests = \_ -> return ()
        , tr_reportGlobalStart = \_ -> return ()
        , tr_reportTestStart = \_ -> return ()
        , tr_reportTestResult = \_ -> return ()
        , tr_reportGlobalResults = \_ -> return ()
        }
  
  instance Show TestReporter where
      showsPrec _ x = showString (tr_id x)
  
  instance Eq TestReporter where
      x == y = (tr_id x) == (tr_id y)
  
  -- | Reports the IDs of all tests available.
  type ReportAllTests = [FlatTest] -> TR ()
  
  -- | Signals that test execution is about to start.
  type ReportGlobalStart = [FlatTest] -> TR ()
  
  -- | Reports the start of a single test.
  type ReportTestStart = FlatTest -> TR ()
  
  -- | Reports the result of a single test.
  type ReportTestResult = FlatTestResult -> TR ()
  
  data ReportGlobalResultsArg
      = ReportGlobalResultsArg
      { rgra_timeMs :: Milliseconds
      , rgra_passed :: [FlatTestResult]
      , rgra_pending :: [FlatTestResult]
      , rgra_failed :: [FlatTestResult]
      , rgra_errors :: [FlatTestResult]
      , rgra_timedOut :: [FlatTestResult]
      , rgra_filtered :: [FlatTest]
      }
  
  -- | Reports the overall results of all tests.
  type ReportGlobalResults = ReportGlobalResultsArg -> TR ()
  