{-# 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 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReportCoverage -> ReportCoverage -> Bool
$c/= :: ReportCoverage -> ReportCoverage -> Bool
== :: ReportCoverage -> ReportCoverage -> Bool
$c== :: ReportCoverage -> ReportCoverage -> Bool
Eq, Eq 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
min :: ReportCoverage -> ReportCoverage -> ReportCoverage
$cmin :: ReportCoverage -> ReportCoverage -> ReportCoverage
max :: ReportCoverage -> ReportCoverage -> ReportCoverage
$cmax :: ReportCoverage -> ReportCoverage -> ReportCoverage
>= :: ReportCoverage -> ReportCoverage -> Bool
$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
compare :: ReportCoverage -> ReportCoverage -> Ordering
$ccompare :: ReportCoverage -> ReportCoverage -> Ordering
Ord, Typeable)

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

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

instance IsOption RemoveTixHash where
  defaultValue :: RemoveTixHash
defaultValue = Bool -> RemoveTixHash
MkRemoveTixHash Bool
False
  parseValue :: String -> Maybe RemoveTixHash
parseValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> RemoveTixHash
MkRemoveTixHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Bool
safeReadBool
  optionName :: Tagged RemoveTixHash String
optionName = forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"remove-tix-hash"
  optionHelp :: Tagged RemoveTixHash String
optionHelp = forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Remove hash from tix file (used for golden tests)"
  optionCLParser :: Parser RemoveTixHash
optionCLParser = forall v. IsOption v => Mod FlagFields v -> v -> Parser v
mkFlagCLParser 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 = forall a. a -> Maybe a
Just (String -> TixDir
MkTixDir String
str)
  optionName :: Tagged TixDir String
optionName = forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"tix-dir"
  optionHelp :: Tagged TixDir String
optionHelp = forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Specify directory for generated tix files"
  showDefaultValue :: TixDir -> Maybe String
showDefaultValue (MkTixDir String
dir) = forall a. a -> Maybe a
Just String
dir

coverageOptions :: [OptionDescription]
coverageOptions :: [OptionDescription]
coverageOptions =
  [ forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy ReportCoverage),
    forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy RemoveTixHash),
    forall v. IsOption v => Proxy v -> OptionDescription
Option (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. a -> NonEmpty a -> NonEmpty a
NE.cons String
groupName)) (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

-- | Collect all tests and
coverageFold :: TreeFold FoldResult
coverageFold :: TreeFold FoldResult
coverageFold =
  forall b. Monoid b => TreeFold b
trivialFold
    { foldSingle :: forall t. IsTest t => OptionSet -> String -> t -> FoldResult
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 <- forall t.
IsTest t =>
OptionSet -> t -> (Progress -> IO ()) -> IO Result
run OptionSet
opts t
test (\Progress
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              Tix
tix <- IO Tix
examineTix
              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: " forall a. Semigroup a => a -> a -> a
<> String
filepath)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> NonEmpty a
NE.singleton String
name, String -> IO ()
f),
      -- Append the name of the testgroup to the list of TestNames
      foldGroup :: OptionSet -> String -> [FoldResult] -> FoldResult
foldGroup = OptionSet -> String -> [FoldResult] -> FoldResult
groupFold
    }

tixFilePath :: OptionSet -> TestName -> Result -> FilePath
tixFilePath :: OptionSet -> String -> Result -> String
tixFilePath OptionSet
opts String
tn Result {Outcome
resultOutcome :: Result -> Outcome
resultOutcome :: Outcome
resultOutcome} = case 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 = 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 = 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 :: Set String
seenNames :: NameGenerator -> Set String
seenNames} String
name
  | String
name forall a. Ord a => a -> Set a -> Bool
`S.member` Set String
seenNames = NameGenerator -> String -> (NameGenerator, String)
freshName NameGenerator
ng (String
name forall a. Semigroup a => a -> a -> a
<> String
"'")
  | Bool
otherwise = (Set String -> NameGenerator
MkNameGenerator (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
_ [] = 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 = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (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
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
fresh forall a. Eq a => a -> a -> Bool
/= String
testname) forall a b. (a -> b) -> a -> b
$
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
      String
"Warning: Test " forall a. Semigroup a => a -> a -> a
<> String
testname forall a. Semigroup a => a -> a -> a
<> String
" is duplicated."
  String -> IO ()
f String
fresh
  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 forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts of
  MkReportCoverage Bool
False -> forall a. Maybe a
Nothing
  MkReportCoverage Bool
True -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
    OptionSet -> TestTree -> IO ()
executeTests OptionSet
opts TestTree
tree
    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 = forall a. (a -> Bool) -> [a] -> [a]
filter (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 forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts of
  MkRemoveTixHash Bool
False -> [TixModule] -> Tix
Tix [TixModule]
txs
  MkRemoveTixHash Bool
True -> [TixModule] -> Tix
Tix (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