Use prettyprinter for annotateFailureReason

fourmolu.yaml

@@ -10,6 +10,7 @@ haddock-style: single-line
 let-style: mixed
 in-style: left-align
 single-constraint-parens: never # ignored until v12 / ghc-9.6
+trailing-section-operators: false # needs fourmolu >= v0.17
 unicode: never # default
 respectful: true # default
 fixities:

freckle-app/freckle-app.cabal

@@ -125,6 +125,7 @@ library
     , persistent-postgresql
     , persistent-sql-lifted
     , postgresql-simple
+    , prettyprinter
     , primitive
     , resource-pool >=0.4.0.0
     , resourcet

freckle-app/library/Freckle/App/Test/Hspec/AnnotatedException.hs

@@ -12,6 +12,9 @@ import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)
 import Data.Text qualified as T
 import Freckle.App.Exception (AnnotatedException (..))
 import GHC.Stack (CallStack, prettyCallStack)
+import Prettyprinter
+import Prettyprinter.Render.String
+import Prettyprinter.Util (reflow)
 import Test.HUnit.Lang (FailureReason (..), HUnitFailure (..))
 import Test.Hspec
 
@@ -50,41 +53,33 @@ annotateFailureReason as =
 --   some additional paragraphs based on annotations, separated by blank lines
 makeMessage :: String -> [Annotation] -> String
 makeMessage m as =
-  combineParagraphs $ stringParagraph m :| annotationParagraphs as
+  combineParagraphs $ pretty m :| annotationParagraphs as
 
 -- | Like 'makeMessage' but without necessarily having an introductory paragraph present
 --
 -- If there is neither an introductory paragraph nor any annotations, the result is 'Nothing'.
 makeMessageMaybe :: Maybe String -> [Annotation] -> Maybe String
 makeMessageMaybe mm as =
-  fmap combineParagraphs $
-    nonEmpty $
-      fmap stringParagraph (toList mm) <> annotationParagraphs as
-
--- | Text that constitutes a paragraph in a potentially lengthy error message
---
--- Construct with 'stringParagraph' or 'textParagraph', which strip the text of
--- surrounding whitespace.
-newtype Paragraph = Paragraph {paragraphText :: Text}
-
-stringParagraph :: String -> Paragraph
-stringParagraph = textParagraph . T.pack
-
-textParagraph :: Text -> Paragraph
-textParagraph = Paragraph . T.strip
+  fmap combineParagraphs
+    $ nonEmpty
+    $ fmap pretty (toList mm) <> annotationParagraphs as
 
 -- | Combine a list of paragraphs into a single string for the final output
-combineParagraphs :: Foldable t => t Paragraph -> String
+combineParagraphs :: Foldable t => t (Doc ann) -> String
 combineParagraphs =
-  T.unpack . T.intercalate "\n\n" . fmap paragraphText . toList
+  renderString
+    . layoutSmart defaultLayoutOptions
+    . vsep
+    . punctuate hardline
+    . toList
 
 -- | Render a list of annotations as a list of paragraphs
 --
 -- The paragraphs, depending on how much information there is to display, are:
 --
 -- * a summary of any annotations that aren't call stacks, if any
 -- * the first call stack, if there are any call stacks
