{-# LANGUAGE CPP #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NamedFieldPuns #-}

-- |
-- Module         : Test.Tasty.CoverageReporter
-- Description    : Ingredient for producing per-test coverage reports
--
-- This module provides an ingredient for the tasty framework which allows
-- to generate one coverage file per individual test.
module Test.Tasty.CoverageReporter (coverageReporter) where

import Control.Monad (when)
import Data.Bifunctor (first)
import Data.Foldable (fold)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as S
import Data.Typeable
import System.FilePath ((<.>), (</>))
import System.IO (hPutStrLn, stderr)
import Test.Tasty
import Test.Tasty.Ingredients
import Test.Tasty.Options
import Test.Tasty.Providers
import Test.Tasty.Runners
import Trace.Hpc.Reflect (clearTix, examineTix)
import Trace.Hpc.Tix (Tix (..), TixModule (..), writeTix)

-------------------------------------------------------------------------------
-- Options
-------------------------------------------------------------------------------

newtype ReportCoverage = MkReportCoverage Bool
  deriving (ReportCoverage -> ReportCoverage -> Bool
(ReportCoverage -> ReportCoverage -> Bool)
-> (ReportCoverage -> ReportCoverage -> Bool) -> Eq ReportCoverage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReportCoverage -> ReportCoverage -> Bool
== :: ReportCoverage -> ReportCoverage -> Bool
$c/= :: ReportCoverage -> ReportCoverage -> Bool
/= :: ReportCoverage -> ReportCoverage -> Bool
Eq, Eq ReportCoverage
Eq ReportCoverage =>
(ReportCoverage -> ReportCoverage -> Ordering)
-> (ReportCoverage -> ReportCoverage -> Bool)
-> (ReportCoverage -> ReportCoverage -> Bool)
-> (ReportCoverage -> ReportCoverage -> Bool)
-> (ReportCoverage -> ReportCoverage -> Bool)
-> (ReportCoverage -> ReportCoverage -> ReportCoverage)
-> (ReportCoverage -> ReportCoverage -> ReportCoverage)
-> Ord ReportCoverage
ReportCoverage -> ReportCoverage -> Bool
ReportCoverage -> ReportCoverage -> Ordering
ReportCoverage -> ReportCoverage -> ReportCoverage
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ReportCoverage -> ReportCoverage -> Ordering
compare :: ReportCoverage -> ReportCoverage -> Ordering
$c< :: ReportCoverage -> ReportCoverage -> Bool
< :: ReportCoverage -> ReportCoverage -> Bool
$c<= :: ReportCoverage -> ReportCoverage -> Bool
<= :: ReportCoverage -> ReportCoverage -> Bool
$c> :: ReportCoverage -> ReportCoverage -> Bool
> :: ReportCoverage -> ReportCoverage -> Bool
$c>= :: ReportCoverage -> ReportCoverage -> Bool
>= :: ReportCoverage -> ReportCoverage -> Bool
$cmax :: ReportCoverage -> ReportCoverage -> ReportCoverage
max :: ReportCoverage -> ReportCoverage -> ReportCoverage
$cmin :: ReportCoverage -> ReportCoverage -> ReportCoverage
min :: ReportCoverage -> ReportCoverage -> ReportCoverage
Ord, Typeable)

instance IsOption ReportCoverage where
  defaultValue :: ReportCoverage
defaultValue = Bool -> ReportCoverage
MkReportCoverage Bool
False
  parseValue :: String -> Maybe ReportCoverage
parseValue = (Bool -> ReportCoverage) -> Maybe Bool -> Maybe ReportCoverage
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> ReportCoverage
MkReportCoverage (Maybe Bool -> Maybe ReportCoverage)
-> (String -> Maybe Bool) -> String -> Maybe ReportCoverage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Bool
safeReadBool
  optionName :: Tagged ReportCoverage String
optionName = String -> Tagged ReportCoverage String
forall a. a -> Tagged ReportCoverage a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"report-coverage"
  optionHelp :: Tagged ReportCoverage String
optionHelp = String -> Tagged ReportCoverage String
forall a. a -> Tagged ReportCoverage a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Generate per-test coverage data"
  optionCLParser :: Parser ReportCoverage
optionCLParser = Mod FlagFields ReportCoverage
-> ReportCoverage -> Parser ReportCoverage
forall v. IsOption v => Mod FlagFields v -> v -> Parser v
mkFlagCLParser Mod FlagFields ReportCoverage
forall a. Monoid a => a
mempty (Bool -> ReportCoverage
MkReportCoverage Bool
True)

newtype RemoveTixHash = MkRemoveTixHash Bool
  deriving (RemoveTixHash -> RemoveTixHash -> Bool
(RemoveTixHash -> RemoveTixHash -> Bool)
-> (RemoveTixHash -> RemoveTixHash -> Bool) -> Eq RemoveTixHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RemoveTixHash -> RemoveTixHash -> Bool
== :: RemoveTixHash -> RemoveTixHash -> Bool
$c/= :: RemoveTixHash -> RemoveTixHash -> Bool
/= :: RemoveTixHash -> RemoveTixHash -> Bool
Eq, Eq RemoveTixHash
Eq RemoveTixHash =>
(RemoveTixHash -> RemoveTixHash -> Ordering)
-> (RemoveTixHash -> RemoveTixHash -> Bool)
-> (RemoveTixHash -> RemoveTixHash -> Bool)
-> (RemoveTixHash -> RemoveTixHash -> Bool)
-> (RemoveTixHash -> RemoveTixHash -> Bool)
-> (RemoveTixHash -> RemoveTixHash -> RemoveTixHash)
-> (RemoveTixHash -> RemoveTixHash -> RemoveTixHash)
-> Ord RemoveTixHash
RemoveTixHash -> RemoveTixHash -> Bool
RemoveTixHash -> RemoveTixHash -> Ordering
RemoveTixHash -> RemoveTixHash -> RemoveTixHash
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RemoveTixHash -> RemoveTixHash -> Ordering
compare :: RemoveTixHash -> RemoveTixHash -> Ordering
$c< :: RemoveTixHash -> RemoveTixHash -> Bool
< :: RemoveTixHash -> RemoveTixHash -> Bool
$c<= :: RemoveTixHash -> RemoveTixHash -> Bool
<= :: RemoveTixHash -> RemoveTixHash -> Bool
$c> :: RemoveTixHash -> RemoveTixHash -> Bool
> :: RemoveTixHash -> RemoveTixHash -> Bool
$c>= :: RemoveTixHash -> RemoveTixHash -> Bool
>= :: RemoveTixHash -> RemoveTixHash -> Bool
$cmax :: RemoveTixHash -> RemoveTixHash -> RemoveTixHash
max :: RemoveTixHash -> RemoveTixHash -> RemoveTixHash
$cmin :: RemoveTixHash -> RemoveTixHash -> RemoveTixHash
min :: RemoveTixHash -> RemoveTixHash -> RemoveTixHash
Ord, Typeable)

instance IsOption RemoveTixHash where
  defaultValue :: RemoveTixHash
defaultValue = Bool -> RemoveTixHash
MkRemoveTixHash Bool
False
  parseValue :: String -> Maybe RemoveTixHash
parseValue = (Bool -> RemoveTixHash) -> Maybe Bool -> Maybe RemoveTixHash
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> RemoveTixHash
MkRemoveTixHash (Maybe Bool -> Maybe RemoveTixHash)
-> (String -> Maybe Bool) -> String -> Maybe RemoveTixHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Bool
safeReadBool
  optionName :: Tagged RemoveTixHash String
optionName = String -> Tagged RemoveTixHash String
forall a. a -> Tagged RemoveTixHash a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"remove-tix-hash"
  optionHelp :: Tagged RemoveTixHash String
optionHelp = String -> Tagged RemoveTixHash String
forall a. a -> Tagged RemoveTixHash a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Remove hash from tix file (used for golden tests)"
  optionCLParser :: Parser RemoveTixHash
optionCLParser = Mod FlagFields RemoveTixHash
-> RemoveTixHash -> Parser RemoveTixHash
forall v. IsOption v => Mod FlagFields v -> v -> Parser v
mkFlagCLParser Mod FlagFields RemoveTixHash
forall a. Monoid a => a
mempty (Bool -> RemoveTixHash
MkRemoveTixHash Bool
True)

newtype TixDir = MkTixDir FilePath

instance IsOption TixDir where
  defaultValue :: TixDir
defaultValue = String -> TixDir
MkTixDir String
"tix"
  parseValue :: String -> Maybe TixDir
parseValue String
str = TixDir -> Maybe TixDir
forall a. a -> Maybe a
Just (String -> TixDir
MkTixDir String
str)
  optionName :: Tagged TixDir String
optionName = String -> Tagged TixDir String
forall a. a -> Tagged TixDir a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"tix-dir"
  optionHelp :: Tagged TixDir String
optionHelp = String -> Tagged TixDir String
forall a. a -> Tagged TixDir a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Specify directory for generated tix files"
  showDefaultValue :: TixDir -> Maybe String
showDefaultValue (MkTixDir String
dir) = String -> Maybe String
forall a. a -> Maybe a
Just String
dir

coverageOptions :: [OptionDescription]
coverageOptions :: [OptionDescription]
coverageOptions =
  [ Proxy ReportCoverage -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy ReportCoverage
forall {k} (t :: k). Proxy t
Proxy :: Proxy ReportCoverage),
    Proxy RemoveTixHash -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy RemoveTixHash
forall {k} (t :: k). Proxy t
Proxy :: Proxy RemoveTixHash),
    Proxy TixDir -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy TixDir
