{-# LANGUAGE InstanceSigs #-}
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 )
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)


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 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 { resultOutcome :: Result -> Outcome
resultOutcome = Outcome
Success }  = TestName
tixDir TestName -> TestName -> TestName
</> TestName
tn TestName -> TestName -> TestName
<.> TestName
"PASSED" TestName -> TestName -> TestName
<.> TestName
".tix"
tixFilePath TestName
tn Result { resultOutcome :: Result -> Outcome
resultOutcome = Failure FailureReason
_ } = TestName
tixDir TestName -> TestName -> TestName
</> TestName
tn TestName -> TestName -> TestName
<.> TestName
"FAILED" TestName -> TestName -> TestName
<.> TestName
".tix"

coverageReporter :: Ingredient
coverageReporter :: Ingredient
coverageReporter = [OptionDescription]
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
TestManager [OptionDescription]
coverageOptions OptionSet -> TestTree -> Maybe (IO Bool)
coverageRunner

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

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