diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## v0.2.0 + +* Move setting properties to `Skeletest.Prop` +* Add coverage functions for property tests + ## v0.1.1 * Support Diff-1.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -277,6 +277,7 @@ Property tests are written with `prop` and run in the `PropertyM` monad (`Property` is an alias for `PropertyM ()`). To write property tests, add the following imports: ```haskell +import qualified Skeletest.Prop as Prop import qualified Skeletest.Prop.Gen as Gen import qualified Skeletest.Prop.Range as Range ``` @@ -309,27 +310,27 @@ Property tests can also be configured with the following functions. These must be called at the very beginning of the test, before any `forAll` calls. Values specified with CLI flags take precedence over the values in the code. -* `setDiscardLimit` +* `Prop.setDiscardLimit` * The max number of values to discard before reporting a failure * Default: `100` -* `setShrinkLimit` +* `Prop.setShrinkLimit` * The max number of shrinks before giving up * Default: `1000` -* `setShrinkRetries` +* `Prop.setShrinkRetries` * The number of times to re-run a test during shrinking. This is useful if you are testing something which fails non-deterministically and you want to increase the change of getting a good shrink. e.g. `10` means a test must pass 10 times before trying a different shrink * Default: `0` -* `setConfidence` +* `Prop.setConfidence` * The acceptable occurrence of false positives. e.g. `10^9` means accepting a false positive for 1 in 10^9 tests * Default: don't check confidence -* `setVerifiedTermination` +* `Prop.setVerifiedTermination` * Validate confidence is reached * Default: disabled -* `setTestLimit` +* `Prop.setTestLimit` * The number of tests to run before reporting success * Default: `100` * CLI flag: `--prop-test-limit` diff --git a/skeletest.cabal b/skeletest.cabal --- a/skeletest.cabal +++ b/skeletest.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: skeletest -version: 0.1.1 +version: 0.2.0 synopsis: Batteries-included, opinionated test framework description: Batteries-included, opinionated test framework. See README.md for more details. homepage: https://github.com/brandonchinn178/skeletest#readme @@ -57,6 +57,7 @@ Skeletest.Main Skeletest.Plugin Skeletest.Predicate + Skeletest.Prop Skeletest.Prop.Gen Skeletest.Prop.Internal Skeletest.Prop.Range @@ -73,7 +74,8 @@ base < 5 , aeson , aeson-pretty - , ansi-terminal >= 0.4.0 + , ansi-terminal >= 0.7.0 + , colour , containers , Diff >= 1.0 , directory diff --git a/src/Skeletest.hs b/src/Skeletest.hs --- a/src/Skeletest.hs +++ b/src/Skeletest.hs @@ -33,14 +33,6 @@ forAll, discard, - -- ** Settings - setDiscardLimit, - setShrinkLimit, - setShrinkRetries, - setConfidence, - setVerifiedTermination, - setTestLimit, - -- * Fixtures Fixture (..), FixtureScope (..), diff --git a/src/Skeletest/Assertions.hs b/src/Skeletest/Assertions.hs --- a/src/Skeletest/Assertions.hs +++ b/src/Skeletest/Assertions.hs @@ -31,10 +31,15 @@ ) import Skeletest.Internal.Predicate qualified as P import Skeletest.Internal.TestInfo (getTestInfo) -import Skeletest.Internal.TestRunner (AssertionFail (..), FailContext, Testable (..)) +import Skeletest.Internal.TestRunner ( + AssertionFail (..), + FailContext, + Testable (..), + testResultPass, + ) instance Testable IO where - runTestable = id + runTestable m = m >> pure testResultPass context = contextIO throwFailure = throwIO diff --git a/src/Skeletest/Internal/Spec.hs b/src/Skeletest/Internal/Spec.hs --- a/src/Skeletest/Internal/Spec.hs +++ b/src/Skeletest/Internal/Spec.hs @@ -62,7 +62,6 @@ TestResultMessage (..), testResultFromAssertionFail, testResultFromError, - testResultPass, ) import Skeletest.Internal.TestTargets (TestTarget, TestTargets, matchesTest) import Skeletest.Internal.TestTargets qualified as TestTargets @@ -96,7 +95,7 @@ -- will contain -- -- >>> SpecTest { testMarkers = [MarkerA, MarkerB] } - , testAction :: IO () + , testAction :: IO TestResult } -- | Traverse the tree with the given processing function. @@ -190,7 +189,7 @@ runTest info action = hookRunTest info $ do try action >>= \case - Right () -> pure testResultPass + Right result -> pure result Left e | Just e' <- fromException e -> testResultFromAssertionFail e' | otherwise -> pure $ testResultFromError e diff --git a/src/Skeletest/Internal/TestRunner.hs b/src/Skeletest/Internal/TestRunner.hs --- a/src/Skeletest/Internal/TestRunner.hs +++ b/src/Skeletest/Internal/TestRunner.hs @@ -40,7 +40,7 @@ {----- Testable -----} class (MonadIO m) => Testable m where - runTestable :: m () -> IO () + runTestable :: m () -> IO TestResult context :: String -> m a -> m a throwFailure :: AssertionFail -> m a diff --git a/src/Skeletest/Internal/Utils/Color.hs b/src/Skeletest/Internal/Utils/Color.hs --- a/src/Skeletest/Internal/Utils/Color.hs +++ b/src/Skeletest/Internal/Utils/Color.hs @@ -2,8 +2,10 @@ green, red, yellow, + gray, ) where +import Data.Colour.Names qualified as Color import Data.Text (Text) import Data.Text qualified as Text import System.Console.ANSI qualified as ANSI @@ -19,3 +21,6 @@ yellow :: Text -> Text yellow = withANSI [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Yellow] + +gray :: Text -> Text +gray = withANSI [ANSI.SetRGBColor ANSI.Foreground Color.gray] diff --git a/src/Skeletest/Prop.hs b/src/Skeletest/Prop.hs new file mode 100644 --- /dev/null +++ b/src/Skeletest/Prop.hs @@ -0,0 +1,17 @@ +module Skeletest.Prop ( + -- * Settings + setDiscardLimit, + setShrinkLimit, + setShrinkRetries, + setConfidence, + setVerifiedTermination, + setTestLimit, + + -- * Coverage + classify, + cover, + label, + collect, +) where + +import Skeletest.Prop.Internal diff --git a/src/Skeletest/Prop/Internal.hs b/src/Skeletest/Prop/Internal.hs --- a/src/Skeletest/Prop/Internal.hs +++ b/src/Skeletest/Prop/Internal.hs @@ -19,6 +19,12 @@ setVerifiedTermination, setTestLimit, + -- * Coverage + classify, + cover, + label, + collect, + -- * CLI flags PropSeedFlag, PropLimitFlag, @@ -29,6 +35,7 @@ import Control.Monad.Trans.Class qualified as Trans import Control.Monad.Trans.Reader qualified as Trans import Data.List qualified as List +import Data.Map qualified as Map import Data.Maybe (catMaybes) import Data.Text qualified as Text import GHC.Stack qualified as GHC @@ -48,11 +55,18 @@ import Skeletest.Internal.CLI (FlagSpec (..), IsFlag (..), getFlag) import Skeletest.Internal.TestInfo (getTestInfo) -import Skeletest.Internal.TestRunner (AssertionFail (..), Testable (..)) +import Skeletest.Internal.TestRunner ( + AssertionFail (..), + TestResult (..), + TestResultMessage (..), + Testable (..), + testResultPass, + ) +import Skeletest.Internal.Utils.Color qualified as Color -- | A property to run, with optional configuration settings specified up front. -- --- Settings should be specified before any 'forAll' or IO calls; any settings +-- Settings should be specified before any other 'Property' calls; any settings -- specified afterwards are ignored. type Property = PropertyM () @@ -146,7 +160,7 @@ Hedgehog.EarlyTermination c _ -> Hedgehog.EarlyTermination c (Hedgehog.TestLimit x) } -runProperty :: Property -> IO () +runProperty :: Property -> IO TestResult runProperty = \case PropertyPure cfg () -> runProperty $ PropertyIO cfg (pure ()) PropertyIO cfg m -> do @@ -163,12 +177,18 @@ let Hedgehog.TestCount testCount = Hedgehog.reportTests report Hedgehog.DiscardCount discards = Hedgehog.reportDiscards report + Hedgehog.Coverage coverage = Hedgehog.reportCoverage report case Hedgehog.reportStatus report of Hedgehog.OK -> - -- TODO: show details - -- https://github.com/brandonchinn178/skeletest/issues/19 - pure () + pure + testResultPass + { testResultMessage = + TestResultMessageInline . Color.gray . Text.pack . List.intercalate "\n" . concat $ + [ [show testCount <> " tests, " <> show discards <> " discards"] + , renderCoverage coverage testCount + ] + } Hedgehog.GaveUp -> do testInfo <- getTestInfo throwIO @@ -224,7 +244,45 @@ } where reportProgress _ = pure () - renderSeed Hedgehog.Report{reportSeed = Hedgehog.Seed value gamma} = show value <> ":" <> show gamma + renderSeed report = + let Hedgehog.Seed value gamma = Hedgehog.reportSeed report + in show value <> ":" <> show gamma + renderCoverage coverage testCount = + let columns = + [ (name, percentStr, percentBar) + | Hedgehog.MkLabel{..} <- List.sortOn Hedgehog.labelLocation $ Map.elems coverage + , let + Hedgehog.LabelName name = labelName + Hedgehog.CoverCount count = labelAnnotation + percent = round $ fromIntegral count / fromIntegral testCount * (100 :: Double) + percentStr = show percent <> "%" + percentBar = renderPercentBar percent + ] + (maxNameLen, maxPercentLen) = + foldr + ( \(name, percent, _) (nameAcc, percentAcc) -> + (max (length name) nameAcc, max (length percent) percentAcc) + ) + (0, 0) + columns + in [ rjust maxNameLen name <> " " <> rjust maxPercentLen percentStr <> " " <> percentBar + | (name, percentStr, percentBar) <- columns + ] + rjust n s = replicate (n - length s) ' ' <> s + renderPercentBar percent = + -- render percentage bar 20 characters wide + let (n, r) = percent `divMod` 5 + in concat + [ replicate n '█' + , case r of + 0 -> "" + 1 -> "▏" + 2 -> "▍" + 3 -> "▌" + 4 -> "▊" + _ -> "" -- unreachable + , replicate (20 - n - (if r == 0 then 0 else 1)) '·' + ] toCallStack mSpan = GHC.fromCallSiteList $ case mSpan of @@ -281,6 +339,41 @@ setTestLimit :: Int -> Property setTestLimit = propConfig . SetTestLimit + +{----- Coverage -----} + +-- | Record the propotion of tests which satisfy a given condition +-- +-- @ +-- xs <- forAll $ Gen.list (Range.linear 0 100) $ Gen.int (Range.linear 0 100) +-- for_ xs $ \x -> do +-- classify "newborns" $ x == 0 +-- classify "children" $ x > 0 && x < 13 +-- classify "teens" $ x > 12 && x < 20 +-- @ +classify :: (GHC.HasCallStack) => String -> Bool -> Property +classify l cond = GHC.withFrozenCallStack $ propM $ Hedgehog.classify (Hedgehog.LabelName l) cond + +-- | Require a certain percentage of the tests to be covered by the classifier. +-- +-- In the following example, if the condition does not have at least 30% +-- coverage, the test will fail. +-- @ +-- match <- forAll Gen.bool +-- cover 30 "True" $ match +-- cover 30 "False" $ not match +-- @ +cover :: (GHC.HasCallStack) => Double -> String -> Bool -> Property +cover p l cond = GHC.withFrozenCallStack $ propM $ Hedgehog.cover (Hedgehog.CoverPercentage p) (Hedgehog.LabelName l) cond + +-- | Add a label for each test run. It produces a table showing the percentage +-- of test runs that produced each label. +label :: (GHC.HasCallStack) => String -> Property +label l = GHC.withFrozenCallStack $ propM $ Hedgehog.label (Hedgehog.LabelName l) + +-- | Like 'label', but uses 'Show' to render its argument for display. +collect :: (Show a, GHC.HasCallStack) => a -> Property +collect a = GHC.withFrozenCallStack $ propM $ Hedgehog.collect a {----- CLI flags -----} diff --git a/test/ExampleSpec.hs b/test/ExampleSpec.hs --- a/test/ExampleSpec.hs +++ b/test/ExampleSpec.hs @@ -7,6 +7,7 @@ import Skeletest import Skeletest.Predicate qualified as P +import Skeletest.Prop qualified as Prop import Skeletest.Prop.Gen qualified as Gen import Skeletest.Prop.Range qualified as Range @@ -56,6 +57,9 @@ forAll $ Gen.list (Range.linear 0 10) $ Gen.string (Range.linear 0 100) Gen.unicode + Prop.label $ show $ length input + Prop.classify "even" $ even $ length input + Prop.classify "odd" $ odd $ length input length (reverse input) `shouldBe` length input prop "read . show === id" $ diff --git a/test/Skeletest/PropSpec.hs b/test/Skeletest/PropSpec.hs --- a/test/Skeletest/PropSpec.hs +++ b/test/Skeletest/PropSpec.hs @@ -16,9 +16,10 @@ [ "module ExampleSpec (spec) where" , "" , "import Skeletest" + , "import qualified Skeletest.Prop as Prop" , "" , "spec = prop \"discards\" $ do" - , " setDiscardLimit 10" + , " Prop.setDiscardLimit 10" , " discard" ]