tasty-hedgehog-coverage (empty) → 0.1.0.0
raw patch · 6 files changed
+496/−0 lines, 6 filesdep +basedep +containersdep +hedgehogsetup-changed
Dependencies added: base, containers, hedgehog, mtl, tagged, tasty, tasty-expected-failure, tasty-hedgehog, tasty-hedgehog-coverage, text, transformers, wl-pprint-annotated
Files
- LICENCE +31/−0
- Setup.hs +2/−0
- changelog.md +3/−0
- src/Test/Tasty/Hedgehog/Coverage.hs +355/−0
- tasty-hedgehog-coverage.cabal +58/−0
- test/Main.hs +47/−0
+ LICENCE view
@@ -0,0 +1,31 @@+Copyright (c) 2018, Commonwealth Scientific and Industrial Research Organisation+(CSIRO) ABN 41 687 119 230.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of QFPL nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
@@ -0,0 +1,3 @@+0.1.0.0++* First version. Released on an unsuspecting world.
+ src/Test/Tasty/Hedgehog/Coverage.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Provide some functionality for tracking the distribution of test inputs+-- when using Hedgehog property-based testing.+module Test.Tasty.Hedgehog.Coverage+ (+ -- * Data types+ Cover (..)+ , Tally (..)++ -- * Test helpers+ , testPropertyCoverage+ , withCoverage++ -- * Coverage functions+ , classify+ , label+ , collect++ -- * Property Config Helpers+ -- | These functions work exactly as their original Hedgehog counterparts, only modified to work with the 'Cover' type.+ , withTests+ , withRetries+ , withDiscards+ , withShrinks+ ) where++import Data.Typeable (Proxy (..))++import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.State (MonadState, StateT (..), modify,+ runStateT)++import Data.Map (Map)+import qualified Data.Map as Map++import Data.Maybe (fromMaybe)++import Data.Text (Text)+import qualified Data.Text as Text++import Hedgehog (evalM)+import Hedgehog.Internal.Property (DiscardLimit,+ PropertyConfig (..),+ PropertyName (..),+ PropertyT (..),+ ShrinkLimit (..), ShrinkRetries,+ TestLimit (..), defaultConfig,+ propertyShrinkLimit,+ propertyTestLimit)+import Hedgehog.Internal.Report (FailureReport (FailureReport, failureShrinks),+ Progress (..), Report (..),+ Result (..), ShrinkCount (..),+ TestCount (..))++import qualified Hedgehog.Internal.Report as Report+import Hedgehog.Internal.Runner (checkReport)+import qualified Hedgehog.Internal.Seed as Seed++-- Hedgehog has the necessary CPP in place to handle older GHCs for these, I see+-- no reason to duplicate their efforts. I'm already depending on internal+-- modules so there is no increase in risk.+import Hedgehog.Internal.Source (HasCallStack,+ withFrozenCallStack)++import Text.PrettyPrint.Annotated.WL (Doc, (<#>), (<+>), (</>))+import qualified Text.PrettyPrint.Annotated.WL as PP++import Text.Printf (printf)++import Test.Tasty.Options+import qualified Test.Tasty.Providers as T++import Test.Tasty.Hedgehog (HedgehogDiscardLimit (..),+ HedgehogReplay (..),+ HedgehogShowReplay (..),+ HedgehogShrinkLimit (..),+ HedgehogShrinkRetries (..),+ HedgehogTestLimit (..))++-- |+-- This is the type used to store the information about the inputs.+newtype Tally = Tally+ { unTally :: Map Text Int+ }+ deriving (Eq, Show)++-- | Gather the property name and the 'Cover' with the property to be tested.+-- Tasty relies on this type+data CoveredProperty = CoveredProperty+ { _coverName :: PropertyName+ , _coverProp :: Cover+ }++-- | Equivalent to the 'Property' type from Hedgehog, but slightly modified for+-- the purpose of enabling the classification functionality.+data Cover = Cover+ { _coverageConf :: !PropertyConfig+ , _coverageProp :: PropertyT (StateT Tally IO) ()+ }++mapPropertyConfig :: (PropertyConfig -> PropertyConfig) -> Cover -> Cover+mapPropertyConfig f cover = cover { _coverageConf = f (_coverageConf cover) }++-- | Set the number of times a property should be executed before it is considered+-- successful.+--+-- If you have a test that does not involve any generators and thus does not+-- need to run repeatedly, you can use @withTests 1@ to define a property that+-- will only be checked once.+--+withTests :: TestLimit -> Cover -> Cover+withTests lim = mapPropertyConfig (\c -> c { propertyTestLimit = lim })++-- | Set the number of times a property is allowed to discard before the test+-- runner gives up.+--+withDiscards :: DiscardLimit -> Cover -> Cover+withDiscards n = mapPropertyConfig $ \c -> c { propertyDiscardLimit = n }++-- | Set the number of times a property is allowed to shrink before the test+-- runner gives up and prints the counterexample.+--+withShrinks :: ShrinkLimit -> Cover -> Cover+withShrinks n = mapPropertyConfig $ \c -> c { propertyShrinkLimit = n }++-- | Set the number of times a property will be executed for each shrink before+-- the test runner gives up and tries a different shrink. See 'ShrinkRetries'+-- for more information.+--+withRetries :: ShrinkRetries -> Cover -> Cover+withRetries n = mapPropertyConfig $ \c -> c { propertyShrinkRetries = n }++-- | Records how many test cases satisfy a given condition.+--+-- @+-- prop_reverse_involutive :: Cover+-- prop_reverse_involutive = withCoverage $ do+-- xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha+-- classify (length xs > 50) "non-trivial"+-- test_involutive reverse xs+-- @+--+-- Which gives output similar to:+--+-- @+-- reverse involutive: OK+-- 18.00% non-trivial+-- @+--+classify+ :: MonadState Tally m+ => Bool -- ^ @True@ if this case should be included.+ -> Text -- ^ The label for this input.+ -> m ()+classify b l = when b $+ modify (Tally . Map.alter (Just . maybe 1 (+1)) l . unTally)++-- | Attach a simple label to a property.+--+-- @+-- prop_reverse_reverse :: Cover+-- prop_reverse_reverse = withCoverage $ do+-- xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha+-- label ("length of input is " ++ show (length xs))+-- reverse (reverse xs) === xs+-- @+--+-- Which gives output similar to:+--+-- @+-- reverse involutive: OK+-- 4.00% with a length of 0+-- 7.00% with a length of 1+-- 3.00% with a length of 11+-- 2.00% with a length of 12+-- 2.00% with a length of 13+-- ...+-- @+--+label+ :: MonadState Tally m+ => Text -- ^ The label for the input.+ -> m ()+label =+ classify True++-- | Uses the input itself as the label, useful for recording test case distribution.+--+-- @+-- prop_reverse_reverse :: Cover+-- prop_reverse_reverse = withCoverage $ do+-- xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha+-- collect (length xs)+-- reverse (reverse xs) === xs+-- @+--+-- Which gives output similar to:+--+-- @+-- reverse involutive: OK+-- 8.00% \"\"+-- 1.00% \"AFkNJBLiWYEBFRyZhulpMkkqIvsDpLAmaYoFTnNNFfkrbPUqDIRUuZOFGohTfB\"+-- 1.00% \"AWWfLCfmZPoydVYXwnFHyCEWztXanEzdoc\"+-- 1.00% \"CJJVBGOeaIkLfcOUGV\"+-- 1.00% \"CNrTsblqfEz\"+-- 1.00% \"CxDqm\"+-- @+--+collect+ :: ( MonadState Tally m+ , Show a+ )+ => a -- ^ The input to collect.+ -> m ()+collect =+ label . Text.pack . show++-- | Simiar to the <https://hackage.haskell.org/package/hedgehog-0.6/docs/Hedgehog.html#v:property property> function in Hedgehog, this creates a 'Cover' that lets us track the required information.+withCoverage+ :: HasCallStack+ => PropertyT (StateT Tally IO) ()+ -> Cover+withCoverage m =+ Cover defaultConfig $ withFrozenCallStack (evalM m)++-- | Create a 'Test.Tasty.Providers.TestTree' using a 'Cover' property test.+testPropertyCoverage+ :: T.TestName+ -> Cover+ -> T.TestTree+testPropertyCoverage name cov =+ T.singleTest name (CoveredProperty (PropertyName name) cov)++ratio :: Integral n => n -> Int -> Double+ratio x y = fromIntegral x / fromIntegral y++prettyTally+ :: PropertyConfig+ -> Report Result+ -> Tally+ -> Doc a+prettyTally _config report (Tally tally) =+ let+ TestCount testCount = reportTests report++ shrinkCount = case reportStatus report of+ -- Account for the failed test that might have included our classified case,+ -- otherwise numbers are skewed. I am not convinced this is correct though.+ Failed FailureReport {failureShrinks = ShrinkCount n} -> 1 + n+ -- We haven't had to shrink so there were no test failures so our+ -- testCount is indicative of the total number of tests that were run.+ _ -> 0++ ntests = shrinkCount + testCount++ ppTally (l,t) =+ PP.text (printf "%.2f%%" (100.0 * ratio t ntests)) <+>+ PP.text (Text.unpack l)+ in+ PP.vsep $ ppTally <$> Map.toList tally++reportToProgress+ :: PropertyConfig+ -> Report Progress+ -> T.Progress+reportToProgress config (Report testsDone _ status) =+ let+ TestLimit testLimit = propertyTestLimit config+ ShrinkLimit shrinkLimit = propertyShrinkLimit config++ ratio'd :: Integral n => n -> Int -> Float+ ratio'd x y = 1.0 * realToFrac (ratio x y)+ in+ case status of+ Running -> T.Progress "Running" (ratio'd testsDone testLimit)+ Shrinking fr -> T.Progress "Shrinking" (ratio'd (Report.failureShrinks fr) shrinkLimit)++reportOutput+ :: PropertyConfig+ -> Bool+ -> String+ -> Tally+ -> Report Result+ -> IO String+reportOutput config showReplay name tally report@(Report _ _ status) = do+ rpt <- Report.ppResult (Just (PropertyName name)) report++ let+ toStr = PP.display . PP.renderPrettyDefault+ tal = prettyTally config report tally++ pure $ case status of+ Failed fr -> do+ let+ size = PP.text . show $ Report.failureSize fr+ seed = PP.text . show $ Report.failureSeed fr++ replayStr = if showReplay+ then PP.text "Use"+ <+> PP.squotes ("--hedgehog-replay" <+> PP.dquotes (size <+> seed))+ <+> "to reproduce"+ else mempty++ toStr $ PP.align tal </> PP.line <#> rpt <#> replayStr++ GaveUp -> "Gave up"+ OK -> toStr tal++instance T.IsTest CoveredProperty where+ testOptions =+ return [ Option (Proxy :: Proxy HedgehogReplay)+ , Option (Proxy :: Proxy HedgehogShowReplay)+ , Option (Proxy :: Proxy HedgehogTestLimit)+ , Option (Proxy :: Proxy HedgehogDiscardLimit)+ , Option (Proxy :: Proxy HedgehogShrinkLimit)+ , Option (Proxy :: Proxy HedgehogShrinkRetries)+ ]++ run opts (CoveredProperty name (Cover conf prop)) yieldProgress = do+ let+ HedgehogReplay replay = lookupOption opts+ HedgehogShowReplay showReplay = lookupOption opts+ HedgehogTestLimit mTests = lookupOption opts+ HedgehogDiscardLimit mDiscards = lookupOption opts+ HedgehogShrinkLimit mShrinks = lookupOption opts+ HedgehogShrinkRetries mRetries = lookupOption opts++ config =+ PropertyConfig+ (fromMaybe (propertyTestLimit conf) mTests)+ (fromMaybe (propertyDiscardLimit conf) mDiscards)+ (fromMaybe (propertyShrinkLimit conf) mShrinks)+ (fromMaybe (propertyShrinkRetries conf) mRetries)++ randSeed <- Seed.random++ let+ size = maybe 0 fst replay+ seed = maybe randSeed snd replay++ runProp = checkReport config size seed prop+ (liftIO . yieldProgress . reportToProgress config)++ (rresult, tally) <- runStateT runProp (Tally mempty)++ let+ resultFn = if reportStatus rresult == OK+ then T.testPassed+ else T.testFailed++ out <- reportOutput config showReplay (unPropertyName name) tally rresult+ return $ resultFn out
+ tasty-hedgehog-coverage.cabal view
@@ -0,0 +1,58 @@+-- Initial tasty-hedgehog-coverage.cabal generated by cabal init. For +-- further documentation, see http://haskell.org/cabal/users-guide/++name: tasty-hedgehog-coverage+version: 0.1.0.0+synopsis: Coverage tracking for Hedgehog Property-Based Testing via Tasty.+description: Integrates with the Tasty testing suite and Hedgehog property-based testing and allows you to keep a tally of the inputs that meet certain criteria. Providing the summary on test completion.+license: BSD3+license-file: LICENCE+author: QFPL @ Data61+maintainer: sean.chalmers@data61.csiro.au+copyright: Copyright (C) 2017 Commonwealth Scientific and Industrial Research Organisation (CSIRO)+category: Testing+build-type: Simple+extra-source-files: changelog.md+cabal-version: >=1.10++tested-with: GHC == 7.10.3+ , GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.1++source-repository head+ type: git+ location: git@github.com:qfpl/tasty-hedgehog-coverage.git++library+ exposed-modules: Test.Tasty.Hedgehog.Coverage++ build-depends: base >= 4.8 && < 4.12+ , tagged >= 0.8 && < 0.9+ , tasty >= 0.11 && < 1.2+ , tasty-hedgehog >= 0.2 && < 0.3+ , hedgehog >= 0.5 && < 0.7+ , wl-pprint-annotated >= 0.1 && < 0.2+ , mtl >= 2.2 && < 3+ , transformers >= 0.4 && < 0.6+ , text >= 1.2 && < 1.3+ , containers >= 0.5 && < 0.7++ hs-source-dirs: src++ ghc-options: -Wall++ default-language: Haskell2010++test-suite tasty-hedgehog-coverage-tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test+ build-depends: base >= 4.8 && <4.12+ , tasty >= 0.11 && < 1.2+ , tasty-expected-failure >= 0.11 && < 0.12+ , hedgehog >= 0.5 && < 0.7+ , tasty-hedgehog-coverage++ ghc-options: -Wall+ default-language: Haskell2010
+ test/Main.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Hedgehog hiding (withTests)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Test.Tasty+import Test.Tasty.ExpectedFailure+import Test.Tasty.Hedgehog.Coverage++genAlphaList :: Gen String+genAlphaList =+ Gen.list (Range.linear 0 100) Gen.alpha++test_involutive :: (MonadTest m, Eq a, Show a) => (a -> a) -> a -> m ()+test_involutive f x =+ f (f x) === x++prop_reverse_involutive :: Cover+prop_reverse_involutive = withTests 500 . withCoverage $ do+ xs <- forAll genAlphaList+ classify (length xs > 50) "non-trivial"+ test_involutive reverse xs++badReverse :: [a] -> [a]+badReverse [] = []+badReverse [_] = []+badReverse as = reverse as++prop_badReverse_involutive :: Cover+prop_badReverse_involutive = withCoverage $ do+ xs <- forAll genAlphaList+ classify (length xs < 10) "trivial"+ classify (length xs > 10) "non-trivial"+ test_involutive badReverse xs++main :: IO ()+main = defaultMain $+ testGroup "tasty-hedgehog-coverage tests"+ [ testPropertyCoverage+ "reverse involutive"+ prop_reverse_involutive+ , expectFail $ testPropertyCoverage+ "badReverse involutive fails"+ prop_badReverse_involutive+ ]