{-# LANGUAGE InstanceSigs, NamedFieldPuns #-}
module Test.Tasty.CoverageReporter (coverageReporter) where

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

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 :: TestName -> 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
. TestName -> Maybe Bool
safeReadBool
    optionName :: Tagged ReportCoverage TestName
optionName = forall (f :: * -> *) a. Applicative f => a -> f a
pure TestName
"report-coverage"
    optionHelp :: Tagged ReportCoverage TestName
optionHelp = forall (f :: * -> *) a. Applicative f => a -> f a
pure TestName
"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 :: TestName -> 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
. TestName -> Maybe Bool
safeReadBool
  optionName :: Tagged RemoveTixHash TestName
optionName = forall (f :: * -> *) a. Applicative f => a -> f a
pure TestName
"remove-tix-hash"
  optionHelp :: Tagged RemoveTixHash TestName
optionHelp = forall (f :: * -> *) a. Applicative f => a -> f a
pure TestName
"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)

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)
                  ]


tixDir :: FilePath
tixDir :: TestName
tixDir = TestName
"tix"

-- | Obtain the list of all tests in the suite
testNames :: OptionSet -> TestTree -> IO ()
testNames :: OptionSet -> TestTree -> IO ()
testNames  OptionSet
os TestTree
tree = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree TreeFold [(NonEmpty TestName, TestName -> IO ())]
coverageFold OptionSet
os TestTree
tree) forall a b. (a -> b) -> a -> b
$ \(NonEmpty TestName
s,TestName -> IO ()
f) -> TestName -> IO ()
f (forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a. a -> NonEmpty a -> NonEmpty a
NE.intersperse TestName
"." NonEmpty TestName
s))



-- | Collect all tests and
coverageFold :: TreeFold [(NonEmpty TestName, String -> IO ())]
coverageFold :: TreeFold [(NonEmpty TestName, TestName -> IO ())]
coverageFold = forall b. Monoid b => TreeFold b
trivialFold
       { foldSingle :: forall t.
IsTest t =>
OptionSet
-> TestName -> t -> [(NonEmpty TestName, TestName -> IO ())]
foldSingle = \OptionSet
opts TestName
name t
test -> do
          let f :: TestName -> IO ()
f TestName
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 :: TestName
filepath = TestName -> Result -> TestName
tixFilePath TestName
n Result
result
                TestName -> Tix -> IO ()
writeTix TestName
filepath (OptionSet -> Tix -> Tix
removeHash OptionSet
opts Tix
tix)
                TestName -> IO ()
putStrLn (TestName
"Wrote coverage file: " forall a. Semigroup a => a -> a -> a
<> TestName
filepath)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> NonEmpty a
NE.singleton TestName
name, TestName -> IO ()
f),
          -- Append the name of the testgroup to the list of TestNames
          foldGroup :: OptionSet
-> TestName
-> [(NonEmpty TestName, TestName -> IO ())]
-> [(NonEmpty TestName, TestName -> IO ())]
foldGroup = \OptionSet
_ TestName
groupName [(NonEmpty TestName, TestName -> IO ())]
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 TestName
groupName)) [(NonEmpty TestName, TestName -> IO ())]
acc
        }

tixFilePath :: TestName -> Result -> FilePath
tixFilePath :: TestName -> Result -> TestName
tixFilePath TestName
tn Result { Outcome
resultOutcome :: Result -> Outcome
resultOutcome :: Outcome
resultOutcome }  =
  TestName
tixDir TestName -> TestName -> TestName
</> TestName -> TestName
generateValidFilepath TestName
tn TestName -> TestName -> TestName
<.> Outcome -> TestName
outcomeSuffix Outcome
resultOutcome TestName -> TestName -> TestName
<.> TestName
".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 -> TestName
outcomeSuffix Outcome
Success = TestName
"PASSED"
outcomeSuffix (Failure FailureReason
TestFailed) = TestName
"FAILED"
outcomeSuffix (Failure (TestThrewException SomeException
_)) = TestName
"EXCEPTION"
outcomeSuffix (Failure (TestTimedOut Integer
_)) = TestName
"TIMEOUT"
outcomeSuffix (Failure FailureReason
TestDepFailed) = TestName
"SKIPPED"

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 ()
testNames 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 :: TestName -> TestName
generateValidFilepath = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` TestName
pathSeparators)
  where
    -- Include both Windows and Posix, so that generated .tix files
    -- are consistent among systems.
    pathSeparators :: TestName
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 TestName
name Hash
_hash Int
i [Integer]
is) = TestName -> Hash -> Int -> [Integer] -> TixModule
TixModule TestName
name Hash
0 Int
i [Integer]
is