Show less context on failure (fixes #26)

.github/workflows/build.yml

@@ -92,4 +92,4 @@ jobs:
       - name: Check for trailing whitespace
         run: '! git grep -I "\s\+$"'
       - run: curl -sSL https://raw.githubusercontent.com/sol/hpack/main/get-hpack.sh | bash
-      - run: hpack && git diff --exit-code
+      - run: hpack && git diff --color --exit-code

.github/workflows/publish.yml

@@ -14,7 +14,7 @@ jobs:
     steps:
       - uses: actions/checkout@v3
 
-      - run: cabal check
+      - run: cabal check --ignore=missing-upper-bounds
 
       - uses: sol/haskell-autotag@v1
         id: autotag

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

package.yaml

@@ -1,7 +1,7 @@
 spec-version: 0.36.0
 
 name: hspec-hedgehog
-version: 0.1.1.0
+version: 0.2.0.0
 synopsis: Integrate Hedgehog and Hspec!
 description: Please see the README on GitHub at <https://github.com/hspec/hspec-hedgehog#readme>
 category: Testing
@@ -19,7 +19,7 @@ dependencies:
   - base >= 4.7 && < 5
   - hspec >= 2.11.0 && < 3
   - hspec-core >= 2.11.0 && < 3
-  - hedgehog >= 1.0.2 && < 2
+  - hedgehog >= 1.5
 
 library:
   source-dirs: src

src/Test/Hspec/Hedgehog.hs

@@ -94,6 +94,7 @@ module Test.Hspec.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)
@@ -105,7 +106,6 @@ import           Hedgehog.Internal.Property (DiscardLimit (..), Property (..),
                                              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 @@ instance (m ~ IO) => Example (a -> PropertyT m ()) where
                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 @@ instance (m ~ IO) => Example (a -> PropertyT m ()) where
                     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

test/Test/Hspec/HedgehogSpec.hs

@@ -56,35 +56,31 @@ spec = do
     context "on Success" $ do
       it "includes the number of passed tests" $ do
         eval success `shouldReturn` Result
-            "  ✓ property passed 100 tests."
+            "passed 100 tests.\n"
             Success
 
       it "includes classification" $ do
         eval (label "foo" >> success) `shouldReturn` Result (joinLines [
-            "  ✓ property passed 100 tests."
-          , "    foo 100% ████████████████████"
+            "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
-            "  ⚐ property gave up after 10 discards, passed 0 tests."
+            "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)
+        let line delta = "" <> show (failingPropertyLine + delta)
         stripAnsi reason `shouldBe` joinLines [
-            "  ✗ property failed at test/Test/Hspec/HedgehogSpec.hs:" <> show failingPropertyLine <> ":19"
-          , "    after 1 test."
-          , "    shrink path: 1:"
-          , "  "
-          ,      "       ┏━━ test/Test/Hspec/HedgehogSpec.hs ━━━"
+            "failed after 1 test."
+          , "shrink path: 1:"
+          , ""
+          ,          "   ┏━━ test/Test/Hspec/HedgehogSpec.hs ━━━"
           , line -1 <> " ┃ failingProperty :: PropertyT IO ()"
           , line  0 <> " ┃ failingProperty = failure"
-          ,      "       ┃ ^^^^^^^^^^^^^^^^^^^^^^^^^"
-          , "  "
-          , "    This failure can be reproduced by running:"
-          , "    > recheckAt (Seed 14375056955115587481 16778118630780010967) \"1:\" property"
-          , "  "
+          ,          "   ┃ ^^^^^^^^^^^^^^^^^^^^^^^^^"
+          , ""
           ]