Show less context on failure (fixes #26)

hspec · May 11, 2024 · 52b3d99 · 52b3d99
1 parent 8ec73d7
commit 52b3d99
Show file tree

Hide file tree

Showing 3 changed files with 27 additions and 2 deletions.
diff --git 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/cabal.project b/cabal.project
@@ -5,3 +5,9 @@ package hspec-hedgehog
   ghc-options: -Werror
 
 tests: True
+
+source-repository-package
+  type: git
+  location: https://github.com/hedgehogqa/haskell-hedgehog
+  tag: fd182bf670abe554a7bebd34a0cac42e7bb07846
+  subdir: hedgehog
diff --git a/src/Test/Hspec/Hedgehog.hs b/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 0
+                , 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