-- | Core types and definitions
{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts,
             ExistentialQuantification, RankNTypes, DeriveDataTypeable, NoMonomorphismRestriction,
             DeriveGeneric #-}
module Test.Tasty.Core where

import Control.Exception
import Test.Tasty.Providers.ConsoleFormat
import Test.Tasty.Options
import Test.Tasty.Patterns
import Test.Tasty.Patterns.Types
import Data.Foldable
import qualified Data.Sequence as Seq
import Data.Monoid
import Data.Typeable
import qualified Data.Map as Map
import Data.Tagged
import GHC.Generics
import Prelude  -- Silence AMP and FTP import warnings
import Text.Printf

-- | If a test failed, 'FailureReason' describes why
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.
  deriving Int -> FailureReason -> ShowS
[FailureReason] -> ShowS
FailureReason -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailureReason] -> ShowS
$cshowList :: [FailureReason] -> ShowS
show :: FailureReason -> String
$cshow :: FailureReason -> String
showsPrec :: Int -> FailureReason -> ShowS
$cshowsPrec :: Int -> FailureReason -> ShowS
Show

-- | Outcome of a test run
--
-- Note: this is isomorphic to @'Maybe' 'FailureReason'@. You can use the
-- @generic-maybe@ package to exploit that.
data Outcome
  = Success -- ^ test succeeded
  | Failure FailureReason -- ^ test failed because of the 'FailureReason'
  deriving (Int -> Outcome -> ShowS
[Outcome] -> ShowS
Outcome -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Outcome] -> ShowS
$cshowList :: [Outcome] -> ShowS
show :: Outcome -> String
$cshow :: Outcome -> String
showsPrec :: Int -> Outcome -> ShowS
$cshowsPrec :: Int -> Outcome -> ShowS
Show, forall x. Rep Outcome x -> Outcome
forall x. Outcome -> Rep Outcome x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Outcome x -> Outcome
$cfrom :: forall x. Outcome -> Rep Outcome x
Generic)

-- | Time in seconds. Used to measure how long the tests took to run.
type Time = Double

-- | A test result
data Result = Result
  { Result -> Outcome
resultOutcome :: Outcome
    -- ^ Did the test fail? If so, why?
  , Result -> String
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.
  , Result -> String
resultShortDescription :: String
    -- ^ The short description printed in the test run summary, usually @OK@ or
    -- @FAIL@.
  , Result -> Time
resultTime :: Time
    -- ^ How long it took to run the test, in seconds.
  , Result -> ResultDetailsPrinter
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 Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show

{- 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.
resultSuccessful :: Result -> Bool
resultSuccessful :: Result -> Bool
resultSuccessful Result
r =
  case Result -> Outcome
resultOutcome Result
r of
    Outcome
Success -> Bool
True
    Failure {} -> Bool
False

-- | Shortcut for creating a 'Result' that indicates exception
exceptionResult :: SomeException -> Result
exceptionResult :: SomeException -> Result
exceptionResult SomeException
e = Result
  { resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure forall a b. (a -> b) -> a -> b
$ SomeException -> FailureReason
TestThrewException SomeException
e
  , resultDescription :: String
resultDescription = String
"Exception: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
e
  , resultShortDescription :: String
resultShortDescription = String
"FAIL"
  , resultTime :: Time
resultTime = Time
0
  , resultDetailsPrinter :: ResultDetailsPrinter
resultDetailsPrinter = 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.
data Progress = Progress
  { Progress -> String
progressText :: String
    -- ^ textual information about the test's progress
  , Progress -> Float
progressPercent :: Float
    -- ^
    -- 'progressPercent' should be a value between 0 and 1. If it's impossible
    -- to compute the estimate, use 0.
  }
  deriving Int -> Progress -> ShowS
[Progress] -> ShowS
Progress -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Progress] -> ShowS
$cshowList :: [Progress] -> ShowS
show :: Progress -> String
$cshow :: Progress -> String
showsPrec :: Int -> Progress -> ShowS
$cshowsPrec :: Int -> Progress -> ShowS
Show

-- | 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.
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.
                           -- Note: the callback is a no-op at the moment
                           -- and there are no plans to use it;
                           -- feel free to ignore this argument for now.
    -> 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
type TestName = String

-- | 'ResourceSpec' describes how to acquire a resource (the first field)
-- and how to release it (the second field).
data ResourceSpec a = ResourceSpec (IO a) (a -> IO ())

-- | A resources-related exception
data ResourceError
  = NotRunningTests
  | UnexpectedState String String
  | UseOutsideOfTest
  deriving Typeable

instance Show ResourceError where
  show :: ResourceError -> String
show ResourceError
NotRunningTests =
    String
"Unhandled resource. Probably a bug in the runner you're using."
  show (UnexpectedState String
where_ String
what) =
    forall r. PrintfType r => String -> r
printf String
"Unexpected state of the resource (%s) in %s. Report as a tasty bug."
      String
what String
where_
  show ResourceError
UseOutsideOfTest =
    String
"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 (DependencyType -> DependencyType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DependencyType -> DependencyType -> Bool
$c/= :: DependencyType -> DependencyType -> Bool
== :: DependencyType -> DependencyType -> Bool
$c== :: DependencyType -> DependencyType -> Bool
Eq, Int -> DependencyType -> ShowS
[DependencyType] -> ShowS
DependencyType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DependencyType] -> ShowS
$cshowList :: [DependencyType] -> ShowS
show :: DependencyType -> String
$cshow :: DependencyType -> String
showsPrec :: Int -> DependencyType -> ShowS
$cshowsPrec :: Int -> DependencyType -> ShowS
Show)