forall {k} (t :: k). Proxy t
Proxy :: Proxy TixDir)
  ]

-------------------------------------------------------------------------------
-- Collect the tests
-------------------------------------------------------------------------------

type FoldResult = [(NonEmpty TestName, String -> IO ())]

#if MIN_VERSION_tasty(1,5,0)
groupFold :: OptionSet -> TestName -> [FoldResult] -> FoldResult
groupFold :: OptionSet -> String -> [FoldResult] -> FoldResult
groupFold OptionSet
_ String
groupName [FoldResult]
acc = ((NonEmpty String, String -> IO ())
 -> (NonEmpty String, String -> IO ()))
-> FoldResult -> FoldResult
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NonEmpty String -> NonEmpty String)
-> (NonEmpty String, String -> IO ())
-> (NonEmpty String, String -> IO ())
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> NonEmpty String -> NonEmpty String
forall a. a -> NonEmpty a -> NonEmpty a
NE.cons String
groupName)) ([FoldResult] -> FoldResult
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [FoldResult]
acc)
#else
groupFold :: OptionSet -> TestName -> FoldResult -> FoldResult
groupFold _ groupName acc = fmap (first (NE.cons groupName)) acc
#endif

isEmptyTix :: Tix -> Bool
isEmptyTix :: Tix -> Bool
isEmptyTix (Tix []) = Bool
True
isEmptyTix Tix
_ = Bool
False

