diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,32 @@ # Changelog for hspec-hedgehog +## 0.3.0.0 + +- [#45](https://github.com/hspec/hspec-hedgehog/pull/45) @ChickenProp + - Set `propertyDiscardLimit` correctly. +- [#44](https://github.com/hspec/hspec-hedgehog/pull/44) @ChickenProp + - Don't re-export `modifyMaxSize`, which is a no-op. + +## 0.2.0.0 + - [#29](https://github.com/parsonsmatt/hspec-hedgehog/pull/29) @sol + - Show less context on failure. + +## 0.1.1.0 +- [#30](https://github.com/parsonsmatt/hspec-hedgehog/pull/30) @sol + - Show classification on success + - Provide more information on "gave up" + +## 0.1.0.0 + +- [#25](https://github.com/parsonsmatt/hspec-hedgehog/pull/25) @sol + - Suppress internal source locations. +- [#24](https://github.com/parsonsmatt/hspec-hedgehog/pull/24) @sol + - Regard `--color` / `--no-color`. +- [#23](https://github.com/parsonsmatt/hspec-hedgehog/pull/23) @ocharles + - Improve type inference by constraining the base monad of `PropertyT` to + `IO`. This makes explicitly using `hedgehog` redundant in many + situations. + ## 0.0.1.2 - [#7](https://github.com/parsonsmatt/hspec-hedgehog/pull/7) @parsonsmatt diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,5 @@ # hspec-hedgehog -[![Build Status](https://travis-ci.org/parsonsmatt/hspec-hedgehog.svg?branch=master)](https://travis-ci.org/parsonsmatt/hspec-hedgehog) - An integration library for [hspec](https://hackage.haskell.org/package/hspec) and [hedgehog](https://hackage.haskell.org/package/hedgehog). Example: diff --git a/hspec-hedgehog.cabal b/hspec-hedgehog.cabal --- a/hspec-hedgehog.cabal +++ b/hspec-hedgehog.cabal @@ -1,11 +1,16 @@ cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + name: hspec-hedgehog -version: 0.0.1.2 -description: Please see the README on GitHub at +version: 0.3.0.0 +description: Please see the README on GitHub at synopsis: Integrate Hedgehog and Hspec! category: Testing -homepage: https://github.com/parsonsmatt/hspec-hedgehog#readme -bug-reports: https://github.com/parsonsmatt/hspec-hedgehog/issues +homepage: https://github.com/hspec/hspec-hedgehog#readme +bug-reports: https://github.com/hspec/hspec-hedgehog/issues author: Matt Parsons maintainer: parsonsmatt@gmail.com copyright: 2020 Matt Parsons @@ -18,7 +23,7 @@ source-repository head type: git - location: https://github.com/parsonsmatt/hspec-hedgehog + location: https://github.com/hspec/hspec-hedgehog library exposed-modules: @@ -26,25 +31,30 @@ hs-source-dirs: src build-depends: - base >= 4.7 && < 5 - , hspec >= 2.4.4 && < 3 - , hspec-core >= 2.4.4 && < 3 - , hedgehog >= 1.0.2 && < 2 - , HUnit >= 1.5 && < 2 - , QuickCheck >= 2.9.2 && < 3 - , splitmix >= 0.0.1 && < 1 + QuickCheck >=2.9.2 && <3 + , base >=4.7 && <5 + , hedgehog >=1.5 + , hspec >=2.11.0 && <3 + , hspec-core >=2.11.0 && <3 + , splitmix >=0.0.1 && <1 default-language: Haskell2010 -test-suite hspec-hedgehog-test +test-suite spec type: exitcode-stdio-1.0 - main-is: - Spec.hs + main-is: Spec.hs + other-modules: + ExampleSpec + Test.Hspec.HedgehogSpec hs-source-dirs: test - ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + hspec-discover:hspec-discover build-depends: - base >= 4.7 && < 5 + HUnit + , QuickCheck + , base >=4.7 && <5 + , hedgehog >=1.5 + , hspec >=2.11.0 && <3 + , hspec-core >=2.11.0 && <3 , hspec-hedgehog - , hspec - , hedgehog >= 1.0.2 && < 2 default-language: Haskell2010 diff --git a/src/Test/Hspec/Hedgehog.hs b/src/Test/Hspec/Hedgehog.hs --- a/src/Test/Hspec/Hedgehog.hs +++ b/src/Test/Hspec/Hedgehog.hs @@ -1,11 +1,13 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -82,26 +84,30 @@ ( -- * The Main Function hedgehog -- * Hspec re-exports + -- + -- | 'Test.Hspec.QuickCheck.modifyMaxSize' isn't re-exported, since + -- hedgehog has nothing that corresponds to it. , modifyArgs , modifyMaxSuccess , modifyMaxDiscardRatio - , modifyMaxSize , modifyMaxShrinks -- * Hedgehog Re-exports , module Hedgehog ) where import Control.Monad.IO.Class (liftIO) +import Data.Char (isSpace) import Data.Coerce (coerce) import Data.IORef (newIORef, readIORef, writeIORef) +import GHC.Stack (withFrozenCallStack) import Hedgehog -import Hedgehog.Internal.Config (detectColor) +import Hedgehog.Internal.Config (UseColor(..)) import Hedgehog.Internal.Property (DiscardLimit (..), Property (..), PropertyConfig (..), ShrinkLimit (..), TerminationCriteria (..), TestCount (..), TestLimit (..)) -import Hedgehog.Internal.Report as Hedge +import Hedgehog.Internal.Report hiding (renderResult) import Hedgehog.Internal.Runner (checkReport) import qualified Hedgehog.Internal.Seed as Seed import Hedgehog.Internal.Source (ColumnNo (..), LineNo (..), @@ -110,9 +116,7 @@ import Test.Hspec import Test.Hspec.Core.Spec as Hspec import Test.Hspec.QuickCheck (modifyArgs, modifyMaxDiscardRatio, - modifyMaxShrinks, modifyMaxSize, - modifyMaxSuccess) -import Test.HUnit.Base (assertFailure) + modifyMaxShrinks, modifyMaxSuccess) import Test.QuickCheck.Random (QCGen (..)) import Test.QuickCheck.Test (Args (..)) @@ -142,10 +146,13 @@ -- of 'Example' for a function for more details. -- -- @since 0.0.0.0 -instance Example (PropertyT IO ()) where - type Arg (PropertyT IO ()) = () +instance m ~ IO => Example (PropertyT m ()) where + type Arg (PropertyT m ()) = () evaluateExample e = evaluateExample (\() -> e) +propertyWithoutCallStack :: PropertyT IO () -> Property +propertyWithoutCallStack = withFrozenCallStack property + -- | Warning: orphan instance! This instance is used to embed a "Hedgehog" -- property seamlessly into the @hspec@ framework. -- @@ -155,13 +162,12 @@ -- Hedgehog tests. -- -- @since 0.0.0.0 -instance Example (a -> PropertyT IO ()) where - type Arg (a -> PropertyT IO ()) = a +instance (m ~ IO) => Example (a -> PropertyT m ()) where + type Arg (a -> PropertyT m ()) = a - evaluateExample (fmap property -> aprop) params aroundAction progressCallback = do + evaluateExample (fmap propertyWithoutCallStack -> aprop) params aroundAction progressCallback = do ref <- newIORef (Result "" (Pending Nothing Nothing)) aroundAction $ \a -> do - color <- detectColor let size = 0 prop = aprop a propConfig = useQuickCheckArgs (propertyConfig prop) @@ -179,7 +185,7 @@ NoConfidenceTermination (TestLimit _) -> NoConfidenceTermination (TestLimit maxTests) , propertyDiscardLimit = - DiscardLimit $ maxDiscardRatio qcArgs + DiscardLimit $ maxDiscardRatio qcArgs * maxTests , propertyShrinkLimit = ShrinkLimit $ maxShrinks qcArgs } @@ -197,9 +203,19 @@ Nothing -> Seed.random Just (rng, _) -> pure (uncurry Seed (unseedSMGen (coerce rng))) hedgeResult <- checkReport propConfig size seed (propertyTest prop) cb - ppresult <- renderResult color Nothing hedgeResult - writeIORef ref $ Result "" $ case reportStatus hedgeResult of - Failed FailureReport{..} -> + + let + config = defaultConfig { + configContext = Context 3 + , configPrintFailedAtLocation = False + , configPrintReproduceMessage = False + , configPrintPrefixIcons = DisablePrefixIcons + } + renderResult color = unlines . unindent . lines . dropWhileEnd isSpace <$> renderResultWith config color (Just "") hedgeResult + + case reportStatus hedgeResult of + Failed FailureReport{..} -> do + ppresult <- renderResult EnableColor let fromSpan Span{..} = Location @@ -207,10 +223,19 @@ , locationLine = coerce spanStartLine , locationColumn = coerce spanStartColumn } - in - Hspec.Failure (fromSpan <$> failureLocation) $ Reason ppresult - GaveUp -> - Failure Nothing (Reason "GaveUp") - OK -> - Success + writeIORef ref $ Result "" $ Hspec.Failure (fromSpan <$> failureLocation) $ ColorizedReason ppresult + GaveUp -> do + ppresult <- renderResult DisableColor + writeIORef ref $ Result "" $ Failure Nothing (Reason ppresult) + OK -> do + ppresult <- renderResult DisableColor + writeIORef ref $ Result ppresult Success readIORef ref + +dropWhileEnd :: (a -> Bool) -> [a] -> [a] +dropWhileEnd p = reverse . dropWhile p . reverse + +unindent :: [String] -> [String] +unindent xs = map (drop indentation) xs + where + indentation = minimum $ map (length . takeWhile (== ' ')) xs diff --git a/test/ExampleSpec.hs b/test/ExampleSpec.hs new file mode 100644 --- /dev/null +++ b/test/ExampleSpec.hs @@ -0,0 +1,59 @@ +module ExampleSpec (spec) where +import Test.Hspec +import Control.Concurrent (threadDelay) +import Control.Monad.IO.Class (liftIO) +import Data.IORef (atomicModifyIORef', readIORef, newIORef) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Hspec.Hedgehog (PropertyT, diff, forAll, hedgehog, + (/==), (===)) +import Test.Hspec.QuickCheck (modifyMaxSuccess) + +spec :: Spec +spec = do + describe "regular tests" $ do + it "works" $ do + True `shouldBe` True + + describe "hedgehog" $ do + it "is useful if you get an ambiguous error" $ hedgehog $ do + "no ambiguity" === "no ambiguity" + + describe "hedgehog tests" $ do + it "lets you use PropertyT directly" $ hedgehog $ do + x <- forAll $ Gen.integral (Range.linear 0 1000) + y <- forAll $ Gen.integral (Range.linear 0 5000) + diff (x + y) (>=) (x :: Integer) + + it "lets you use PropertyT directly without forcing the type" $ do + x <- forAll $ Gen.integral (Range.linear 0 1000) + y <- forAll $ Gen.integral (Range.linear 0 5000) + diff (x + y) (>=) (x :: Integer) + + it "renders a progress bit" $ hedgehog $ do + x <- forAll $ Gen.integral (Range.linear 0 1000) + y <- forAll $ Gen.integral (Range.linear 1 5000) + liftIO $ threadDelay (100 * x + y) + + describe "with hooks" $ do + before (pure "Hello!") $ do + it "has functions" $ \str -> hedgehog $ + str === "Hello!" + + it "goes before or after" $ \str -> do + pure () :: PropertyT IO () + str === "Hello!" + + it "generates" $ \str -> hedgehog $ do + wrongLen <- forAll $ Gen.integral (Range.linear 0 3) + length str /== wrongLen + + describe "modifyMaxSuccess" $ do + modifyMaxSuccess (\_ -> 10) $ do + beforeAll (newIORef (0 :: Integer)) $ do + it "counts to 10" $ \ref -> hedgehog $ do + liftIO $ atomicModifyIORef' ref (\a -> (a + 1, ())) + True === True + it "works" $ \ref -> do + val <- readIORef ref + val `shouldBe` 10 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,53 +1,1 @@ -import Control.Concurrent (threadDelay) -import Control.Monad.IO.Class (liftIO) -import Data.IORef (atomicModifyIORef', readIORef, newIORef) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range -import Test.Hspec (before, beforeAll, describe, hspec, it, shouldBe) -import Test.Hspec.Hedgehog (PropertyT, diff, forAll, hedgehog, - (/==), (===)) -import Test.Hspec.QuickCheck (modifyMaxSuccess) - -main :: IO () -main = hspec $ do - describe "regular tests" $ do - it "works" $ do - True `shouldBe` True - - describe "hedgehog" $ do - it "is useful if you get an ambiguous error" $ hedgehog $ do - "no ambiguity" === "no ambiguity" - - describe "hedgehog tests" $ do - it "lets you use PropertyT directly" $ hedgehog $ do - x <- forAll $ Gen.integral (Range.linear 0 1000) - y <- forAll $ Gen.integral (Range.linear 0 5000) - diff (x + y) (>=) (x :: Integer) - - it "renders a progress bit" $ hedgehog $ do - x <- forAll $ Gen.integral (Range.linear 0 1000) - y <- forAll $ Gen.integral (Range.linear 1 5000) - liftIO $ threadDelay (100 * x + y) - - describe "with hooks" $ do - before (pure "Hello!") $ do - it "has functions" $ \str -> hedgehog $ - str === "Hello!" - - it "goes before or after" $ \str -> do - pure () :: PropertyT IO () - str === "Hello!" - - it "generates" $ \str -> hedgehog $ do - wrongLen <- forAll $ Gen.integral (Range.linear 0 3) - length str /== wrongLen - - describe "modifyMaxSuccess" $ do - modifyMaxSuccess (\_ -> 10) $ do - beforeAll (newIORef (0 :: Integer)) $ do - it "counts to 10" $ \ref -> hedgehog $ do - liftIO $ atomicModifyIORef' ref (\a -> (a + 1, ())) - True === True - it "works" $ \ref -> do - val <- readIORef ref - val `shouldBe` 10 +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Test/Hspec/HedgehogSpec.hs b/test/Test/Hspec/HedgehogSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/HedgehogSpec.hs @@ -0,0 +1,86 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +module Test.Hspec.HedgehogSpec (spec) where + +import Test.Hspec +import Test.Hspec.Core.Spec +import Test.Hspec.Core.Util (formatException, stripAnsi) + +import Data.List +import Control.Exception + +import qualified Test.HUnit.Lang as HUnit +import Test.QuickCheck (stdArgs, replay) +import Test.QuickCheck.Random (mkQCGen) + +import Test.Hspec.Hedgehog hiding (eval) + +deriving instance Eq Result +deriving instance Eq ResultStatus +deriving instance Eq FailureReason + +instance Eq SomeException where + (==) = exceptionEq + +exceptionEq :: SomeException -> SomeException -> Bool +exceptionEq a b + | Just ea <- fromException a, Just eb <- fromException b = ea == (eb :: ErrorCall) + | Just ea <- fromException a, Just eb <- fromException b = ea == (eb :: ArithException) + | otherwise = throw (HUnit.HUnitFailure Nothing $ HUnit.ExpectedButGot Nothing (formatException b) (formatException a)) + +progressCallback :: ProgressCallback +progressCallback _ = return () + +params :: Params +params = defaultParams {paramsQuickCheckArgs = stdArgs {replay = Just (mkQCGen 23, 0)}} + +joinLines :: [String] -> String +joinLines = intercalate "\n" + +failingProperty :: PropertyT IO () +failingProperty = failure + +failingPropertyLine :: Int +failingPropertyLine = __LINE__ - 3 + +spec :: Spec +spec = do + describe "evaluateExample" $ do + let + eval :: PropertyT IO () -> IO Result + eval p = evaluateExample p params ($ ()) progressCallback + + context "on Success" $ do + it "includes the number of passed tests" $ do + eval success `shouldReturn` Result + "passed 100 tests.\n" + Success + + it "includes classification" $ do + eval (label "foo" >> success) `shouldReturn` Result (joinLines [ + "passed 100 tests." + , "foo 100% ████████████████████\n" + ]) Success + + context "on Failure" $ do + it "includes the number of discarded tests" $ do + eval discard `shouldReturn` Result "" (Failure Nothing (Reason + "gave up after 1000 discards, passed 0 tests.\n" + )) + + it "provides a detailed failure message" $ do + Result "" (Failure (Just _loc) (ColorizedReason reason)) <- eval failingProperty + let line delta = "" <> show (failingPropertyLine + delta) + stripAnsi reason `shouldBe` joinLines [ + "failed after 1 test." + , "shrink path: 1:" + , "" + , " ┏━━ test/Test/Hspec/HedgehogSpec.hs ━━━" + , line -1 <> " ┃ failingProperty :: PropertyT IO ()" + , line 0 <> " ┃ failingProperty = failure" + , " ┃ ^^^^^^^^^^^^^^^^^^^^^^^^^" + , "" + ]