-- | 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'.
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.
  | AskOptions (OptionSet -> TestTree)
    -- ^ Ask for the options and customize the tests based on them
  | After DependencyType Expr TestTree
    -- ^ Only run after all tests that match a given pattern finish
    -- (and, depending on the 'DependencyType', succeed)

-- | Create a named group of test cases or other groups
testGroup :: TestName -> [TestTree] -> TestTree
testGroup :: String -> [TestTree] -> TestTree
testGroup = String -> [TestTree] -> TestTree
TestGroup

-- | 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_ :: DependencyType -> Expr -> TestTree -> TestTree
after_ = DependencyType -> Expr -> TestTree -> TestTree
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 :: DependencyType -> String -> TestTree -> TestTree
after DependencyType
deptype String
s =
  case String -> Maybe Expr
parseExpr String
s of
    Maybe Expr
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Could not parse pattern " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s
    Just Expr
e -> DependencyType -> Expr -> TestTree -> TestTree
after_ DependencyType
deptype Expr
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.
data TreeFold b = TreeFold
  { forall b.
TreeFold b -> forall t. IsTest t => OptionSet -> String -> t -> b
foldSingle :: forall t . IsTest t => OptionSet -> TestName -> t -> b
  , forall b. TreeFold b -> OptionSet -> String -> b -> b
foldGroup :: OptionSet -> TestName -> b -> b
  , forall b.
TreeFold b
-> forall a. OptionSet -> ResourceSpec a -> (IO a -> b) -> b
foldResource :: forall a . OptionSet -> ResourceSpec a -> (IO a -> b) -> b
  , forall b.
TreeFold b -> OptionSet -> DependencyType -> Expr -> b -> b
foldAfter :: OptionSet -> DependencyType -> Expr -> b -> b
  }

-- | '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)
trivialFold :: Monoid b => TreeFold b
trivialFold :: forall b. Monoid b => TreeFold b
trivialFold = TreeFold
  { foldSingle :: forall t. IsTest t => OptionSet -> String -> t -> b
foldSingle = \OptionSet
_ String
_ t
_ -> forall a. Monoid a => a
mempty
  , foldGroup :: OptionSet -> String -> b -> b
foldGroup = \OptionSet
_ String
_ b
b -> b
b
  , foldResource :: forall a. OptionSet -> ResourceSpec a -> (IO a -> b) -> b
foldResource = \OptionSet
_ ResourceSpec a
_ IO a -> b
f -> IO a -> b
f forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO ResourceError
NotRunningTests
  , foldAfter :: OptionSet -> DependencyType -> Expr -> b -> b
foldAfter = \OptionSet
_ DependencyType
_ Expr
_ b
b -> b
b
  }