-- | Collect all tests and
coverageFold :: TreeFold FoldResult
coverageFold :: TreeFold FoldResult
coverageFold =
  TreeFold FoldResult
forall b. Monoid b => TreeFold b
trivialFold
    { foldSingle = \OptionSet
opts String
name t
test -> do
        let f :: String -> IO ()
f String
n = do
              -- Collect the coverage data for exactly this test.
              IO ()
clearTix
              Result
result <- OptionSet -> t -> (Progress -> IO ()) -> IO Result
forall t.
IsTest t =>
OptionSet -> t -> (Progress -> IO ()) -> IO Result
run OptionSet
opts t
test (\Progress
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              Tix
tix <- IO Tix
examineTix
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Tix -> Bool
isEmptyTix Tix
tix) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Warning: Tix file is empty. Make sure to run the testsuite with -fhpc enabled."
              let filepath :: String
filepath = OptionSet -> String -> Result -> String
tixFilePath OptionSet
opts String
n Result
result
              String -> Tix -> IO ()
writeTix String
filepath (OptionSet -> Tix -> Tix
removeHash OptionSet
opts Tix
tix)
              String -> IO ()
putStrLn (String
"Wrote coverage file: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
filepath)
        (NonEmpty String, String -> IO ()) -> FoldResult
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> NonEmpty String
forall a. a -> NonEmpty a
NE.singleton String
name, String -> IO ()
f),
      -- Append the name of the testgroup to the list of TestNames
      foldGroup = groupFold
    }