-annotationParagraphs :: [Annotation] -> [Paragraph]
+annotationParagraphs :: [Annotation] -> [Doc ann]
 annotationParagraphs annotations =
   catMaybes
     [ otherAnnotationsPart <$> nonEmpty otherAnnotations
@@ -94,14 +89,13 @@ annotationParagraphs annotations =
   (callStacks, otherAnnotations) = tryAnnotations @CallStack annotations
 
 -- | Construct a paragraph consisting of a bullet list of annotations
-otherAnnotationsPart :: Foldable t => t Annotation -> Paragraph
+otherAnnotationsPart :: Foldable t => t Annotation -> Doc ann
 otherAnnotationsPart =
-  textParagraph
-    . T.intercalate "\n"
+  vsep
     . ("Annotations:" :)
-    . fmap (("\t * " <>) . T.pack . show)
+    . fmap (indent 2 . ("*" <+>) . align . reflow . T.pack . show)
     . toList
 
 -- | Construct a paragraph that displays a call stack
-callStackPart :: CallStack -> Paragraph
-callStackPart = textParagraph . T.pack . prettyCallStack
+callStackPart :: CallStack -> Doc ann
+callStackPart = pretty . prettyCallStack

freckle-app/package.yaml

@@ -106,6 +106,7 @@ library:
     - persistent-sql-lifted
     - persistent-postgresql
     - postgresql-simple
+    - prettyprinter
     - primitive
     - resource-pool >= 0.4.0.0 # defaultPoolConfig, etc
     - resourcet

freckle-app/tests/Freckle/App/Test/Hspec/AnnotatedExceptionSpec.hs

@@ -17,33 +17,33 @@ spec :: Spec
 spec = do
   describe "annotateHUnitFailure" $ do
     describe "does nothing if there are no annotations" $ do
-      it "when the failure is Reason" $
-        let e = HUnitFailure Nothing (Reason "x")
-        in  annotateHUnitFailure (AnnotatedException [] e) `shouldBe` e
+      it "when the failure is Reason"
+        $ let e = HUnitFailure Nothing (Reason "x")
+          in  annotateHUnitFailure (AnnotatedException [] e) `shouldBe` e
 
-      it "when the failure is ExpectedButGot with no message" $
-        let e = HUnitFailure Nothing (ExpectedButGot Nothing "a" "b")
-        in  annotateHUnitFailure (AnnotatedException [] e) `shouldBe` e
+      it "when the failure is ExpectedButGot with no message"
+        $ let e = HUnitFailure Nothing (ExpectedButGot Nothing "a" "b")
+          in  annotateHUnitFailure (AnnotatedException [] e) `shouldBe` e
 
-      it "when the failure is ExpectedButGot with a message" $
-        let e = HUnitFailure Nothing (ExpectedButGot (Just "x") "a" "b")
-        in  annotateHUnitFailure (AnnotatedException [] e) `shouldBe` e
+      it "when the failure is ExpectedButGot with a message"
+        $ let e = HUnitFailure Nothing (ExpectedButGot (Just "x") "a" "b")
+          in  annotateHUnitFailure (AnnotatedException [] e) `shouldBe` e
 
     describe "can show an annotation" $ do
-      it "when the failure is Reason" $
-        annotateHUnitFailure
+      it "when the failure is Reason"
+        $ annotateHUnitFailure
           AnnotatedException
             { annotations = [toAnnotation @Int 56]
             , exception = HUnitFailure Nothing (Reason "x")
             }
           `shouldBe` HUnitFailure
             Nothing
-            ( Reason . intercalate "\n" $
-                [ "x"
-                , ""
-                , "Annotations:"
-                , "\t * Annotation @Int 56"
-                ]
+            ( Reason . intercalate "\n"
+                $ [ "x"
+                  , ""
+                  , "Annotations:"
+                  , "  * Annotation @Int 56"
+                  ]
             )
 
       it "when the failure is ExpectedButGot with no message" $ do
@@ -55,41 +55,41 @@ spec = do
           `shouldBe` HUnitFailure
             Nothing
             ( ExpectedButGot
-                ( Just . intercalate "\n" $
-                    [ "Annotations:"
-                    , "\t * Annotation @Int 56"
-                    ]
+                ( Just . intercalate "\n"
+                    $ [ "Annotations:"
+                      , "  * Annotation @Int 56"
+                      ]
                 )
                 "a"
                 "b"
             )
 
-      it "when the failure is ExpectedButGot with a message" $
-        annotateHUnitFailure
+      it "when the failure is ExpectedButGot with a message"
+        $ annotateHUnitFailure
           AnnotatedException
             { annotations = [toAnnotation @Int 56]
             , exception = HUnitFailure Nothing (ExpectedButGot (Just "x") "a" "b")
             }
           `shouldBe` HUnitFailure
             Nothing
             ( ExpectedButGot
-                ( Just . intercalate "\n" $
-                    [ "x"
-                    , ""
-                    , "Annotations:"
-                    , "\t * Annotation @Int 56"
-                    ]
+                ( Just . intercalate "\n"
+                    $ [ "x"
+                      , ""
+                      , "Annotations:"
+                      , "  * Annotation @Int 56"
+                      ]
                 )
                 "a"
                 "b"
             )
 
-    it "can show a stack trace" $
-      annotateHUnitFailure
+    it "can show a stack trace"
+      $ annotateHUnitFailure
         AnnotatedException
           { annotations =
-              [ toAnnotation @CallStack $
-                  fromList
+              [ toAnnotation @CallStack
+                  $ fromList
                     [
                       ( "abc"
                       , SrcLoc
@@ -108,21 +108,21 @@ spec = do
           }
         `shouldBe` HUnitFailure
           Nothing
-          ( Reason . intercalate "\n" $
-              [ "x"
-              , ""
-              , "CallStack (from HasCallStack):"
-              , "  abc, called at src/Foo.hs:7:50 in thepackage:Foo"
-              ]
+          ( Reason . intercalate "\n"
+              $ [ "x"
+                , ""
+                , "CallStack (from HasCallStack):"
+                , "  abc, called at src/Foo.hs:7:50 in thepackage:Foo"
+                ]
           )
 
-    it "can show both an annotation and a stack trace" $
-      annotateHUnitFailure
+    it "can show both an annotation and a stack trace"
+      $ annotateHUnitFailure
         AnnotatedException
           { annotations =
               [ toAnnotation @Text "Visibility is poor"
-              , toAnnotation @CallStack $
-                  fromList
+              , toAnnotation @CallStack
+                  $ fromList
                     [
                       ( "abc"
                       , SrcLoc
@@ -141,13 +141,53 @@ spec = do
           }
         `shouldBe` HUnitFailure
           Nothing
-          ( Reason . intercalate "\n" $
-              [ "x"
-              , ""
-              , "Annotations:"
-              , "\t * Annotation @Text \"Visibility is poor\""
-              , ""
-              , "CallStack (from HasCallStack):"
-              , "  abc, called at src/Foo.hs:7:50 in thepackage:Foo"
+          ( Reason . intercalate "\n"
+              $ [ "x"
+                , ""
+                , "Annotations:"
+                , "  * Annotation @Text \"Visibility is poor\""
+                , ""
+                , "CallStack (from HasCallStack):"
+                , "  abc, called at src/Foo.hs:7:50 in thepackage:Foo"
+                ]
+          )
+
+    it "wraps long annotations into neat lists"
+      $ annotateHUnitFailure
+        AnnotatedException
+          { annotations =
+              [ toAnnotation @Text
+                  "Visibility is poor. Visability is poor. Visability is poor. Visability is poor. Visability is poor. Visability is poor. Visability is poor. Visability is poor. Visability is poor. Visability is poor. Visability is poor"
+              , toAnnotation @CallStack
+                  $ fromList
+                    [
+                      ( "abc"
+                      , SrcLoc
+                          { srcLocPackage = "thepackage"
+                          , srcLocModule = "Foo"
+                          , srcLocFile = "src/Foo.hs"
+                          , srcLocStartLine = 7
+                          , srcLocStartCol = 50
+                          , srcLocEndLine = 8
+                          , srcLocEndCol = 23
+                          }
+                      )
+                    ]
               ]
+          , exception = HUnitFailure Nothing (Reason "x")
+          }
+        `shouldBe` HUnitFailure
+          Nothing
+          ( Reason . intercalate "\n"
+              $ [ "x"
+                , ""
+                , "Annotations:"
+                , "  * Annotation @Text \"Visibility is poor. Visability is poor. Visability is"
+                , "    poor. Visability is poor. Visability is poor. Visability is poor. Visability"
+                , "    is poor. Visability is poor. Visability is poor. Visability is poor."
+                , "    Visability is poor\""
+                , ""
+                , "CallStack (from HasCallStack):"
+                , "  abc, called at src/Foo.hs:7:50 in thepackage:Foo"
+                ]
           )