{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Hedgehog.Internal.Property (
Property(..)
, PropertyT(..)
, PropertyName(..)
, PropertyConfig(..)
, TestLimit(..)
, TestCount(..)
, DiscardLimit(..)
, DiscardCount(..)
, ShrinkLimit(..)
, ShrinkCount(..)
, ShrinkRetries(..)
, withTests
, withDiscards
, withShrinks
, withRetries
, property
, test
, forAll
, forAllT
, forAllWith
, forAllWithT
, defaultMinTests
, discard
, Group(..)
, GroupName(..)
, PropertyCount(..)
, MonadTest(..)
, Test
, TestT(..)
, Log(..)
, Journal(..)
, Failure(..)
, Diff(..)
, annotate
, annotateShow
, footnote
, footnoteShow
, failure
, success
, assert
, diff
, (===)
, (/==)
, eval
, evalM
, evalIO
, evalEither
, evalExceptT
, Coverage(..)
, Label(..)
, LabelName(..)
, cover
, classify
, label
, collect
, coverPercentage
, labelCovered
, coverageSuccess
, coverageFailures
, journalCoverage
, Cover(..)
, CoverCount(..)
, CoverPercentage(..)
, toCoverCount
, Confidence(..)
, TerminationCriteria(..)
, confidenceSuccess
, confidenceFailure
, withConfidence
, verifiedTermination
, defaultConfidence
, defaultConfig
, mapConfig
, failDiff
, failException
, failWith
, writeLog
, mkTest
, mkTestT
, runTest
, runTestT
, wilsonBounds
) where
import Control.Applicative (Alternative(..))
import Control.Monad (MonadPlus(..))
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
import Control.Monad.Catch (SomeException(..), displayException)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Fail (MonadFail (..))
import qualified Control.Monad.Fail as Fail
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Morph (MFunctor(..))
import Control.Monad.Primitive (PrimMonad(..))
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.State.Class (MonadState(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Cont (ContT)
import Control.Monad.Trans.Control (ComposeSt, defaultLiftBaseWith, defaultRestoreM)
import Control.Monad.Trans.Control (MonadBaseControl(..), MonadTransControl(..))
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import Control.Monad.Trans.Identity (IdentityT)
import Control.Monad.Trans.Maybe (MaybeT)
import qualified Control.Monad.Trans.RWS.Lazy as Lazy
import qualified Control.Monad.Trans.RWS.Strict as Strict
import Control.Monad.Trans.Reader (ReaderT)
import Control.Monad.Trans.Resource (MonadResource(..))
import Control.Monad.Trans.Resource (ResourceT)
import qualified Control.Monad.Trans.State.Lazy as Lazy
import qualified Control.Monad.Trans.State.Strict as Strict
import qualified Control.Monad.Trans.Writer.Lazy as Lazy
import qualified Control.Monad.Trans.Writer.Strict as Strict
import qualified Data.Char as Char
import Data.Functor.Identity (Identity(..))
import Data.Int (Int64)
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Number.Erf (invnormcdf)
import qualified Data.List as List
import Data.Semigroup (Semigroup(..))
import Data.String (IsString)
import Data.Ratio ((%))
import Data.Typeable (typeOf)
import Hedgehog.Internal.Distributive
import Hedgehog.Internal.Exception
import Hedgehog.Internal.Gen (Gen, GenT)
import qualified Hedgehog.Internal.Gen as Gen
import Hedgehog.Internal.Show
import Hedgehog.Internal.Source
import Language.Haskell.TH.Syntax (Lift)
data Property =
Property {
propertyConfig :: !PropertyConfig
, propertyTest :: PropertyT IO ()
}
newtype PropertyT m a =
PropertyT {
unPropertyT :: TestT (GenT m) a
} deriving (
Functor
, Applicative
, Monad
, MonadIO
, MonadBase b
, MonadThrow
, MonadCatch
, MonadReader r
, MonadState s
, MonadError e
)
deriving instance MonadResource m => MonadResource (PropertyT m)
#if __GLASGOW_HASKELL__ >= 802
deriving instance MonadBaseControl b m => MonadBaseControl b (PropertyT m)
#else
instance MonadBaseControl b m => MonadBaseControl b (PropertyT m) where
type StM (PropertyT m) a = StM (TestT (GenT m)) a
liftBaseWith f = PropertyT $ liftBaseWith $ \rib -> f (rib . unPropertyT)
restoreM = PropertyT . restoreM
#endif
type Test =
TestT Identity
newtype TestT m a =
TestT {
unTest :: ExceptT Failure (Lazy.WriterT Journal m) a
} deriving (
Functor
, Applicative
, MonadIO
, MonadBase b
, MonadThrow
, MonadCatch
, MonadReader r
, MonadState s
)
newtype PropertyName =
PropertyName {
unPropertyName :: String
} deriving (Eq, Ord, Show, IsString, Semigroup, Lift)
newtype Confidence =
Confidence {
unConfidence :: Int64
} deriving (Eq, Ord, Show, Num, Lift)
data PropertyConfig =
PropertyConfig {
propertyDiscardLimit :: !DiscardLimit
, propertyShrinkLimit :: !ShrinkLimit
, propertyShrinkRetries :: !ShrinkRetries
, propertyTerminationCriteria :: !TerminationCriteria
} deriving (Eq, Ord, Show, Lift)
newtype TestLimit =
TestLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)
newtype TestCount =
TestCount Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
newtype DiscardCount =
DiscardCount Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
newtype DiscardLimit =
DiscardLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)
newtype ShrinkLimit =
ShrinkLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)
newtype ShrinkCount =
ShrinkCount Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
newtype ShrinkRetries =
ShrinkRetries Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)
data Group =
Group {
groupName :: !GroupName
, groupProperties :: ![(PropertyName, Property)]
}
newtype GroupName =
GroupName {
unGroupName :: String
} deriving (Eq, Ord, Show, IsString, Semigroup, Lift)
newtype PropertyCount =
PropertyCount Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
data TerminationCriteria =
EarlyTermination Confidence TestLimit
| NoEarlyTermination Confidence TestLimit
| NoConfidenceTermination TestLimit
deriving (Eq, Ord, Show, Lift)
data Log =
Annotation (Maybe Span) String
| Footnote String
| Label (Label Cover)
deriving (Eq, Show)
newtype Journal =
Journal {
journalLogs :: [Log]
} deriving (Eq, Show, Semigroup, Monoid)
data Failure =
Failure (Maybe Span) String (Maybe Diff)
deriving (Eq, Show)
data Diff =
Diff {
diffPrefix :: String
, diffRemoved :: String
, diffInfix :: String
, diffAdded :: String
, diffSuffix :: String
, diffValue :: ValueDiff
} deriving (Eq, Show)
data Cover =
NoCover
| Cover
deriving (Eq, Ord, Show)
newtype CoverCount =
CoverCount {
unCoverCount :: Int
} deriving (Eq, Ord, Show, Num)
newtype CoverPercentage =
CoverPercentage {
unCoverPercentage :: Double
} deriving (Eq, Ord, Show, Num, Fractional)
newtype LabelName =
LabelName {
unLabelName :: String
} deriving (Eq, Monoid, Ord, Semigroup, Show, IsString)
data Label a =
MkLabel {
labelName :: !LabelName
, labelLocation :: !(Maybe Span)
, labelMinimum :: !CoverPercentage
, labelAnnotation :: !a
} deriving (Eq, Show, Functor, Foldable, Traversable)
newtype Coverage a =
Coverage {
coverageLabels :: Map LabelName (Label a)
} deriving (Eq, Show, Functor, Foldable, Traversable)
instance Monad m => Monad (TestT m) where
return =
pure
(>>=) m k =
TestT $
unTest m >>=
unTest . k
instance Monad m => MonadFail (TestT m) where
fail err =
TestT . ExceptT . pure . Left $ Failure Nothing err Nothing
instance MonadTrans TestT where
lift =
TestT . lift . lift
instance MFunctor TestT where
hoist f =
TestT . hoist (hoist f) . unTest
instance MonadTransDistributive TestT where
type Transformer t TestT m = (
Transformer t (Lazy.WriterT Journal) m
, Transformer t (ExceptT Failure) (Lazy.WriterT Journal m)
)
distributeT =
hoist TestT .
distributeT .
hoist distributeT .
unTest
instance PrimMonad m => PrimMonad (TestT m) where
type PrimState (TestT m) =
PrimState m
primitive =
lift . primitive
instance MonadError e m => MonadError e (TestT m) where
throwError =
lift . throwError
catchError m onErr =
TestT . ExceptT $
(runExceptT $ unTest m) `catchError`
(runExceptT . unTest . onErr)
instance MonadResource m => MonadResource (TestT m) where
liftResourceT =
lift . liftResourceT
instance MonadTransControl TestT where
type StT TestT a =
(Either Failure a, Journal)
liftWith f =
mkTestT . fmap (, mempty) . fmap Right $ f $ runTestT
restoreT =
mkTestT
instance MonadBaseControl b m => MonadBaseControl b (TestT m) where
type StM (TestT m) a =
ComposeSt TestT m a
liftBaseWith =
defaultLiftBaseWith
restoreM =
defaultRestoreM
class Monad m => MonadTest m where
liftTest :: Test a -> m a
instance Monad m => MonadTest (TestT m) where
liftTest =
hoist (pure . runIdentity)
instance MonadTest m => MonadTest (IdentityT m) where
liftTest =
lift . liftTest
instance MonadTest m => MonadTest (MaybeT m) where
liftTest =
lift . liftTest
instance MonadTest m => MonadTest (ExceptT x m) where
liftTest =
lift . liftTest
instance MonadTest m => MonadTest (ReaderT r m) where
liftTest =
lift . liftTest
instance MonadTest m => MonadTest (Lazy.StateT s m) where
liftTest =
lift . liftTest
instance MonadTest m => MonadTest (Strict.StateT s m) where
liftTest =
lift . liftTest
instance (MonadTest m, Monoid w) => MonadTest (Lazy.WriterT w m) where
liftTest =
lift . liftTest
instance (MonadTest m, Monoid w) => MonadTest (Strict.WriterT w m) where
liftTest =
lift . liftTest
instance (MonadTest m, Monoid w) => MonadTest (Lazy.RWST r w s m) where
liftTest =
lift . liftTest
instance (MonadTest m, Monoid w) => MonadTest (Strict.RWST r w s m) where
liftTest =
lift . liftTest
instance MonadTest m => MonadTest (ContT r m) where
liftTest =
lift . liftTest
instance MonadTest m => MonadTest (ResourceT m) where
liftTest =
lift . liftTest
mkTestT :: m (Either Failure a, Journal) -> TestT m a
mkTestT =
TestT . ExceptT . Lazy.WriterT
mkTest :: (Either Failure a, Journal) -> Test a
mkTest =
mkTestT . Identity
runTestT :: TestT m a -> m (Either Failure a, Journal)
runTestT =
Lazy.runWriterT . runExceptT . unTest
runTest :: Test a -> (Either Failure a, Journal)
runTest =
runIdentity . runTestT
writeLog :: MonadTest m => Log -> m ()
writeLog x =
liftTest $ mkTest (pure (), (Journal [x]))
failWith :: (MonadTest m, HasCallStack) => Maybe Diff -> String -> m a
failWith mdiff msg =
liftTest $ mkTest (Left $ Failure (getCaller callStack) msg mdiff, mempty)
annotate :: (MonadTest m, HasCallStack) => String -> m ()
annotate x = do
writeLog $ Annotation (getCaller callStack) x
annotateShow :: (MonadTest m, Show a, HasCallStack) => a -> m ()
annotateShow x = do
withFrozenCallStack $ annotate (showPretty x)
footnote :: MonadTest m => String -> m ()
footnote =
writeLog . Footnote
footnoteShow :: (MonadTest m, Show a) => a -> m ()
footnoteShow =
writeLog . Footnote . showPretty
failDiff :: (MonadTest m, Show a, Show b, HasCallStack) => a -> b -> m ()
failDiff x y =
case valueDiff <$> mkValue x <*> mkValue y of
Nothing ->
withFrozenCallStack $
failWith Nothing $
unlines $ [
"Failed"
, "━━ lhs ━━"
, showPretty x
, "━━ rhs ━━"
, showPretty y
]
Just vdiff@(ValueSame _) ->
withFrozenCallStack $
failWith (Just $
Diff "━━━ Failed (" "" "no differences" "" ") ━━━" vdiff) ""
Just vdiff ->
withFrozenCallStack $
failWith (Just $
Diff "━━━ Failed (" "- lhs" ") (" "+ rhs" ") ━━━" vdiff) ""
failException :: (MonadTest m, HasCallStack) => SomeException -> m a
failException (SomeException x) =
withFrozenCallStack $
failWith Nothing $ unlines [
"━━━ Exception (" ++ show (typeOf x) ++ ") ━━━"
, List.dropWhileEnd Char.isSpace (displayException x)
]
failure :: (MonadTest m, HasCallStack) => m a
failure =
withFrozenCallStack $ failWith Nothing ""
success :: MonadTest m => m ()
success =
pure ()
assert :: (MonadTest m, HasCallStack) => Bool -> m ()
assert b = do
ok <- withFrozenCallStack $ eval b
if ok then
success
else
withFrozenCallStack failure
diff :: (MonadTest m, Show a, Show b, HasCallStack) => a -> (a -> b -> Bool) -> b -> m ()
diff x op y = do
ok <- withFrozenCallStack $ eval (x `op` y)
if ok then
success
else
withFrozenCallStack $ failDiff x y
infix 4 ===
(===) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m ()
(===) x y =
withFrozenCallStack $
diff x (==) y
infix 4 /==
(/==) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m ()
(/==) x y =
withFrozenCallStack $
diff x (/=) y
eval :: (MonadTest m, HasCallStack) => a -> m a
eval x =
either (withFrozenCallStack failException) pure (tryEvaluate x)
evalM :: (MonadTest m, MonadCatch m, HasCallStack) => m a -> m a
evalM m =
either (withFrozenCallStack failException) pure =<< tryAll m
evalIO :: (MonadTest m, MonadIO m, HasCallStack) => IO a -> m a
evalIO m =
either (withFrozenCallStack failException) pure =<< liftIO (tryAll m)
evalEither :: (MonadTest m, Show x, HasCallStack) => Either x a -> m a
evalEither = \case
Left x ->
withFrozenCallStack $ failWith Nothing $ showPretty x
Right x ->
pure x
evalExceptT :: (MonadTest m, Show x, HasCallStack) => ExceptT x m a -> m a
evalExceptT m =
withFrozenCallStack evalEither =<< runExceptT m
instance MonadTrans PropertyT where
lift =
PropertyT . lift . lift
instance Monad m => MonadFail (PropertyT m) where
fail err =
PropertyT (Fail.fail err)
instance MFunctor PropertyT where
hoist f =
PropertyT . hoist (hoist f) . unPropertyT
instance MonadTransDistributive PropertyT where
type Transformer t PropertyT m = (
Transformer t GenT m
, Transformer t TestT (GenT m)
)
distributeT =
hoist PropertyT .
distributeT .
hoist distributeT .
unPropertyT
instance PrimMonad m => PrimMonad (PropertyT m) where
type PrimState (PropertyT m) =
PrimState m
primitive =
lift . primitive
instance Monad m => MonadTest (PropertyT m) where
liftTest =
PropertyT . hoist (pure . runIdentity)
instance MonadPlus m => MonadPlus (PropertyT m) where
mzero =
discard
mplus (PropertyT x) (PropertyT y) =
PropertyT . mkTestT $
mplus (runTestT x) (runTestT y)
instance MonadPlus m => Alternative (PropertyT m) where
empty =
mzero
(<|>) =
mplus
forAllWithT :: (Monad m, HasCallStack) => (a -> String) -> GenT m a -> PropertyT m a
forAllWithT render gen = do
x <- PropertyT $ lift gen
withFrozenCallStack $ annotate (render x)
return x
forAllWith :: (Monad m, HasCallStack) => (a -> String) -> Gen a -> PropertyT m a
forAllWith render gen =
withFrozenCallStack $ forAllWithT render $ Gen.generalize gen
forAllT :: (Monad m, Show a, HasCallStack) => GenT m a -> PropertyT m a
forAllT gen =
withFrozenCallStack $ forAllWithT showPretty gen
forAll :: (Monad m, Show a, HasCallStack) => Gen a -> PropertyT m a
forAll gen =
withFrozenCallStack $ forAllWith showPretty gen
discard :: Monad m => PropertyT m a
discard =
PropertyT $ lift (Gen.generalize Gen.discard)
test :: Monad m => TestT m a -> PropertyT m a
test =
PropertyT . hoist lift
defaultConfig :: PropertyConfig
defaultConfig =
PropertyConfig {
propertyDiscardLimit =
100
, propertyShrinkLimit =
1000
, propertyShrinkRetries =
0
, propertyTerminationCriteria =
NoConfidenceTermination defaultMinTests
}
defaultMinTests :: TestLimit
defaultMinTests = 100
defaultConfidence :: Confidence
defaultConfidence = 10 ^ (9 :: Int)
mapConfig :: (PropertyConfig -> PropertyConfig) -> Property -> Property
mapConfig f (Property cfg t) =
Property (f cfg) t
withConfidence :: Confidence -> Property -> Property
withConfidence c =
let
setConfidence = \case
NoEarlyTermination _ tests -> NoEarlyTermination c tests
NoConfidenceTermination tests -> NoEarlyTermination c tests
EarlyTermination _ tests -> EarlyTermination c tests
in
mapConfig $ \config@PropertyConfig{..} ->
config
{ propertyTerminationCriteria =
setConfidence propertyTerminationCriteria
}
verifiedTermination :: Property -> Property
verifiedTermination =
mapConfig $ \config@PropertyConfig{..} ->
let
newTerminationCriteria = case propertyTerminationCriteria of
NoEarlyTermination c tests -> EarlyTermination c tests
NoConfidenceTermination tests -> EarlyTermination defaultConfidence tests
EarlyTermination c tests -> EarlyTermination c tests
in
config { propertyTerminationCriteria = newTerminationCriteria }
withTests :: TestLimit -> Property -> Property
withTests n =
let
setTestLimit tests = \case
NoEarlyTermination c _ -> NoEarlyTermination c tests
NoConfidenceTermination _ -> NoConfidenceTermination tests
EarlyTermination c _ -> EarlyTermination c tests
in
mapConfig $ \config@PropertyConfig{..} ->
config { propertyTerminationCriteria = setTestLimit n propertyTerminationCriteria }
withDiscards :: DiscardLimit -> Property -> Property
withDiscards n =
mapConfig $ \config -> config { propertyDiscardLimit = n }
withShrinks :: ShrinkLimit -> Property -> Property
withShrinks n =
mapConfig $ \config -> config { propertyShrinkLimit = n }
withRetries :: ShrinkRetries -> Property -> Property
withRetries n =
mapConfig $ \config -> config { propertyShrinkRetries = n }
property :: HasCallStack => PropertyT IO () -> Property
property m =
Property defaultConfig $
withFrozenCallStack (evalM m)
instance Semigroup Cover where
(<>) NoCover NoCover =
NoCover
(<>) _ _ =
Cover
instance Monoid Cover where
mempty =
NoCover
mappend =
(<>)
instance Semigroup CoverCount where
(<>) (CoverCount n0) (CoverCount n1) =
CoverCount (n0 + n1)
instance Monoid CoverCount where
mempty =
CoverCount 0
mappend =
(<>)
toCoverCount :: Cover -> CoverCount
toCoverCount = \case
NoCover ->
CoverCount 0
Cover ->
CoverCount 1
instance Semigroup a => Semigroup (Label a) where
(<>) (MkLabel _ _ _ m0) (MkLabel name location percentage m1) =
MkLabel name location percentage (m0 <> m1)
instance Semigroup a => Semigroup (Coverage a) where
(<>) (Coverage c0) (Coverage c1) =
Coverage $
Map.foldrWithKey (Map.insertWith (<>)) c0 c1
instance (Semigroup a, Monoid a) => Monoid (Coverage a) where
mempty =
Coverage mempty
mappend =
(<>)
coverPercentage :: TestCount -> CoverCount -> CoverPercentage
coverPercentage (TestCount tests) (CoverCount count) =
let
percentage :: Double
percentage =
fromIntegral count / fromIntegral tests * 100
thousandths :: Int
thousandths =
round $ percentage * 10
in
CoverPercentage (fromIntegral thousandths / 10)
labelCovered :: TestCount -> Label CoverCount -> Bool
labelCovered tests (MkLabel _ _ minimum_ population) =
coverPercentage tests population >= minimum_
coverageSuccess :: TestCount -> Coverage CoverCount -> Bool
coverageSuccess tests =
null . coverageFailures tests
coverageFailures :: TestCount -> Coverage CoverCount -> [Label CoverCount]
coverageFailures tests (Coverage kvs) =
filter (not . labelCovered tests) (Map.elems kvs)
confidenceSuccess :: TestCount -> Confidence -> Coverage CoverCount -> Bool
confidenceSuccess tests confidence =
let
assertLow :: Label CoverCount -> Bool
assertLow coverCount@MkLabel{..} =
fst (boundsForLabel tests confidence coverCount)
>= unCoverPercentage labelMinimum / 100.0
in
and . fmap assertLow . Map.elems . coverageLabels
confidenceFailure :: TestCount -> Confidence -> Coverage CoverCount -> Bool
confidenceFailure tests confidence =
let
assertHigh :: Label CoverCount -> Bool
assertHigh coverCount@MkLabel{..} =
snd (boundsForLabel tests confidence coverCount)
< (unCoverPercentage labelMinimum / 100.0)
in
or . fmap assertHigh . Map.elems . coverageLabels
boundsForLabel :: TestCount -> Confidence -> Label CoverCount -> (Double, Double)
boundsForLabel tests confidence MkLabel{..} =
wilsonBounds
(fromIntegral $ unCoverCount labelAnnotation)
(fromIntegral tests)
(1 / fromIntegral (unConfidence confidence))
wilsonBounds :: Integer -> Integer -> Double -> (Double, Double)
wilsonBounds positives count acceptance =
let
p =
fromRational $ positives % count
n =
fromIntegral count
z =
invnormcdf $ 1 - acceptance / 2
midpoint =
p + z * z / (2 * n)
offset =
z / (1 + z ** 2 / n) * sqrt (p * (1 - p) / n + z ** 2 / (4 * n ** 2))
denominator =
1 + z * z / n
low =
(midpoint - offset) / denominator
high =
(midpoint + offset) / denominator
in
(low, high)
fromLabel :: Label a -> Coverage a
fromLabel x =
Coverage $
Map.singleton (labelName x) x
unionsCoverage :: Semigroup a => [Coverage a] -> Coverage a
unionsCoverage =
Coverage .
Map.unionsWith (<>) .
fmap coverageLabels
journalCoverage :: Journal -> Coverage CoverCount
journalCoverage (Journal logs) =
fmap toCoverCount .
unionsCoverage $ do
Label x <- logs
pure (fromLabel x)
cover :: (MonadTest m, HasCallStack) => CoverPercentage -> LabelName -> Bool -> m ()
cover minimum_ name covered =
let
cover_ =
if covered then
Cover
else
NoCover
in
writeLog . Label $
MkLabel name (getCaller callStack) minimum_ cover_
classify :: (MonadTest m, HasCallStack) => LabelName -> Bool -> m ()
classify name covered =
withFrozenCallStack $
cover 0 name covered
label :: (MonadTest m, HasCallStack) => LabelName -> m ()
label name =
withFrozenCallStack $
cover 0 name True
collect :: (MonadTest m, Show a, HasCallStack) => a -> m ()
collect x =
withFrozenCallStack $
cover 0 (LabelName (show x)) True