tixFilePath :: OptionSet -> TestName -> Result -> FilePath
tixFilePath :: OptionSet -> String -> Result -> String
tixFilePath OptionSet
opts String
tn Result {Outcome
resultOutcome :: Outcome
resultOutcome :: Result -> Outcome
resultOutcome} = case OptionSet -> TixDir
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts of
  MkTixDir String
tixDir -> String
tixDir String -> String -> String
</> String -> String
generateValidFilepath String
tn String -> String -> String
<.> Outcome -> String
outcomeSuffix Outcome
resultOutcome String -> String -> String
<.> String
".tix"

-- | We want to compute the file suffix that we use to distinguish
-- tix files for failing and succeeding tests.
outcomeSuffix :: Outcome -> String
outcomeSuffix :: Outcome -> String
outcomeSuffix Outcome
Success = String
"PASSED"
outcomeSuffix (Failure FailureReason
TestFailed) = String
"FAILED"
outcomeSuffix (Failure (TestThrewException SomeException
_)) = String
"EXCEPTION"
outcomeSuffix (Failure (TestTimedOut Integer
_)) = String
"TIMEOUT"
outcomeSuffix (Failure FailureReason
TestDepFailed) = String
"SKIPPED"

collectTests :: OptionSet -> TestTree -> FoldResult
collectTests :: OptionSet -> TestTree -> FoldResult
collectTests = TreeFold FoldResult -> OptionSet -> TestTree -> FoldResult
forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree TreeFold FoldResult
coverageFold

-------------------------------------------------------------------------------
-- Execute the tests
-------------------------------------------------------------------------------

-- | A fresh name generator which collects names we have encountered before.
newtype NameGenerator = MkNameGenerator {NameGenerator -> Set String
seenNames :: S.Set String}

emptyNameGenerator :: NameGenerator
emptyNameGenerator :: NameGenerator
emptyNameGenerator = MkNameGenerator {seenNames :: Set String
seenNames = Set String
forall a. Set a
S.empty}

-- | Check if the name is already used, and insert ticks until the name is fresh.
-- Returns the name generator extended with the newly generated name.
freshName :: NameGenerator -> String -> (NameGenerator, String)
freshName :: NameGenerator -> String -> (NameGenerator, String)
freshName ng :: NameGenerator
ng@MkNameGenerator {Set String
seenNames :: NameGenerator -> Set String
seenNames :: Set String
seenNames} String
name
  | String
