CoverageReporter.hs

{-# 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 (forM_)
import Data.Bifunctor (first)
import Data.Foldable (fold)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
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 (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)

newtype RemoveTixHash = MkRemoveTixHash Bool
  deriving (Eq, Ord, Typeable)

instance IsOption RemoveTixHash where
  defaultValue = MkRemoveTixHash False
  parseValue = fmap MkRemoveTixHash . safeReadBool
  optionName = pure "remove-tix-hash"
  optionHelp = pure "Remove hash from tix file (used for golden tests)"
  optionCLParser = mkFlagCLParser mempty (MkRemoveTixHash True)

newtype TixDir = MkTixDir FilePath

instance IsOption TixDir where
  defaultValue = MkTixDir "tix"
  parseValue str = Just (MkTixDir str)
  optionName = pure "tix-dir"
  optionHelp = pure "Specify directory for generated tix files"
  showDefaultValue (MkTixDir dir) = Just dir

coverageOptions :: [OptionDescription]
coverageOptions =
  [ Option (Proxy :: Proxy ReportCoverage),
    Option (Proxy :: Proxy RemoveTixHash),
    Option (Proxy :: Proxy TixDir)
  ]

-------------------------------------------------------------------------------
-- coverageReporter Ingredient
-------------------------------------------------------------------------------

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

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

#if MIN_VERSION_tasty(1,5,0)
groupFold :: OptionSet -> TestName -> [FoldResult] -> FoldResult
groupFold _ groupName acc = fmap (first (NE.cons groupName)) (concat 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 =
  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 opts n result
              writeTix filepath (removeHash opts tix)
              putStrLn ("Wrote coverage file: " <> filepath)
        pure (NE.singleton name, f),
      -- Append the name of the testgroup to the list of TestNames
      foldGroup = groupFold
    }

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

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

-- | 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 = TestManager coverageOptions coverageRunner

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

-- | 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 = filter (`notElem` pathSeparators)
  where
    -- Include both Windows and Posix, so that generated .tix files
    -- are consistent among systems.
    pathSeparators = ['\\', '/']

removeHash :: OptionSet -> Tix -> Tix
removeHash opts (Tix txs) = case lookupOption opts of
  MkRemoveTixHash False -> Tix txs
  MkRemoveTixHash True -> Tix (fmap removeHashModule txs)

removeHashModule :: TixModule -> TixModule
removeHashModule (TixModule name _hash i is) = TixModule name 0 i is