diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for hspec-hedgehog +## 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 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.1.1.0 -description: Please see the README on GitHub at +version: 0.2.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,24 +31,31 @@ hs-source-dirs: src build-depends: - base >= 4.7 && < 5 - , hspec >= 2.11.0 && < 3 - , hspec-core >= 2.11.0 && < 3 - , hedgehog >= 1.0.2 && < 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 @@ -94,6 +94,7 @@ ) 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) @@ -105,7 +106,6 @@ TerminationCriteria (..), TestCount (..), TestLimit (..)) import Hedgehog.Internal.Report hiding (renderResult) -import qualified Hedgehog.Internal.Report as Hedge import Hedgehog.Internal.Runner (checkReport) import qualified Hedgehog.Internal.Seed as Seed import Hedgehog.Internal.Source (ColumnNo (..), LineNo (..), @@ -203,7 +203,14 @@ Just (rng, _) -> pure (uncurry Seed (unseedSMGen (coerce rng))) hedgeResult <- checkReport propConfig size seed (propertyTest prop) cb - let renderResult color = Hedge.renderResult color (Just "property") hedgeResult + 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 @@ -223,3 +230,11 @@ 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,58 +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 "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 +{-# 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 10 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" + , " ┃ ^^^^^^^^^^^^^^^^^^^^^^^^^" + , "" + ]