name String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set String
seenNames = NameGenerator -> String -> (NameGenerator, String)
freshName NameGenerator
ng (String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'")
  | Bool
otherwise = (Set String -> NameGenerator
MkNameGenerator (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
S.insert String
name Set String
seenNames), String
name)

-- | Execute the tests
executeTests :: OptionSet -> TestTree -> IO ()
executeTests :: OptionSet -> TestTree -> IO ()
executeTests OptionSet
os TestTree
tree = NameGenerator -> FoldResult -> IO ()
go NameGenerator
emptyNameGenerator (OptionSet -> TestTree -> FoldResult
collectTests OptionSet
os TestTree
tree)
  where
    go :: NameGenerator -> [(NonEmpty TestName, String -> IO ())] -> IO ()
    go :: NameGenerator -> FoldResult -> IO ()
go NameGenerator
_ [] = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go NameGenerator
ng ((NonEmpty String, String -> IO ())
t : FoldResult
ts) = do
      NameGenerator
ng' <- NameGenerator
-> (NonEmpty String, String -> IO ()) -> IO NameGenerator
executeTest NameGenerator
ng (NonEmpty String, String -> IO ())
t
      NameGenerator -> FoldResult -> IO ()
go NameGenerator
ng' FoldResult
ts

-- | Execute a single test
executeTest ::
  -- | The testnames we have already seen.
  NameGenerator ->
  -- | The test we are currently processing
  (NonEmpty String, String -> IO ()) ->
  IO NameGenerator
executeTest :: NameGenerator
-> (NonEmpty String, String -> IO ()) -> IO NameGenerator
executeTest NameGenerator
seen (NonEmpty String
s, String -> IO ()
f) = do
  let testname :: String
testname = NonEmpty String -> String
forall m. Monoid m => NonEmpty m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (String -> NonEmpty String -> NonEmpty String
forall a. a -> NonEmpty a -> NonEmpty a
NE.intersperse String
"." NonEmpty String
s)
  let (NameGenerator
seen', String
fresh) = NameGenerator -> String -> (NameGenerator, String)
freshName NameGenerator
seen String
testname
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
fresh String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
testname) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"Warning: Test " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
testname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is duplicated."
  String -> IO ()
f String
fresh
  NameGenerator -> IO NameGenerator
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameGenerator
seen'

-- | This ingredient implements its own test-runner which can be executed with
-- the @--report-coverage@ command line option.
-- The testrunner executes the tests sequentially and emits one coverage file
-- per executed test.
--
-- @since 0.1.0.0
coverageReporter :: Ingredient
coverageReporter :: Ingredient
coverageReporter = [OptionDescription]
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
TestManager [OptionDescription]
coverageOptions OptionSet -> TestTree -> Maybe (IO Bool)
coverageRunner

coverageRunner :: OptionSet -> TestTree -> Maybe (IO Bool)
coverageRunner :: OptionSet -> TestTree -> Maybe (IO Bool)
coverageRunner OptionSet
opts TestTree
tree = case OptionSet -> ReportCoverage
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts of
  MkReportCoverage Bool
False -> Maybe (IO Bool)
forall a. Maybe a
Nothing
  MkReportCoverage Bool
True -> IO Bool -> Maybe (IO Bool)
forall a. a -> Maybe a
Just (IO Bool -> Maybe (IO Bool)) -> IO Bool -> Maybe (IO Bool)
forall a b. (a -> b) -> a -> b
$ do
    OptionSet -> TestTree -> IO ()
executeTests OptionSet
opts TestTree
tree
    Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

-- | Removes all path separators from the input String in order
-- to generate a valid filepath.
-- The names of some tests contain path separators, so we have to
-- remove them.
generateValidFilepath :: String -> FilePath
generateValidFilepath :: String -> String
generateValidFilepath = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
pathSeparators)
  where
    -- Include both Windows and Posix, so that generated .tix files
    -- are consistent among systems.
    pathSeparators :: String
pathSeparators = [Char
'\\', Char
'/']

removeHash :: OptionSet -> Tix -> Tix
removeHash :: OptionSet -> Tix -> Tix
removeHash OptionSet
opts (Tix [TixModule]
txs) = case OptionSet -> RemoveTixHash
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts of
  MkRemoveTixHash Bool
False -> [TixModule] -> Tix
Tix [TixModule]
txs
  MkRemoveTixHash Bool
True -> [TixModule] -> Tix
Tix ((TixModule -> TixModule) -> [TixModule] -> [TixModule]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TixModule -> TixModule
removeHashModule [TixModule]
txs)

removeHashModule :: TixModule -> TixModule
removeHashModule :: TixModule -> TixModule
removeHashModule (TixModule String
name Hash
_hash Int
i [Integer]
is) = String -> Hash -> Int -> [Integer] -> TixModule
TixModule String
name Hash
0 Int
i [Integer]
is