Only print a specified number of context lines in failure reports

hedgehog/src/Hedgehog/Internal/Report.hs

@@ -22,13 +22,18 @@ module Hedgehog.Internal.Report (
   , Style(..)
   , Markup(..)
 
+  , Context(..)
+  , Lines
+
   , renderProgress
   , renderResult
+  , renderResultWith
   , renderSummary
   , renderDoc
 
   , ppProgress
   , ppResult
+  , ppResultWith
   , ppSummary
 
   , fromResult
@@ -181,7 +186,7 @@ summaryTotal (Summary x1 x2 x3 x4 x5) =
 
 data Line a =
   Line {
-      _lineAnnotation :: !a
+      lineAnnotation :: !a
     , lineNumber :: !LineNo
     , _lineSource :: !String
     } deriving (Eq, Ord, Show, Functor)
@@ -553,9 +558,44 @@ ppFailureLocation msgs mdiff sloc =
     pure $
       mapSource (styleFailure . insertDoc) decl
 
+type Annotation = (Style, [(Style, Doc Markup)])
+
+newtype Lines = Lines Int
+  deriving (Eq, Num)
+
+instance Show Lines where
+  showsPrec p (Lines n) = showsPrec p n
+
+data Context = FullContext | Context Lines
+
+applyContext :: Context -> Declaration Annotation -> Declaration Annotation
+applyContext context decl = case context of
+  FullContext -> decl
+  Context n -> decl { declarationSource = limitContextTo n (declarationSource decl) }
+
+limitContextTo :: Lines -> Map LineNo (Line Annotation) -> Map LineNo (Line Annotation)
+limitContextTo (Lines context) = Map.fromList . skipBoring . Map.toList
+  where
+    skipBoring xs = case span isBoring xs of
+      (boring, []) -> take context boring
+      (boring, rest) -> takeEnd context boring <> keepInteresting rest
+
+    keepInteresting xs = case break isBoring xs of
+      (interesting, rest) -> interesting <> take context rest <> skipBoring rest
+
+    isBoring = isBoringAnnotation . lineAnnotation . snd
+
+takeEnd :: Int -> [a] -> [a]
+takeEnd n = reverse . take n . reverse
+
+isBoringAnnotation :: Annotation -> Bool
+isBoringAnnotation = \ case
+  (StyleDefault, []) -> True
+  _ -> False
+
 ppDeclaration :: Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup
-ppDeclaration decl =
-  case Map.maxView $ declarationSource decl of
+ppDeclaration decl = let source = declarationSource decl in
+  case Map.maxView source of
     Nothing ->
       mempty
     Just (lastLine, _) ->
@@ -578,17 +618,30 @@ ppDeclaration decl =
 
         ppSource :: Style -> LineNo -> String -> Doc Markup
         ppSource style n src =
+          (if isOmittedLine (pred n) then addVerticalEllipsis else id) $
           markup (StyledLineNo style) (ppLineNo n) <+>
           markup (StyledBorder style) "┃" <+>
           markup (StyledSource style) (WL.text src)
 
+        addVerticalEllipsis =
+          (verticalEllipsis <#>)
+
+        verticalEllipsis =
+          "\x22ee"
+
+        isOmittedLine n =
+          n >= firstLine && Map.notMember n source
+
+        firstLine =
+          fst $ Map.findMin source
+
         ppAnnot (style, doc) =
           markup (StyledLineNo style) ppEmptyNo <+>
           markup (StyledBorder style) "┃" <+>
           doc
 
         ppLines = do
-          Line (style, xs) n src <- Map.elems $ declarationSource decl
+          Line (style, xs) n src <- Map.elems source
           ppSource style n src : fmap ppAnnot xs
       in
         WL.vsep (ppLocation : ppLines)
@@ -624,8 +677,8 @@ ppTextLines :: String -> [Doc Markup]
 ppTextLines =
   fmap WL.text . List.lines
 
-ppFailureReport :: MonadIO m => Maybe PropertyName -> TestCount -> DiscardCount -> Seed -> FailureReport -> m [Doc Markup]
-ppFailureReport name tests discards seed (FailureReport _ shrinkPath mcoverage inputs0 mlocation0 msg mdiff msgs0) = do
+ppFailureReport :: MonadIO m => Context -> Maybe PropertyName -> TestCount -> DiscardCount -> Seed -> FailureReport -> m [Doc Markup]
+ppFailureReport context name tests discards seed (FailureReport _ shrinkPath mcoverage inputs0 mlocation0 msg mdiff msgs0) = do
   let
     basic =
       -- Move the failure message to the end section if we have
@@ -713,7 +766,7 @@ ppFailureReport name tests discards seed (FailureReport _ shrinkPath mcoverage i
       with args $
         WL.punctuate WL.line
     , with decls $
-        WL.punctuate WL.line . fmap ppDeclaration
+        WL.punctuate WL.line . fmap (ppDeclaration . applyContext context)
     , with msgs1 $
         id
     , with bottom $
@@ -749,12 +802,14 @@ ppProgress name (Report tests discards coverage _ status) =
         ppTestCount tests <>
         ppShrinkDiscard (failureShrinks failure) discards <+>
         "(shrinking)"
-
 ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup)
-ppResult name (Report tests discards coverage seed result) = do
+ppResult = ppResultWith FullContext
+
+ppResultWith :: MonadIO m => Context -> Maybe PropertyName -> Report Result -> m (Doc Markup)
+ppResultWith context name (Report tests discards coverage seed result) = do
   case result of
     Failed failure -> do
-      pfailure <- ppFailureReport name tests discards seed failure
+      pfailure <- ppFailureReport context name tests discards seed failure
       pure . WL.vsep $ [
           icon FailedIcon '✗' . WL.align . WL.annotate FailedText $
             ppName name <+>
@@ -1226,8 +1281,11 @@ renderProgress color name x =
   renderDoc color =<< ppProgress name x
 
 renderResult :: MonadIO m => UseColor -> Maybe PropertyName -> Report Result -> m String
-renderResult color name x =
-  renderDoc color =<< ppResult name x
+renderResult = renderResultWith FullContext
+
+renderResultWith :: MonadIO m => Context -> UseColor -> Maybe PropertyName -> Report Result -> m String
+renderResultWith context color name x =
+  renderDoc color =<< ppResultWith context name x
 
 renderSummary :: MonadIO m => UseColor -> Summary -> m String
 renderSummary color x =