Use [Log] for all labelling/classification

hedgehog-example/hedgehog-example.cabal

@@ -43,6 +43,7 @@ library
 
   exposed-modules:
       Test.Example.Basic
+    , Test.Example.Coverage
     , Test.Example.Exception
     , Test.Example.QuickCheck
     , Test.Example.References

hedgehog-example/src/Test/Example/Coverage.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DoAndIfThenElse #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Test.Example.Coverage (
@@ -12,6 +13,29 @@ import           Hedgehog
 import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
 
+
+prop_label :: Property
+prop_label =
+  withTests 101 . property $ do
+    match <- forAll Gen.bool
+    evalIO $ threadDelay 10000
+    if match then
+      label "True"
+    else
+      label "False"
+
+data Bucket =
+  Bucket !Int
+  deriving (Eq, Show)
+
+prop_collect :: Property
+prop_collect =
+  withTests 101 . property $ do
+    x <- forAll .
+      fmap Bucket . Gen.int $ Range.linear 1 10
+    evalIO $ threadDelay 10000
+    collect x
+
 prop_classify :: Property
 prop_classify =
   withTests 1 . property $ do
@@ -21,16 +45,16 @@ prop_classify =
 
 prop_cover_number :: Property
 prop_cover_number =
-  property $ do
+  withTests 101 . property $ do
     number <- forAll (Gen.int $ Range.linear 1 100)
     evalIO $ threadDelay 20000
-    cover 50 "small number" $ number < 50
-    cover 50 "medium number" $ number >= 20
-    cover 50 "big number" $ number >= 50
+    cover 50 "small number" $ number < 10
+    cover 15 "medium number" $ number >= 20
+    cover 5 "big number" $ number >= 70
 
 prop_cover_bool :: Property
 prop_cover_bool =
-  property $ do
+  withTests 101 . property $ do
     match <- forAll Gen.bool
     cover 30 "True" match
     cover 30 "False" $ not match

hedgehog-example/test/test.hs

@@ -1,6 +1,7 @@
 import           System.IO (BufferMode(..), hSetBuffering, stdout, stderr)
 
 import qualified Test.Example.Basic as Test.Example.Basic
+import qualified Test.Example.Coverage as Test.Example.Coverage
 import qualified Test.Example.Exception as Test.Example.Exception
 import qualified Test.Example.QuickCheck as Test.Example.QuickCheck
 import qualified Test.Example.References as Test.Example.References
