CoverageReporter.hs

{-# 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 (Eq, Ord, Typeable)

instance IsOption ReportCoverage where
    defaultValue  = MkReportCoverage False
    parseValue = fmap MkReportCoverage . safeReadBool
    optionName = pure "report-coverage"
    optionHelp = pure "Generate per-test coverage data"
    optionCLParser = mkFlagCLParser mempty (MkReportCoverage True)


tixDir :: FilePath
tixDir = "tix"

-- | Obtain the list of all tests in the suite
testNames :: OptionSet -> TestTree -> IO ()
testNames  os tree = forM_ (foldTestTree coverageFold os tree) $ \(s,f) -> f (fold (NE.intersperse "." s))



-- | Collect all tests and
coverageFold :: TreeFold [(NonEmpty TestName, String -> IO ())]
coverageFold = trivialFold
       { foldSingle = \opts name test -> do
          let f n = do
                -- Collect the coverage data for exactly this test.
                clearTix
                result <- run opts test (\_ -> pure ())
                tix <- examineTix
                let filepath = tixFilePath n result
                writeTix filepath tix
                putStrLn ("Wrote coverage file: " <> filepath)
          pure (NE.singleton name, f),
          -- Append the name of the testgroup to the list of TestNames
          foldGroup = \_ groupName acc -> fmap (first (NE.cons groupName)) acc
        }

tixFilePath :: TestName -> Result -> FilePath
tixFilePath tn Result { resultOutcome = Success }  = tixDir </> tn <.> "PASSED" <.> ".tix"
tixFilePath tn Result { resultOutcome = Failure _ } = tixDir </> tn <.> "FAILED" <.> ".tix"

coverageReporter :: Ingredient
coverageReporter = TestManager coverageOptions coverageRunner

coverageOptions :: [OptionDescription]
coverageOptions = [Option (Proxy :: Proxy ReportCoverage)]

coverageRunner :: OptionSet -> TestTree -> Maybe (IO Bool)
coverageRunner opts tree = case lookupOption opts of
  MkReportCoverage False -> Nothing
  MkReportCoverage True -> Just $ do
    testNames opts tree
    pure True