Fix the pretty-printing of module-level warnings (#822)

* Add a test * Pass the test * Pass the test * Move a test * Add a test and pass it * Add a test * Modify a test * Support multiple GHC versions * Add a changelog * Format * Fix the log
mihaimaruseac · Mar 3, 2024 · b4b9103 · b4b9103
1 parent deac852
commit b4b9103
Show file tree

Hide file tree

Showing 3 changed files with 63 additions and 25 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -13,6 +13,7 @@
 - Wrong default HIndent configuration in [`README.md`] ([#750]).
 - Fix the bug of panicking when the given source code has CPP lines and space-prefixed lines ([#780]).
 - Fix not pretty-printing multiple signatures in a `SPECIALISE` ([#784]).
+- Fix the bug of not pretty-printing multiple module-level warning messages ([#822])
 
 ### Removed
 
@@ -368,6 +369,7 @@ This version is accidentally pushlished, and is the same as 5.3.3.
 [@uhbif19]: https://github.com/uhbif19
 [@toku-sa-n]: https://github.com/toku-sa-n
 
+[#822]: https://github.com/mihaimaruseac/hindent/pull/822
 [#784]: https://github.com/mihaimaruseac/hindent/pull/784
 [#780]: https://github.com/mihaimaruseac/hindent/pull/780
 [#775]: https://github.com/mihaimaruseac/hindent/pull/775

diff --git a/TESTS.md b/TESTS.md
@@ -77,22 +77,6 @@ module X
 
 ### Module-level pragmas
 
-A `WARNING` for a module without an export list.
-
-```haskell
-module Foo {-# WARNING "Debug purpose only." #-} where
-```
-
-A `DEPRECATED` for a module with an export list.
-
-```haskell
-module Foo {-# DEPRECATED "Use Bar." #-}
-  ( x
-  , y
-  , z
-  ) where
-```
-
 A pragma's name is converted to the SHOUT_CASE.
 
 ```haskell given
@@ -183,6 +167,50 @@ Do not collect pragma-like comments
 static = 3
 ```
 
+#### `WARNING`
+
+Without messages and an export list.
+
+```haskell
+module Foo {-# WARNING [] #-} where
+```
+
+With a string without an export list.
+
+```haskell
+module Foo {-# WARNING "Debug purpose only." #-} where
+```
+
+With a list of reasons without an export list.
+
+```haskell
+module Foo {-# WARNING ["Debug purpose only.", "Okay?"] #-} where
+```
+
+#### `DEPRECATED`
+
+Without messages and an export list.
+
+```haskell
+module Foo {-# DEPRECATED [] #-} where
+```
+
+With a string without an export list.
+
+```haskell
+module Foo {-# DEPRECATED "Use Bar." #-} where
+```
+
+With a list of reasons and an export list.
+
+```haskell
+module Foo {-# DEPRECATED ["Use Bar.", "Or use Baz."] #-}
+  ( x
+  , y
+  , z
+  ) where
+```
+
 ## Imports, foreign imports, and foreign exports
 
 Import lists

diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs
@@ -2493,18 +2493,26 @@ instance Pretty CCallConv where
   pretty' StdCallConv = string "stdcall"
   pretty' PrimCallConv = string "prim"
   pretty' JavaScriptCallConv = string "javascript"
-#if MIN_VERSION_ghc_lib_parser(9,8,1)
+#if MIN_VERSION_ghc_lib_parser(9, 8, 1)
 instance Pretty ModuleDeprecatedPragma where
-  pretty' (ModuleDeprecatedPragma (WarningTxt _ _ xs)) =
-    spaced [string "{-# WARNING", spaced $ fmap pretty xs, string "#-}"]
-  pretty' (ModuleDeprecatedPragma (DeprecatedTxt _ xs)) =
-    spaced [string "{-# DEPRECATED", spaced $ fmap pretty xs, string "#-}"]
+  pretty' (ModuleDeprecatedPragma (WarningTxt _ _ [msg])) =
+    spaced [string "{-# WARNING", pretty msg, string "#-}"]
+  pretty' (ModuleDeprecatedPragma (WarningTxt _ _ msgs)) =
+    spaced [string "{-# WARNING", hList $ fmap pretty msgs, string "#-}"]
+  pretty' (ModuleDeprecatedPragma (DeprecatedTxt _ [msg])) =
+    spaced [string "{-# DEPRECATED", pretty msg, string "#-}"]
+  pretty' (ModuleDeprecatedPragma (DeprecatedTxt _ msgs)) =
+    spaced [string "{-# DEPRECATED", hList $ fmap pretty msgs, string "#-}"]
 #else
 instance Pretty ModuleDeprecatedPragma where
-  pretty' (ModuleDeprecatedPragma (WarningTxt _ xs)) =
-    spaced [string "{-# WARNING", spaced $ fmap pretty xs, string "#-}"]
-  pretty' (ModuleDeprecatedPragma (DeprecatedTxt _ xs)) =
-    spaced [string "{-# DEPRECATED", spaced $ fmap pretty xs, string "#-}"]
+  pretty' (ModuleDeprecatedPragma (WarningTxt _ [msg])) =
+    spaced [string "{-# WARNING", pretty msg, string "#-}"]
+  pretty' (ModuleDeprecatedPragma (WarningTxt _ msgs)) =
+    spaced [string "{-# WARNING", hList $ fmap pretty msgs, string "#-}"]
+  pretty' (ModuleDeprecatedPragma (DeprecatedTxt _ [msg])) =
+    spaced [string "{-# DEPRECATED", pretty msg, string "#-}"]
+  pretty' (ModuleDeprecatedPragma (DeprecatedTxt _ msgs)) =
+    spaced [string "{-# DEPRECATED", hList $ fmap pretty msgs, string "#-}"]
 #endif
 instance Pretty HsSrcBang where
   pretty' (HsSrcBang _ unpack strictness) = do