Better formatting of result message in GitHub.

Author: chungyc

action.yaml

@@ -42,7 +42,7 @@ outputs:
 
 runs:
   using: docker
-  image: Dockerfile # docker://ghcr.io/haskell-actions/hlint-scan:main
+  image: docker://ghcr.io/haskell-actions/hlint-scan:main
   args:
     - binary=${{ inputs.binary }}
     - path=${{ inputs.path }}

docs/CHANGELOG.md

@@ -11,6 +11,7 @@ the [Haskell Package Versioning Policy].
 ## Unreleased
 
 *   Support `hints` input for explicitly specifying the HLint configuration file.
+*   Better message formatting on GitHub.
 
 ## 0.4.1 - 2023-04-10
 

src/Format.hs

@@ -47,32 +47,44 @@ import Data.Text qualified as Text
 -- | Format text messages in result objects to be better readable on GitHub.
 formatMessages :: Value -> Value
 formatMessages (Object v) = Object $ mapWithKey formatRuns v
-formatMessages v = v
-
-formatRuns :: Key -> Value -> Value
-formatRuns "runs" (Array vs) = Array $ fmap formatRun vs
-formatRuns _ v = v
+  where
+    formatRuns "runs" (Array us) = Array $ fmap formatRun us
+    formatRuns _ u = u
 
-formatRun :: Value -> Value
-formatRun (Object v) = Object $ mapWithKey formatResults v
-formatRun v = v
+    formatRun (Object u) = Object $ mapWithKey formatResults u
+    formatRun u = u
 
-formatResults :: Key -> Value -> Value
-formatResults "results" (Array vs) = Array $ fmap formatResult vs
-formatResults _ v = v
+    formatResults "results" (Array us) = Array $ fmap formatResult us
+    formatResults _ u = u
 
-formatResult :: Value -> Value
-formatResult (Object v) = Object $ mapWithKey formatMessage v
-formatResult v = v
+    formatResult (Object u) = Object $ mapWithKey formatMessage u
+    formatResult u = u
 
-formatMessage :: Key -> Value -> Value
-formatMessage "message" (Object v) = Object $ mapWithKey formatText v
-formatMessage _ v = v
+    formatMessage "message" (Object u) = Object $ mapWithKey formatText u
+    formatMessage _ u = u
+formatMessages v = v
 
+-- | Formats the text in a @message@ object better for GitHub.
+--
+-- Basically rewrites the text so that GitHub does not turn the message
+-- into mindlessly left-aligned lines of text.  The specific rewriting
+-- was derived by trial and error; there appears to be no documentation
+-- as to what parts of Markdown syntax are effective in this context,
+-- unfortunately.
 formatText :: Key -> Value -> Value
-formatText "text" (String s) = String s'
+formatText "text" (String s) = String s''
   where
-    l = Text.lines s
-    s' | x:xs <- l = Text.unlines $ x : "<pre>" : xs ++ ["</pre>"]
-       | [] <- l = s
+    s' = Text.unlines $ format $ Text.lines s
+    -- Replace all spaces with @&nbsp;@ so that GitHub does not collapse them.
+    s'' = Text.replace " " "&nbsp;" s'
+    -- Put an extra newline between separate pieces of content.
+    -- I.e., between the general message, the code found,
+    -- the suggested replacements, and any notes.
+    -- The extra line is inserted as "  " instead of ""
+    -- because GitHub would otherwise collapse them.
+    format (x : xs@(x' : _))
+      | not (Text.isPrefixOf " " x') = x : "  " : format xs
+      | otherwise = x : format xs
+    format (x : xs) = x : format xs
+    format [] = []
 formatText _ v = v

test/FormatSpec.hs

@@ -0,0 +1,95 @@
+{-
+Copyright 2023 Google LLC
+
+Licensed under the Apache License, Version 2.0 (the "License");
+you may not use this file except in compliance with the License.
+You may obtain a copy of the License at
+
+    https://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software
+distributed under the License is distributed on an "AS IS" BASIS,
+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+See the License for the specific language governing permissions and
+limitations under the License.
+-}
+
+-- |
+-- Description: Tests for the "Format" module.
+-- Copyright: Copyright 2023 Google LLC
+-- License: Apache-2.0
+-- Maintainer: [email protected]
+module FormatSpec (spec) where
+
+import Data.Aeson
+import Data.Aeson.KeyMap qualified as KeyMap
+import Data.Char
+import Data.Text (Text)
+import Data.Text qualified as Text
+import Data.Vector qualified as Vector
+import Format
+import Test.Hspec
+import Test.Hspec.QuickCheck
+import Test.QuickCheck
+import Test.QuickCheck.Instances.Text ()
+
+spec :: Spec
+spec = do
+  describe "formatMessages" $ do
+    it "formats a particular message" $
+      formatMessages
+        ( objectWithMessage $
+            Text.unlines
+              [ "Bad.hs:16:9-20: Warning: Use /=",
+                "Found:",
+                "  not (a == b)",
+                "Perhaps:",
+                "  a /= b",
+                "Note: incorrect if either value is NaN"
+              ]
+        )
+        `shouldBe` objectWithMessage
+          ( Text.unlines
+              [ "Bad.hs:16:9-20: Warning: Use /=",
+                "  ",
+                "Found:",
+                "  not (a == b)",
+                "  ",
+                "Perhaps:",
+                "  a /= b",
+                "  ",
+                "Note: incorrect if either value is NaN"
+              ]
+          )
+
+    prop "formats messages in general" $
+      forAll (listOf chooseSection) $ \sections ->
+        let message = mconcat sections
+            message' = Text.replace " " " " $ Text.intercalate "  \n" sections
+         in counterexample (show message) $
+              counterexample (show message') $
+                formatMessages (objectWithMessage message) `shouldBe` objectWithMessage message'
+
+objectWithMessage :: Text -> Value
+objectWithMessage message =
+  Object . KeyMap.singleton "runs" $
+    Array . Vector.singleton . Object . KeyMap.singleton "results" $
+      Array . Vector.singleton . Object . KeyMap.singleton "message" $
+        Object . KeyMap.singleton "text" $
+          String message
+
+chooseSection :: Gen Text
+chooseSection = do
+  note <- arbitrary `suchThat` isNonEmptyLine
+  codelines <- map ("  " <>) <$> arbitrary `suchThat` all isNonEmptyLine
+  return $ Text.unlines $ note : codelines
+  where
+    isNonEmptyLine s =
+      not
+        ( Text.null s
+            || Text.take 1 s == " "
+            || Text.elem '\n' s
+            || Text.elem '\r' s
+            || Text.all isSpace s
+        )
+        && Text.all (\c -> isAlphaNum c || c == ' ') s