diff --git a/fourmolu.yaml b/fourmolu.yaml index 315cc82b..61cea5ce 100644 --- a/fourmolu.yaml +++ b/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: diff --git a/freckle-app/freckle-app.cabal b/freckle-app/freckle-app.cabal index 93634719..ade2f96b 100644 --- a/freckle-app/freckle-app.cabal +++ b/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 diff --git a/freckle-app/library/Freckle/App/Test/Hspec/AnnotatedException.hs b/freckle-app/library/Freckle/App/Test/Hspec/AnnotatedException.hs index dbc45135..c602d158 100644 --- a/freckle-app/library/Freckle/App/Test/Hspec/AnnotatedException.hs +++ b/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,33 +53,25 @@ 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 -- @@ -84,7 +79,7 @@ combineParagraphs = -- -- * 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 diff --git a/freckle-app/package.yaml b/freckle-app/package.yaml index eb86500c..9611455e 100644 --- a/freckle-app/package.yaml +++ b/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 diff --git a/freckle-app/tests/Freckle/App/Test/Hspec/AnnotatedExceptionSpec.hs b/freckle-app/tests/Freckle/App/Test/Hspec/AnnotatedExceptionSpec.hs index 30a7e432..60a99bde 100644 --- a/freckle-app/tests/Freckle/App/Test/Hspec/AnnotatedExceptionSpec.hs +++ b/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,17 +55,17 @@ 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") @@ -73,23 +73,23 @@ spec = do `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" + ] )