@@ -16,6 +17,7 @@ main = do
 
   _results <- sequence [
       Test.Example.Basic.tests
+    , Test.Example.Coverage.tests
     , Test.Example.Exception.tests
     , Test.Example.QuickCheck.tests
     , Test.Example.References.tests

hedgehog/src/Hedgehog/Internal/Property.hs

@@ -65,10 +65,6 @@ module Hedgehog.Internal.Property (
   , (===)
   , (/==)
 
-  , label
-  , collect
-  , collectLogLabels
-
   , eval
   , evalM
   , evalIO
@@ -77,14 +73,17 @@ module Hedgehog.Internal.Property (
 
   -- * Coverage
   , Coverage(..)
-  , Classifier(..)
-  , ClassifierName(..)
-  , classify
+  , Label(..)
+  , LabelName(..)
   , cover
+  , classify
+  , label
+  , collect
   , coverPercentage
-  , classifierCovered
+  , labelCovered
   , coverageSuccess
   , coverageFailures
+  , journalCoverage
 
   , Cover(..)
   , CoverCount(..)
@@ -343,15 +342,14 @@ newtype PropertyCount =
 data Log =
     Annotation (Maybe Span) String
   | Footnote String
-  | Label String
+  | Label (Label Cover)
     deriving (Eq, Show)
 
 -- | A record containing the details of a test run.
-data Journal =
+newtype Journal =
   Journal {
-      journalCoverage :: !(Coverage Cover)
-    , journalLogs :: ![Log]
-    } deriving (Eq, Show)
+      journalLogs :: [Log]
+    } deriving (Eq, Show, Semigroup, Monoid)
 
 -- | Details on where and why a test failed.
 --
@@ -410,25 +408,25 @@ newtype CoverPercentage =
 --   Can be constructed using `OverloadedStrings`:
 --
 -- @
---   "apples" :: ClassifierName
+--   "apples" :: LabelName
 -- @
 --
-newtype ClassifierName =
-  ClassifierName {
-      unClassifierName :: String
+newtype LabelName =
+  LabelName {
+      unLabelName :: String
     } deriving (Eq, Ord, Show, IsString)
 
 -- | The extent to which a test is covered by a classifier.
 --
 --   /When a classifier's coverage does not exceed the required minimum, the
 --   test will be failed./
 --
-data Classifier a =
-  Classifier {
-      classifierName :: !ClassifierName
-    , classifierLocation :: !(Maybe Span)
-    , classifierMinimum :: !CoverPercentage
-    , classifierExtent :: !a
+data Label a =
+  MkLabel {
+      labelName :: !LabelName
+    , labelLocation :: !(Maybe Span)
+    , labelMinimum :: !CoverPercentage
+    , labelAnnotation :: !a
     } deriving (Eq, Show, Functor, Foldable, Traversable)
 
 -- | The extent to which all classifiers cover a test.
@@ -438,7 +436,7 @@ data Classifier a =
 --
 newtype Coverage a =
   Coverage {
-      unCoverage :: Map ClassifierName (Classifier a)
+      coverageLabels :: Map LabelName (Label a)
     } deriving (Eq, Show, Functor, Foldable, Traversable)
 
 ------------------------------------------------------------------------
@@ -572,16 +570,6 @@ instance MonadTest m => MonadTest (ResourceT m) where
   liftTest =
     lift . liftTest
 
-instance Semigroup Journal where
-  (<>) (Journal c0 logs0) (Journal c1 logs1) =
-    Journal (c0 <> c1) (logs0 <> logs1)
-
-instance Monoid Journal where
-  mempty =
-    Journal mempty mempty
-  mappend =
-    (<>)
-
 mkTestT :: m (Either Failure a, Journal) -> TestT m a
 mkTestT =
   TestT . ExceptT . Lazy.WriterT
@@ -598,24 +586,18 @@ runTest :: Test a -> (Either Failure a, Journal)
 runTest =
   runIdentity . runTestT
 
--- | Write the current coverage information.
---
-writeCoverage :: MonadTest m => Coverage Cover -> m ()
-writeCoverage c =
-  liftTest $ mkTest (pure (), Journal c [])
-
 -- | Log some information which might be relevant to a potential test failure.
 --
 writeLog :: MonadTest m => Log -> m ()
 writeLog x =
-  liftTest $ mkTest (pure (), (Journal mempty [x]))
+  liftTest $ mkTest (pure (), (Journal [x]))
 
 -- | Fail the test with an error message, useful for building other failure
 --   combinators.
 --
 failWith :: (MonadTest m, HasCallStack) => Maybe Diff -> String -> m a
 failWith mdiff msg =
-  liftTest $ mkTest (Left $ Failure (getCaller callStack) msg mdiff, (Journal mempty []))
+  liftTest $ mkTest (Left $ Failure (getCaller callStack) msg mdiff, mempty)
 
 -- | Annotates the source code with a message that might be useful for
 --   debugging a test failure.
@@ -645,25 +627,6 @@ footnoteShow :: (MonadTest m, Show a) => a -> m ()
 footnoteShow =
   writeLog . Footnote . showPretty
 
--- | Add a label for each test run. It produces a table showing the percentage
---   of test runs that produced each label.
---
-label :: MonadTest m => String -> m ()
-label =
-  writeLog . Label
-
--- | Like 'label', but uses the 'Show'n value as the label
-collect :: (MonadTest m, Show a) => a -> m ()
-collect =
-  writeLog . Label . show
-
--- | Collect 'Label' values from the 'Log's
-collectLogLabels :: [Log] -> [String]
-collectLogLabels = foldr step []
-  where
-    step (Label s) b = s : b
-    step _ b = b
-
 -- | Fails with an error that shows the difference between two values.
 failDiff :: (MonadTest m, Show a, Show b, HasCallStack) => a -> b -> m ()
 failDiff x y =
@@ -987,7 +950,7 @@ property m =
     withFrozenCallStack (evalM m)
 
 ------------------------------------------------------------------------
--- Classification
+-- Coverage
 
 instance Semigroup Cover where
   (<>) NoCover NoCover =
@@ -1019,11 +982,11 @@ toCoverCount = \case
     CoverCount 1
 
 -- | This semigroup is right biased. The name, location and percentage from the
---   rightmost `Classifier` will be kept. This shouldn't be a problem since the
+--   rightmost `Label` will be kept. This shouldn't be a problem since the
 --   library doesn't allow setting multiple classes with the same 'ClassifierName'.
-instance Semigroup a => Semigroup (Classifier a) where
-  (<>) (Classifier _ _ _ m0) (Classifier name location percentage m1) =
-    Classifier name location percentage (m0 <> m1)
+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) =
@@ -1036,11 +999,6 @@ instance (Semigroup a, Monoid a) => Monoid (Coverage a) where
   mappend =
     (<>)
 
-mkCoverage :: Maybe Span -> ClassifierName -> CoverPercentage -> Cover -> Coverage Cover
-mkCoverage mlocation name minimum_ cover_ =
-  Coverage $
-    Map.singleton name (Classifier name mlocation minimum_ cover_)
-
 coverPercentage :: TestCount -> CoverCount -> CoverPercentage
 coverPercentage (TestCount tests) (CoverCount count) =
   let
@@ -1054,33 +1012,35 @@ coverPercentage (TestCount tests) (CoverCount count) =
   in
     CoverPercentage (fromIntegral thousandths / 10)
 
-classifierCovered :: TestCount -> Classifier CoverCount -> Bool
-classifierCovered tests (Classifier _ _ minimum_ population) =
+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 -> [Classifier CoverCount]
+coverageFailures :: TestCount -> Coverage CoverCount -> [Label CoverCount]
 coverageFailures tests (Coverage kvs) =
-  filter (not . classifierCovered tests) (Map.elems kvs)
+  filter (not . labelCovered tests) (Map.elems kvs)
 
--- | Records the proportion of tests which satisfy a given condition.
---
--- @
---    prop_with_classifier :: Property
---    prop_with_classifier =
---      property $ do
---        xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha
---        for_ xs $ \x -> do
---          classify "newborns" $ x == 0
---          classify "children" $ x > 0 && x < 13
---          classify "teens" $ x > 12 && x < 20
--- @
-classify :: MonadTest m => ClassifierName -> Bool -> m ()
-classify =
-  cover 0
+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)
 
 -- | Require a certain percentage of the tests to be covered by the
 --   classifier.
@@ -1097,7 +1057,7 @@ classify =
 --   The example above requires a minimum of 30% coverage for both
 --   classifiers. If these requirements are not met, it will fail the test.
 --
-cover :: (MonadTest m, HasCallStack) => CoverPercentage -> ClassifierName -> Bool -> m ()
+cover :: (MonadTest m, HasCallStack) => CoverPercentage -> LabelName -> Bool -> m ()
 cover minimum_ name covered =
   let
     cover_ =
@@ -1106,8 +1066,37 @@ cover minimum_ name covered =
       else
         NoCover
   in
-    writeCoverage $
-      mkCoverage (getCaller callStack) name minimum_ cover_
+    writeLog . Label $
+      MkLabel name (getCaller callStack) minimum_ cover_
+
+-- | Records the proportion of tests which satisfy a given condition.
+--
+-- @
+--    prop_with_classifier :: Property
+--    prop_with_classifier =
+--      property $ do
+--        xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha
+--        for_ xs $ \x -> do
+--          classify "newborns" $ x == 0
+--          classify "children" $ x > 0 && x < 13
+--          classify "teens" $ x > 12 && x < 20
+-- @
+classify :: MonadTest m => LabelName -> Bool -> m ()
+classify =
+  cover 0
+
+-- | Add a label for each test run. It produces a table showing the percentage
+--   of test runs that produced each label.
+--
+label :: MonadTest m => LabelName -> m ()
+label name =
+  cover 0 name True
+
+-- | Like 'label', but uses the 'Show'n value as the label.
+--
+collect :: (MonadTest m, Show a) => a -> m ()
+collect x =
+  cover 0 (LabelName (show x)) True
 
 ------------------------------------------------------------------------
 -- FIXME Replace with DeriveLift when we drop 7.10 support.