content: -- | Core types and definitions
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE ExistentialQuantification #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE RankNTypes #-}
  module Test.Tasty.Core
    ( FailureReason(..)
    , Outcome(..)
    , Time
    , Result(..)
    , resultSuccessful
    , exceptionResult
    , Progress(..)
    , emptyProgress
    , IsTest(..)
    , TestName
    , ResourceSpec(..)
    , ResourceError(..)
    , DependencyType(..)
    , ExecutionMode(..)
    , Parallel(..)
    , TestTree(..)
    , testGroup
    , sequentialTestGroup
    , dependentTestGroup
    , inOrderTestGroup
    , after
    , after_
    , TreeFold(..)
    , trivialFold
    , foldTestTree
    , foldTestTree0
    , treeOptions
    ) where
  
  import Control.Exception
  import qualified Data.Map as Map
  import Data.Bifunctor (Bifunctor(second, bimap))
  import Data.List (mapAccumR)
  import Data.Monoid (Any (getAny, Any))
  import Data.Sequence ((|>))
  import qualified Data.Sequence as Seq
  import Data.Tagged
  import Data.Typeable
  import GHC.Generics
  import Options.Applicative (internal)
  import Test.Tasty.Options
  import Test.Tasty.Patterns
  import Test.Tasty.Patterns.Types
  import Test.Tasty.Providers.ConsoleFormat
  import Text.Printf
  import Text.Read (readMaybe)
  
  -- | If a test failed, 'FailureReason' describes why.
  --
  -- @since 0.8
  data FailureReason
    = TestFailed
      -- ^ test provider indicated failure of the code to test, either because
      -- the tested code returned wrong results, or raised an exception
    | TestThrewException SomeException
      -- ^ the test code itself raised an exception. Typical cases include missing
      -- example input or output files.
      --
      -- Usually, providers do not have to implement this, as their 'run' method
      -- may simply raise an exception.
    | TestTimedOut Integer
      -- ^ test didn't complete in allotted time
    | TestDepFailed -- See Note [Skipped tests]
      -- ^ a dependency of this test failed, so this test was skipped.
      --
      -- @since 1.2
    deriving Show
  
  -- | Outcome of a test run
  --
  -- Note: this is isomorphic to @'Maybe' 'FailureReason'@. You can use the
  -- @generic-maybe@ package to exploit that.
  --
  -- @since 0.8
  data Outcome
    = Success -- ^ test succeeded
    | Failure FailureReason -- ^ test failed because of the 'FailureReason'
    deriving (Show, Generic)
  
  -- | Time in seconds. Used to measure how long the tests took to run.
  --
  -- @since 0.10
  type Time = Double
  
  -- | A test result.
  --
  -- @since 0.1
  data Result = Result
    { resultOutcome :: Outcome
      -- ^ Did the test fail? If so, why?
    , resultDescription :: String
      -- ^
      -- 'resultDescription' may contain some details about the test. For
      -- a passed test it's ok to leave it empty. Providers like SmallCheck and
      -- QuickCheck use it to provide information about how many tests were
      -- generated.
      --
      -- For a failed test, 'resultDescription' should typically provide more
      -- information about the failure.
      --
      -- @since 0.11
    , resultShortDescription :: String
      -- ^ The short description printed in the test run summary, usually @OK@ or
      -- @FAIL@.
      --
      -- @since 0.10
    , resultTime :: Time
      -- ^ How long it took to run the test, in seconds.
    , resultDetailsPrinter :: ResultDetailsPrinter
      -- ^ An action that prints additional information about a test.
      --
      -- This is similar to 'resultDescription' except it can produce
      -- colorful/formatted output; see "Test.Tasty.Providers.ConsoleFormat".
      --
      -- This can be used instead of or in addition to 'resultDescription'.
      --
      -- Usually this is set to 'noResultDetails', which does nothing.
      --
      -- @since 1.3.1
    }
    deriving
    ( Show -- ^ @since 1.2
    )
  
  {- Note [Skipped tests]
     ~~~~~~~~~~~~~~~~~~~~
     There are two potential ways to represent the tests that are skipped
     because of their failed dependencies:
     1. With Outcome = Failure, and FailureReason giving the specifics (TestDepFailed)
     2. With a dedicated Outcome = Skipped
  
     It seems to me that (1) will lead to fewer bugs (esp. in the extension packages),
     because most of the time skipped tests should be handled in the same way
     as failed tests.
     But sometimes it is not obvious what the right behavior should be. E.g.
     should --hide-successes show or hide the skipped tests?
  
     Perhaps we should hide them, because they aren't really informative.
     Or perhaps we shouldn't hide them, because we are not sure that they
     will pass, and hiding them will imply a false sense of security
     ("there's at most 2 tests failing", whereas in fact there could be much more).
  
     So I might change this in the future, but for now treating them as
     failures seems the easiest yet reasonable approach.
  -}
  
  -- | 'True' for a passed test, 'False' for a failed one.
  --
  -- @since 0.8
  resultSuccessful :: Result -> Bool
  resultSuccessful r =
    case resultOutcome r of
      Success -> True
      Failure {} -> False
  
  -- | Shortcut for creating a 'Result' that indicates exception
  exceptionResult :: SomeException -> Result
  exceptionResult e = Result
    { resultOutcome = Failure $ TestThrewException e
    , resultDescription = "Exception: " ++ displayException e
    , resultShortDescription = "FAIL"
    , resultTime = 0
    , resultDetailsPrinter = noResultDetails
    }
  
  -- | Test progress information.
  --
  -- This may be used by a runner to provide some feedback to the user while
  -- a long-running test is executing.
  --
  -- @since 0.1
  data Progress = Progress
    { progressText :: String
      -- ^ textual information about the test's progress
    , progressPercent :: Float
      -- ^
      -- 'progressPercent' should be a value between 0 and 1. If it's impossible
      -- to compute the estimate, use 0.
    }
    deriving
    ( Show -- ^ @since 1.2
    , Eq   -- ^ @since 1.5
    )
  
  -- | Empty progress
  --
  -- @since 1.5
  emptyProgress :: Progress
  emptyProgress = Progress mempty 0.0
  
  -- | The interface to be implemented by a test provider.
  --
  -- The type @t@ is the concrete representation of the test which is used by
  -- the provider.
  --
  -- @since 0.1
  class Typeable t => IsTest t where
    -- | Run the test
    --
    -- This method should cleanly catch any exceptions in the code to test, and
    -- return them as part of the 'Result', see 'FailureReason' for an
    -- explanation. It is ok for 'run' to raise an exception if there is a
    -- problem with the test suite code itself (for example, if a file that
    -- should contain example data or expected output is not found).
    run
      :: OptionSet -- ^ options
      -> t -- ^ the test to run
      -> (Progress -> IO ()) -- ^ a callback to report progress.
      -> IO Result
  
    -- | The list of options that affect execution of tests of this type
    testOptions :: Tagged t [OptionDescription]
  
  -- | The name of a test or a group of tests.
  --
  -- @since 0.1
  type TestName = String
  
  -- | 'ResourceSpec' describes how to acquire a resource (the first field)
  -- and how to release it (the second field).
  --
  -- @since 0.6
  data ResourceSpec a = ResourceSpec (IO a) (a -> IO ())
  
  -- | A resources-related exception
  data ResourceError
    = NotRunningTests
    | UnexpectedState String String
    | UseOutsideOfTest
  
  instance Show ResourceError where
    show NotRunningTests =
      "Unhandled resource. Probably a bug in the runner you're using."
    show (UnexpectedState where_ what) =
      printf "Unexpected state of the resource (%s) in %s. Report as a tasty bug."
        what where_
    show UseOutsideOfTest =
      "It looks like you're attempting to use a resource outside of its test. Don't do that!"
  
  instance Exception ResourceError
  
  -- | These are the two ways in which one test may depend on the others.
  --
  -- This is the same distinction as the
  -- <http://testng.org/doc/documentation-main.html#dependent-methods hard vs soft dependencies in TestNG>.
  --
  -- @since 1.2
  data DependencyType
    = AllSucceed
      -- ^ The current test tree will be executed after its dependencies finish, and only
      -- if all of the dependencies succeed.
    | AllFinish
      -- ^ The current test tree will be executed after its dependencies finish,
      -- regardless of whether they succeed or not.
    deriving
      ( Eq
      , Show
      , Read -- ^ @since 1.5
      )
  
  -- | Determines mode of execution of a 'TestGroup'
  data ExecutionMode
    = Dependent DependencyType
    -- ^ Test have dependencies
    | Independent Parallel
    -- ^ Test have no dependencies
    deriving (Show, Read)
  
  data Parallel
    = Parallel
    -- ^ Tests can be run in parallel
    | NonParallel
    -- ^ Tests should not be parallelized
    deriving (Show, Read)
  
  -- | Determines mode of execution of a 'TestGroup'. Note that this option is
  -- not exposed as a command line argument.
  instance IsOption ExecutionMode where
    defaultValue = Independent Parallel
    parseValue = readMaybe
    optionName = Tagged "execution-mode"
    optionHelp = Tagged "Whether tests have dependencies or not"
    optionCLParser = mkOptionCLParser internal
  
  -- | The main data structure defining a test suite.
  --
  -- It consists of individual test cases and properties, organized in named
  -- groups which form a tree-like hierarchy.
  --
  -- There is no generic way to create a test case. Instead, every test
  -- provider (tasty-hunit, tasty-smallcheck etc.) provides a function to
  -- turn a test case into a 'TestTree'.
  --
  -- Groups can be created using 'testGroup'.
  --
  -- @since 0.1
  data TestTree
    = forall t . IsTest t => SingleTest TestName t
      -- ^ A single test of some particular type
    | TestGroup TestName [TestTree]
      -- ^ Assemble a number of tests into a cohesive group
    | PlusTestOptions (OptionSet -> OptionSet) TestTree
      -- ^ Add some options to child tests
    | forall a . WithResource (ResourceSpec a) (IO a -> TestTree)
      -- ^ Acquire the resource before the tests in the inner tree start and
      -- release it after they finish. The tree gets an `IO` action which
      -- yields the resource, although the resource is shared across all the
      -- tests.
      --
      -- @since 0.5
    | AskOptions (OptionSet -> TestTree)
      -- ^ Ask for the options and customize the tests based on them.
      --
      -- @since 0.6
    | After DependencyType Expr TestTree
      -- ^ Only run after all tests that match a given pattern finish
      -- (and, depending on the 'DependencyType', succeed).
      --
      -- @since 1.2
  
  -- | Create a named group of test cases or other groups. Tests are executed in
  -- parallel. For sequential execution, see 'sequentialTestGroup'.
  --
  -- @since 0.1
  testGroup :: TestName -> [TestTree] -> TestTree
  testGroup = TestGroup
  
  {-# DEPRECATED sequentialTestGroup "Use dependentTestGroup instead" #-}
  -- | Legacy name for 'dependentTestGroup'.
  --
  -- @since 1.5
  sequentialTestGroup :: TestName -> DependencyType -> [TestTree] -> TestTree
  sequentialTestGroup = dependentTestGroup
    
  -- | Create a named group of test cases or other groups. Tests are executed in
  -- order and each test is considered a dependency of the next one. If a filter
  -- is applied, any dependencies are run too, even if they would otherwise not
  -- match the filter's criteria.
  --
  -- For parallel execution, see 'testGroup'. For ordered test execution, but
  -- without dependencies, see 'inOrderTestGroup'.
  --
  -- Note that this is will only work when used with the default `TestManager`.
  -- If you use another manager, like `tasty-rerun` for instance, sequentiality
  -- might possibly be ignored.
  --
  -- @since 1.5
  dependentTestGroup :: TestName -> DependencyType -> [TestTree] -> TestTree
  dependentTestGroup nm depType = setDependent . TestGroup nm . map setParallel
   where
    setParallel = PlusTestOptions (setOption $ Independent Parallel)
    setDependent = PlusTestOptions (setOption (Dependent depType))
  
  
  -- | Create a named group of test cases that will be played sequentially,
  -- in the exact order provided, though filters are still applied.
  --
  -- Note that this is will only work when used with the default `TestManager`.
  -- If you use another manager, like `tasty-rerun` for instance, the fact that
  -- these tests should be run in the given order might possibly be ignored.
  inOrderTestGroup :: TestName -> [TestTree] -> TestTree
  inOrderTestGroup nm = setSequential . TestGroup nm . map setParallel
   where
    setParallel = PlusTestOptions (setOption $ Independent Parallel)
    setSequential = PlusTestOptions (setOption (Independent NonParallel))
  
  -- | Like 'after', but accepts the pattern as a syntax tree instead
  -- of a string. Useful for generating a test tree programmatically.
  --
  -- ==== __Examples__
  --
  -- Only match on the test's own name, ignoring the group names:
  --
  -- @
  -- 'after_' 'AllFinish' ('Test.Tasty.Patterns.Types.EQ' ('Field' 'NF') ('StringLit' \"Bar\")) $
  --    @testCase@ \"A test that depends on Foo.Bar\" $ ...
  -- @
  --
  -- @since 1.2
  after_
    :: DependencyType -- ^ whether to run the tests even if some of the dependencies fail
    -> Expr -- ^ the pattern
    -> TestTree -- ^ the subtree that depends on other tests
    -> TestTree -- ^ the subtree annotated with dependency information
  after_ = After
  
  -- | The 'after' combinator declares dependencies between tests.
  --
  -- If a 'TestTree' is wrapped in 'after', the tests in this tree will not run
  -- until certain other tests («dependencies») have finished. These
  -- dependencies are specified using an AWK pattern (see the «Patterns» section
  -- in the README).
  --
  -- Moreover, if the 'DependencyType' argument is set to 'AllSucceed' and
  -- at least one dependency has failed, this test tree will not run at all.
  --
  -- Tasty does not check that the pattern matches any tests (let alone the
  -- correct set of tests), so it is on you to supply the right pattern.
  --
  -- ==== __Examples__
  --
  -- The following test will be executed only after all tests that contain
  -- @Foo@ anywhere in their path finish.
  --
  -- @
  -- 'after' 'AllFinish' \"Foo\" $
  --    @testCase@ \"A test that depends on Foo.Bar\" $ ...
  -- @
  --
  -- Note, however, that our test also happens to contain @Foo@ as part of its name,
  -- so it also matches the pattern and becomes a dependency of itself. This
  -- will result in a 'Test.Tasty.DependencyLoop' exception. To avoid this, either
  -- change the test name so that it doesn't mention @Foo@ or make the
  -- pattern more specific.
  --
  -- You can use AWK patterns, for instance, to specify the full path to the dependency.
  --
  -- @
  -- 'after' 'AllFinish' \"$0 == \\\"Tests.Foo.Bar\\\"\" $
  --    @testCase@ \"A test that depends on Foo.Bar\" $ ...
  -- @
  --
  -- Or only specify the dependency's own name, ignoring the group names:
  --
  -- @
  -- 'after' 'AllFinish' \"$NF == \\\"Bar\\\"\" $
  --    @testCase@ \"A test that depends on Foo.Bar\" $ ...
  -- @
  --
  -- @since 1.2
  after
    :: DependencyType -- ^ whether to run the tests even if some of the dependencies fail
    -> String -- ^ the pattern
    -> TestTree -- ^ the subtree that depends on other tests
    -> TestTree -- ^ the subtree annotated with dependency information
  after deptype s =
    case parseExpr s of
      Nothing -> error $ "Could not parse pattern " ++ show s
      Just e -> after_ deptype e
  
  -- | An algebra for folding a `TestTree`.
  --
  -- Instead of constructing fresh records, build upon `trivialFold`
  -- instead. This way your code won't break when new nodes/fields are
  -- indroduced.
  --
  -- @since 0.7
  data TreeFold b = TreeFold
    { foldSingle :: forall t . IsTest t => OptionSet -> TestName -> t -> b
    , foldGroup :: OptionSet -> TestName -> [b] -> b
    -- ^ @since 1.4
    , foldResource :: forall a . OptionSet -> ResourceSpec a -> (IO a -> b) -> b
    , foldAfter :: OptionSet -> DependencyType -> Expr -> b -> b
    -- ^ @since 1.2
    }
  
  -- | 'trivialFold' can serve as the basis for custom folds. Just override
  -- the fields you need.
  --
  -- Here's what it does:
  --
  -- * single tests are mapped to `mempty` (you probably do want to override that)
  --
  -- * test groups are returned unmodified
  --
  -- * for a resource, an IO action that throws an exception is passed (you
  -- want to override this for runners/ingredients that execute tests)
  --
  -- @since 0.7
  trivialFold :: Monoid b => TreeFold b
  trivialFold = TreeFold
    { foldSingle = \_ _ _ -> mempty
    , foldGroup = \_ _ bs -> mconcat bs
    , foldResource = \_ _ f -> f $ throwIO NotRunningTests
    , foldAfter = \_ _ _ b -> b
    }
  
  
  -- | Indicates whether a test matched in an evaluated subtree. If no filter was
  -- used, tests always match.
  type TestMatched = Any
  
  -- | Used to force tests to be included, even if they would be filtered out by
  -- a user's filter. This is used to force dependencies of a test to run. For
  -- example, if test @A@ depends on test @B@ and test @A@ is selected to run, test
  -- @B@ will be forced to match. Note that this only applies to dependencies
  -- specified using 'sequentialTestGroup'.
  type ForceTestMatch = Any
  
  -- | Fold a test tree into a single value.
  --
  -- The fold result type should be a monoid. This is used to fold multiple
  -- results in a test group. In particular, empty groups get folded into 'mempty'.
  --
  -- Apart from pure convenience, this function also does the following
  -- useful things:
  --
  -- 1. Keeping track of the current options (which may change due to
  -- `PlusTestOptions` nodes)
  --
  -- 2. Filtering out the tests which do not match the patterns
  --
  -- Thus, it is preferred to an explicit recursive traversal of the tree.
  --
  -- @since 0.7
  foldTestTree
    :: forall b . Monoid b
    => TreeFold b
       -- ^ the algebra (i.e. how to fold a tree)
    -> OptionSet
       -- ^ initial options
    -> TestTree
       -- ^ the tree to fold
    -> b
  foldTestTree = foldTestTree0 mempty
  
  -- | Like 'foldTestTree', but with a custom (non-Monoid) empty value. Unlike
  -- 'foldTestTree', it is not part of the public API.
  foldTestTree0
    :: forall b
     . b
       -- ^ "empty" value
    -> TreeFold b
       -- ^ the algebra (i.e. how to fold a tree)
    -> OptionSet
       -- ^ initial options
    -> TestTree
       -- ^ the tree to fold
    -> b
  foldTestTree0 empty (TreeFold fTest fGroup fResource fAfter) opts0 tree0 =
    go (filterByPattern (annotatePath (evaluateOptions opts0 tree0)))
    where
      go :: AnnTestTree OptionSet -> b
      go = \case
        AnnEmptyTestTree               -> empty
        AnnSingleTest opts name test   -> fTest opts name test
        AnnTestGroup opts name trees   -> fGroup opts name (map go trees)
        AnnWithResource opts res0 tree -> fResource opts res0 $ \res -> go (tree res)
        AnnAfter opts deptype dep tree -> fAfter opts deptype dep (go tree)
  
  -- | 'TestTree' with arbitrary annotations, e. g., evaluated 'OptionSet'.
  data AnnTestTree ann
    = AnnEmptyTestTree
    -- ^ Just an empty test tree (e. g., when everything has been filtered out).
    | forall t . IsTest t => AnnSingleTest ann TestName t
    -- ^ Annotated counterpart of 'SingleTest'.
    | AnnTestGroup ann TestName [AnnTestTree ann]
    -- ^ Annotated counterpart of 'TestGroup'.
    | forall a . AnnWithResource ann (ResourceSpec a) (IO a -> AnnTestTree ann)
    -- ^ Annotated counterpart of 'WithResource'.
    | AnnAfter ann DependencyType Expr (AnnTestTree ann)
    -- ^ Annotated counterpart of 'After'.
  
  -- | Annotate 'TestTree' with options, removing 'PlusTestOptions' and 'AskOptions' nodes.
  evaluateOptions :: OptionSet -> TestTree -> AnnTestTree OptionSet
  evaluateOptions opts = \case
    SingleTest name test ->
      AnnSingleTest opts name test
    TestGroup name trees ->
      AnnTestGroup opts name $ map (evaluateOptions opts) trees
    PlusTestOptions f tree ->
      evaluateOptions (f opts) tree
    WithResource res0 tree ->
      AnnWithResource opts res0 $ \res -> evaluateOptions opts (tree res)
    AskOptions f ->
      evaluateOptions opts (f opts)
    After deptype dep tree ->
      AnnAfter opts deptype dep $ evaluateOptions opts tree
  
  -- | Annotate 'AnnTestTree' with paths.
  annotatePath :: AnnTestTree OptionSet -> AnnTestTree (OptionSet, Path)
  annotatePath = go mempty
    where
      go :: Seq.Seq TestName -> AnnTestTree OptionSet -> AnnTestTree (OptionSet, Path)
      go path = \case
        AnnEmptyTestTree -> AnnEmptyTestTree
        AnnSingleTest opts name tree ->
          AnnSingleTest (opts, path |> name) name tree
        AnnTestGroup opts name trees ->
          let newPath = path |> name in
          AnnTestGroup (opts, newPath) name (map (go newPath) trees)
        AnnWithResource opts res0 tree ->
          AnnWithResource (opts, path) res0 $ \res -> go path (tree res)
        AnnAfter opts deptype dep tree ->
          AnnAfter (opts, path) deptype dep (go path tree)
  
  -- | Filter test tree by pattern, replacing leafs with 'AnnEmptyTestTree'.
  filterByPattern :: AnnTestTree (OptionSet, Path) -> AnnTestTree OptionSet
  filterByPattern = snd . go (Any False)
    where
      mkGroup opts name xs = case filter isNonEmpty xs of
        [] -> AnnEmptyTestTree
        ys -> AnnTestGroup opts name ys
  
      isNonEmpty = \case
        AnnEmptyTestTree -> False
        _                -> True
  
      go
        :: ForceTestMatch
        -> AnnTestTree (OptionSet, Path)
        -> (TestMatched, AnnTestTree OptionSet)
      go forceMatch = \case
        AnnEmptyTestTree ->
          (Any False, AnnEmptyTestTree)
  
        AnnSingleTest (opts, path) name tree
          | getAny forceMatch || testPatternMatches (lookupOption opts) path
          -> (Any True, AnnSingleTest opts name tree)
          | otherwise
          -> (Any False, AnnEmptyTestTree)
  
        AnnTestGroup _ _ [] ->
          (forceMatch, AnnEmptyTestTree)
  
        AnnTestGroup (opts, _) name trees ->
          case lookupOption opts of
            Dependent _ ->
              second
                (mkGroup opts name)
                (mapAccumR go forceMatch trees)
            Independent _ ->
              bimap
                mconcat
                (mkGroup opts name)
                (unzip (map (go forceMatch) trees))
  
        AnnWithResource (opts, _) res0 tree ->
          ( fst (go forceMatch (tree (throwIO NotRunningTests)))
          , AnnWithResource opts res0 $ \res -> snd (go forceMatch (tree res))
          )
  
        AnnAfter (opts, _) deptype dep tree ->
          second
            (AnnAfter opts deptype dep)
            (go forceMatch tree)
  
  -- | Get the list of options that are relevant for a given test tree
  treeOptions :: TestTree -> [OptionDescription]
  treeOptions =
  
    Prelude.concat .
    Map.elems .
  
    foldTestTree
      trivialFold { foldSingle = \_ _ -> getTestOptions }
      mempty
  
    where
      getTestOptions
        :: forall t . IsTest t
        => t -> Map.Map TypeRep [OptionDescription]
      getTestOptions t =
        Map.singleton (typeOf t) $
            witness testOptions t
  