{-# LANGUAGE CPP #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NamedFieldPuns #-}
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)
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)
]
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
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
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),
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"
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
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}
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)
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
executeTest ::
NameGenerator ->
(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'
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
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
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