-- | 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.
--
-- Note: right now, the patterns are looked up only once, and won't be
-- affected by the subsequent option changes. This shouldn't be a problem
-- in practice; OTOH, this behaviour may be changed later.
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 :: forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree (TreeFold forall t. IsTest t => OptionSet -> String -> t -> b
fTest OptionSet -> String -> b -> b
fGroup forall a. OptionSet -> ResourceSpec a -> (IO a -> b) -> b
fResource OptionSet -> DependencyType -> Expr -> b -> b
fAfter) OptionSet
opts0 TestTree
tree0 =
  Seq String -> OptionSet -> TestTree -> b
go forall a. Monoid a => a
mempty OptionSet
opts0 TestTree
tree0
  where
    go :: (Seq.Seq TestName -> OptionSet -> TestTree -> b)
    go :: Seq String -> OptionSet -> TestTree -> b
go Seq String
path OptionSet
opts TestTree
tree1 =
      case TestTree
tree1 of
        SingleTest String
name t
test
          | TestPattern -> Seq String -> Bool
testPatternMatches TestPattern
pat (Seq String
path forall a. Seq a -> a -> Seq a
Seq.|> String
name)
            -> forall t. IsTest t => OptionSet -> String -> t -> b
fTest OptionSet
opts String
name t
test
          | Bool
otherwise -> forall a. Monoid a => a
mempty
        TestGroup String
name [TestTree]
trees ->
          OptionSet -> String -> b -> b
fGroup OptionSet
opts String
name forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Seq String -> OptionSet -> TestTree -> b
go (Seq String
path forall a. Seq a -> a -> Seq a
Seq.|> String
name) OptionSet
opts) [TestTree]
trees
        PlusTestOptions OptionSet -> OptionSet
f TestTree
tree -> Seq String -> OptionSet -> TestTree -> b
go Seq String
path (OptionSet -> OptionSet
f OptionSet
opts) TestTree
tree
        WithResource ResourceSpec a
res0 IO a -> TestTree
tree -> forall a. OptionSet -> ResourceSpec a -> (IO a -> b) -> b
fResource OptionSet
opts ResourceSpec a
res0 forall a b. (a -> b) -> a -> b
$ \IO a
res -> Seq String -> OptionSet -> TestTree -> b
go Seq String
path OptionSet
opts (IO a -> TestTree
tree IO a
res)
        AskOptions OptionSet -> TestTree
f -> Seq String -> OptionSet -> TestTree -> b
go Seq String
path OptionSet
opts (OptionSet -> TestTree
f OptionSet
opts)
        After DependencyType
deptype Expr
dep TestTree
tree -> OptionSet -> DependencyType -> Expr -> b -> b
fAfter OptionSet
opts DependencyType
deptype Expr
dep forall a b. (a -> b) -> a -> b
$ Seq String -> OptionSet -> TestTree -> b
go Seq String
path OptionSet
opts TestTree
tree
      where
        pat :: TestPattern
pat = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts :: TestPattern

-- | Get the list of options that are relevant for a given test tree
treeOptions :: TestTree -> [OptionDescription]
treeOptions :: TestTree -> [OptionDescription]
treeOptions =

  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
Prelude.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
.

  forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree
    forall b. Monoid b => TreeFold b
trivialFold { foldSingle :: forall t.
IsTest t =>
OptionSet -> String -> t -> Map TypeRep [OptionDescription]
foldSingle = \OptionSet
_ String
_ -> forall t. IsTest t => t -> Map TypeRep [OptionDescription]
getTestOptions }
    forall a. Monoid a => a
mempty

  where
    getTestOptions
      :: forall t . IsTest t
      => t -> Map.Map TypeRep [OptionDescription]
    getTestOptions :: forall t. IsTest t => t -> Map TypeRep [OptionDescription]
getTestOptions t
t =
      forall k a. k -> a -> Map k a
Map.singleton (forall a. Typeable a => a -> TypeRep
typeOf t
t) forall a b. (a -> b) -> a -> b
$
          forall a b. Tagged a b -> a -> b
witness forall t. IsTest t => Tagged t [OptionDescription]
testOptions t
t