From 80068200eb27fc47453ed95d294a1735988759c8 Mon Sep 17 00:00:00 2001
From: Hiroki Tokunaga <tokusan441@gmail.com>
Date: Mon, 4 Mar 2024 22:38:13 +0900
Subject: [PATCH] Define `ModuleWarning` in replacement for `WarningTxt` (#823)

* Create `Warning.hs`

* `WithComments`

* Do not depend on GHC AST

* Remove an unused instance

* Remove an unused type

* pretty kind

* `prettyMsgs`

* Separation

* Fix

* Format

* Fix

* Fix
---
 hindent.cabal                          |  2 +
 src/HIndent/Ast/Module/Declaration.hs  |  9 ++--
 src/HIndent/Ast/Module/Warning.hs      | 58 ++++++++++++++++++++++++++
 src/HIndent/Ast/Module/Warning/Kind.hs | 19 +++++++++
 src/HIndent/Pretty.hs                  | 22 +---------
 src/HIndent/Pretty/NodeComments.hs     |  3 --
 src/HIndent/Pretty/Types.hs            | 12 +-----
 7 files changed, 85 insertions(+), 40 deletions(-)
 create mode 100644 src/HIndent/Ast/Module/Warning.hs
 create mode 100644 src/HIndent/Ast/Module/Warning/Kind.hs

diff --git a/hindent.cabal b/hindent.cabal
index d984dcc8d..46a432e70 100644
--- a/hindent.cabal
+++ b/hindent.cabal
@@ -44,6 +44,8 @@ library
       HIndent.Ast.Module
       HIndent.Ast.Module.Declaration
       HIndent.Ast.Module.Name
+      HIndent.Ast.Module.Warning
+      HIndent.Ast.Module.Warning.Kind
       HIndent.Ast.NodeComments
       HIndent.Ast.WithComments
       HIndent.ByteString
diff --git a/src/HIndent/Ast/Module/Declaration.hs b/src/HIndent/Ast/Module/Declaration.hs
index 22a37a6a9..af97986a4 100644
--- a/src/HIndent/Ast/Module/Declaration.hs
+++ b/src/HIndent/Ast/Module/Declaration.hs
@@ -7,18 +7,17 @@ module HIndent.Ast.Module.Declaration
 
 import HIndent.Applicative
 import HIndent.Ast.Module.Name
+import HIndent.Ast.Module.Warning
 import HIndent.Ast.NodeComments
 import HIndent.Ast.WithComments
 import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
-import qualified HIndent.GhcLibParserWrapper.GHC.Unit.Module.Warnings as GHC
 import HIndent.Pretty
 import HIndent.Pretty.Combinators
 import HIndent.Pretty.NodeComments
-import HIndent.Pretty.Types
 
 data ModuleDeclaration = ModuleDeclaration
   { name :: WithComments ModuleName
-  , warning :: Maybe (GHC.LocatedP GHC.WarningTxt')
+  , warning :: Maybe (WithComments ModuleWarning)
   , exports :: Maybe (GHC.LocatedL [GHC.LIE GHC.GhcPs])
   }
 
@@ -30,7 +29,7 @@ instance Pretty ModuleDeclaration where
     pretty name
     whenJust warning $ \x -> do
       space
-      pretty $ fmap ModuleDeprecatedPragma x
+      pretty x
     whenJust exports $ \xs -> do
       newline
       indentedBlock $ do
@@ -43,5 +42,5 @@ mkModuleDeclaration m =
     Nothing -> Nothing
     Just name' -> Just ModuleDeclaration {..}
       where name = mkModuleName <$> fromGenLocated name'
-            warning = GHC.getDeprecMessage m
+            warning = mkModuleWarning m
             exports = GHC.hsmodExports m
diff --git a/src/HIndent/Ast/Module/Warning.hs b/src/HIndent/Ast/Module/Warning.hs
new file mode 100644
index 000000000..92b3cd519
--- /dev/null
+++ b/src/HIndent/Ast/Module/Warning.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module HIndent.Ast.Module.Warning
+  ( ModuleWarning
+  , mkModuleWarning
+  ) where
+
+import HIndent.Ast.Module.Warning.Kind
+import HIndent.Ast.NodeComments
+import HIndent.Ast.WithComments
+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
+import qualified HIndent.GhcLibParserWrapper.GHC.Unit.Module.Warnings as GHC
+import HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+data ModuleWarning = ModuleWarning
+  { messages :: [String]
+  , kind :: Kind
+  }
+
+instance CommentExtraction ModuleWarning where
+  nodeComments _ = NodeComments [] [] []
+
+instance Pretty ModuleWarning where
+  pretty' ModuleWarning {..} = do
+    string "{-# "
+    pretty kind
+    space
+    prettyMsgs
+    string " #-}"
+    where
+      prettyMsgs =
+        case messages of
+          [x] -> string x
+          xs -> hList $ fmap string xs
+
+mkModuleWarning :: GHC.HsModule' -> Maybe (WithComments ModuleWarning)
+mkModuleWarning =
+  fmap (fromGenLocated . fmap fromWarningTxt) . GHC.getDeprecMessage
+
+fromWarningTxt :: GHC.WarningTxt' -> ModuleWarning
+#if MIN_VERSION_ghc_lib_parser(9, 8, 1)
+fromWarningTxt (GHC.WarningTxt _ _ s) = ModuleWarning {..}
+  where
+    messages = fmap showOutputable s
+    kind = Warning
+#else
+fromWarningTxt (GHC.WarningTxt _ s) = ModuleWarning {..}
+  where
+    messages = fmap showOutputable s
+    kind = Warning
+#endif
+fromWarningTxt (GHC.DeprecatedTxt _ s) = ModuleWarning {..}
+  where
+    messages = fmap showOutputable s
+    kind = Deprecated
diff --git a/src/HIndent/Ast/Module/Warning/Kind.hs b/src/HIndent/Ast/Module/Warning/Kind.hs
new file mode 100644
index 000000000..48a780ad3
--- /dev/null
+++ b/src/HIndent/Ast/Module/Warning/Kind.hs
@@ -0,0 +1,19 @@
+module HIndent.Ast.Module.Warning.Kind
+  ( Kind(..)
+  ) where
+
+import HIndent.Ast.NodeComments
+import HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+data Kind
+  = Warning
+  | Deprecated
+
+instance CommentExtraction Kind where
+  nodeComments _ = NodeComments [] [] []
+
+instance Pretty Kind where
+  pretty' Warning = string "WARNING"
+  pretty' Deprecated = string "DEPRECATED"
diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs
index b3cb24b4c..a9b906908 100644
--- a/src/HIndent/Pretty.hs
+++ b/src/HIndent/Pretty.hs
@@ -2493,27 +2493,7 @@ 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)
-instance Pretty ModuleDeprecatedPragma where
-  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 _ [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
     pretty unpack
diff --git a/src/HIndent/Pretty/NodeComments.hs b/src/HIndent/Pretty/NodeComments.hs
index 240555d49..d0bd69c2d 100644
--- a/src/HIndent/Pretty/NodeComments.hs
+++ b/src/HIndent/Pretty/NodeComments.hs
@@ -961,9 +961,6 @@ instance CommentExtraction (RuleBndr GhcPs) where
 instance CommentExtraction CCallConv where
   nodeComments = const emptyNodeComments
 
-instance CommentExtraction ModuleDeprecatedPragma where
-  nodeComments ModuleDeprecatedPragma {} = emptyNodeComments
-
 instance CommentExtraction HsSrcBang where
   nodeComments HsSrcBang {} = emptyNodeComments
 
diff --git a/src/HIndent/Pretty/Types.hs b/src/HIndent/Pretty/Types.hs
index da6ca7c2b..b90cf0590 100644
--- a/src/HIndent/Pretty/Types.hs
+++ b/src/HIndent/Pretty/Types.hs
@@ -40,7 +40,6 @@ module HIndent.Pretty.Types
   , ModuleNameWithPrefix(..)
   , PatInsidePatDecl(..)
   , LambdaCase(..)
-  , ModuleDeprecatedPragma(..)
   , ListComprehension(..)
   , DoExpression(..)
   , DoOrMdo(..)
@@ -56,7 +55,6 @@ module HIndent.Pretty.Types
 
 import GHC.Hs
 import GHC.Types.Name.Reader
-import GHC.Unit.Module.Warnings
 #if !MIN_VERSION_ghc_lib_parser(9,6,1)
 import GHC.Unit
 #endif
@@ -254,15 +252,7 @@ data LambdaCase = LambdaCase
   { lamCaseGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
   , caseOrCases :: CaseOrCases
   }
-#if MIN_VERSION_ghc_lib_parser(9,4,1)
--- | A deprecation pragma for a module.
-newtype ModuleDeprecatedPragma =
-  ModuleDeprecatedPragma (WarningTxt GhcPs)
-#else
--- | A deprecation pragma for a module.
-newtype ModuleDeprecatedPragma =
-  ModuleDeprecatedPragma WarningTxt
-#endif
+
 -- | Use this type to pretty-print a list comprehension.
 data ListComprehension = ListComprehension
   { listCompLhs :: ExprLStmt GhcPs -- ^ @f x@ of @[f x| x <- xs]@.