Implement WarningCollection

hindent.cabal

@@ -76,6 +76,9 @@ library
       HIndent.Ast.Declaration.StandAloneDeriving
       HIndent.Ast.Declaration.TypeSynonym
       HIndent.Ast.Declaration.TypeSynonym.Lhs
+      HIndent.Ast.Declaration.Warning
+      HIndent.Ast.Declaration.Warning.Collection
+      HIndent.Ast.Declaration.Warning.Kind
       HIndent.Ast.FileHeaderPragma
       HIndent.Ast.FileHeaderPragma.Collection
       HIndent.Ast.Import
@@ -89,7 +92,6 @@ library
       HIndent.Ast.Module.Export.Entry
       HIndent.Ast.Module.Name
       HIndent.Ast.Module.Warning
-      HIndent.Ast.Module.Warning.Kind
       HIndent.Ast.NodeComments
       HIndent.Ast.Type
       HIndent.Ast.Type.Variable

src/HIndent/Ast/Declaration.hs

@@ -22,6 +22,7 @@ import HIndent.Ast.Declaration.Signature
 import HIndent.Ast.Declaration.Signature.StandaloneKind
 import HIndent.Ast.Declaration.StandAloneDeriving
 import HIndent.Ast.Declaration.TypeSynonym
+import HIndent.Ast.Declaration.Warning.Collection
 import HIndent.Ast.NodeComments
 import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
 import {-# SOURCE #-} HIndent.Pretty
@@ -42,7 +43,7 @@ data Declaration
   | StandaloneKindSignature StandaloneKind
   | Default DefaultDeclaration
   | Foreign ForeignDeclaration
-  | WarningDecl (GHC.WarnDecls GHC.GhcPs)
+  | Warnings WarningCollection
   | AnnDecl (GHC.AnnDecl GHC.GhcPs)
   | RuleDecl (GHC.RuleDecls GHC.GhcPs)
   | SpliceDecl (GHC.SpliceDecl GHC.GhcPs)
@@ -63,7 +64,7 @@ instance CommentExtraction Declaration where
   nodeComments StandaloneKindSignature {} = NodeComments [] [] []
   nodeComments Default {} = NodeComments [] [] []
   nodeComments Foreign {} = NodeComments [] [] []
-  nodeComments WarningDecl {} = NodeComments [] [] []
+  nodeComments Warnings {} = NodeComments [] [] []
   nodeComments AnnDecl {} = NodeComments [] [] []
   nodeComments RuleDecl {} = NodeComments [] [] []
   nodeComments SpliceDecl {} = NodeComments [] [] []
@@ -84,7 +85,7 @@ instance Pretty Declaration where
   pretty' (StandaloneKindSignature x) = pretty x
   pretty' (Default x) = pretty x
   pretty' (Foreign x) = pretty x
-  pretty' (WarningDecl x) = pretty x
+  pretty' (Warnings x) = pretty x
   pretty' (AnnDecl x) = pretty x
   pretty' (RuleDecl x) = pretty x
   pretty' (SpliceDecl x) = pretty x
@@ -111,7 +112,7 @@ mkDeclaration (GHC.SigD _ x) = Signature $ mkSignature x
 mkDeclaration (GHC.KindSigD _ x) = StandaloneKindSignature $ mkStandaloneKind x
 mkDeclaration (GHC.DefD _ x) = Default $ mkDefaultDeclaration x
 mkDeclaration (GHC.ForD _ x) = Foreign $ mkForeignDeclaration x
-mkDeclaration (GHC.WarningD _ x) = WarningDecl x
+mkDeclaration (GHC.WarningD _ x) = Warnings $ mkWarningCollection x
 mkDeclaration (GHC.AnnD _ x) = AnnDecl x
 mkDeclaration (GHC.RuleD _ x) = RuleDecl x
 mkDeclaration (GHC.SpliceD _ x) = SpliceDecl x

src/HIndent/Ast/Declaration/Warning.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module HIndent.Ast.Declaration.Warning
+  ( WarningDeclaration
+  , mkWarningDeclaration
+  ) where
+
+import qualified GHC.Types.SourceText as GHC
+import qualified GHC.Types.SrcLoc as GHC
+import HIndent.Ast.Declaration.Warning.Kind
+import HIndent.Ast.NodeComments
+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
+import qualified HIndent.GhcLibParserWrapper.GHC.Unit.Module.Warnings as GHC
+import {-# SOURCE #-} HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+data WarningDeclaration = WarningDeclaration
+  { names :: [GHC.LIdP GHC.GhcPs]
+  , kind :: Kind
+  , reasons :: [GHC.Located GHC.StringLiteral]
+  }
+
+instance CommentExtraction WarningDeclaration where
+  nodeComments _ = NodeComments [] [] []
+
+instance Pretty WarningDeclaration where
+  pretty' WarningDeclaration {..} = do
+    lined
+      [ string "{-# " >> pretty kind
+      , spaced [hCommaSep $ fmap pretty names, hCommaSep $ fmap pretty reasons]
+      , string " #-}"
+      ]
+
+mkWarningDeclaration :: GHC.WarnDecl GHC.GhcPs -> WarningDeclaration
+#if MIN_VERSION_ghc_lib_parser(9, 8, 1)
+mkWarningDeclaration (GHC.Warning _ names (GHC.DeprecatedTxt _ rs)) =
+  WarningDeclaration {kind = Deprecated, ..}
+  where
+    reasons = fmap (fmap GHC.hsDocString) rs
+mkWarningDeclaration (GHC.Warning _ names (GHC.WarningTxt _ _ rs)) =
+  WarningDeclaration {kind = Warning, ..}
+  where
+    reasons = fmap (fmap GHC.hsDocString) rs
+#else
+mkWarningDeclaration (GHC.Warning _ names (GHC.DeprecatedTxt _ reasons)) =
+  WarningDeclaration {kind = Deprecated, ..}
+mkWarningDeclaration (GHC.Warning _ names (GHC.WarningTxt _ reasons)) =
+  WarningDeclaration {kind = Warning, ..}
+#endif

src/HIndent/Ast/Declaration/Warning/Collection.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE CPP #-}
+
+module HIndent.Ast.Declaration.Warning.Collection
+  ( WarningCollection
+  , mkWarningCollection
+  ) where
+
+import HIndent.Ast.Declaration.Warning
+import HIndent.Ast.NodeComments
+import HIndent.Ast.WithComments
+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
+import {-# SOURCE #-} HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+newtype WarningCollection =
+  WarningCollection [WithComments WarningDeclaration]
+
+instance CommentExtraction WarningCollection where
+  nodeComments WarningCollection {} = NodeComments [] [] []
+
+instance Pretty WarningCollection where
+  pretty' (WarningCollection xs) = lined $ fmap pretty xs
+
+mkWarningCollection :: GHC.WarnDecls GHC.GhcPs -> WarningCollection
+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)
+mkWarningCollection (GHC.Warnings _ xs) =
+  WarningCollection $ fmap (fmap mkWarningDeclaration . fromGenLocated) xs
+#else
+mkWarningCollection (GHC.Warnings _ _ xs) =
+  WarningCollection $ fmap (fmap mkWarningDeclaration . fromGenLocated) xs
+#endif

src/HIndent/Ast/Module/Warning/Kind.hs → src/HIndent/Ast/Declaration/Warning/Kind.hs

@@ -1,9 +1,9 @@
-module HIndent.Ast.Module.Warning.Kind
+module HIndent.Ast.Declaration.Warning.Kind
   ( Kind(..)
   ) where
 
 import HIndent.Ast.NodeComments
-import HIndent.Pretty
+import {-# SOURCE #-} HIndent.Pretty
 import HIndent.Pretty.Combinators
 import HIndent.Pretty.NodeComments
 

src/HIndent/Ast/Module/Warning.hs

@@ -6,7 +6,7 @@ module HIndent.Ast.Module.Warning
   , mkModuleWarning
   ) where
 
-import HIndent.Ast.Module.Warning.Kind
+import HIndent.Ast.Declaration.Warning.Kind
 import HIndent.Ast.NodeComments
 import HIndent.Ast.WithComments
 import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC

src/HIndent/Pretty.hs

@@ -36,7 +36,6 @@ import qualified GHC.Types.Name as GHC
 import qualified GHC.Types.Name.Reader as GHC
 import qualified GHC.Types.SourceText as GHC
 import qualified GHC.Types.SrcLoc as GHC
-import qualified GHC.Unit.Module.Warnings as GHC
 import HIndent.Applicative
 import HIndent.Ast.Declaration
 import HIndent.Ast.Declaration.Bind
@@ -1425,42 +1424,6 @@ instance Pretty (GHC.HsQuote GHC.GhcPs) where
   pretty' (GHC.VarBr _ True x) = string "'" >> pretty x
   pretty' (GHC.VarBr _ False x) = string "''" >> pretty x
 #endif
-#if MIN_VERSION_ghc_lib_parser(9,6,1)
-instance Pretty (GHC.WarnDecls GHC.GhcPs) where
-  pretty' (GHC.Warnings _ x) = lined $ fmap pretty x
-#else
-instance Pretty (GHC.WarnDecls GHC.GhcPs) where
-  pretty' (GHC.Warnings _ _ x) = lined $ fmap pretty x
-#endif
-#if MIN_VERSION_ghc_lib_parser(9,8,1)
-instance Pretty (GHC.WarnDecl GHC.GhcPs) where
-  pretty' (GHC.Warning _ names deprecatedOrWarning) =
-    case deprecatedOrWarning of
-      GHC.DeprecatedTxt _ reasons -> prettyWithTitleReasons "DEPRECATED" reasons
-      GHC.WarningTxt _ _ reasons -> prettyWithTitleReasons "WARNING" reasons
-    where
-      prettyWithTitleReasons title reasons =
-        lined
-          [ string $ "{-# " ++ title
-          , spaced
-              [hCommaSep $ fmap pretty names, hCommaSep $ fmap pretty reasons]
-          , string " #-}"
-          ]
-#else
-instance Pretty (GHC.WarnDecl GHC.GhcPs) where
-  pretty' (GHC.Warning _ names deprecatedOrWarning) =
-    case deprecatedOrWarning of
-      GHC.DeprecatedTxt _ reasons -> prettyWithTitleReasons "DEPRECATED" reasons
-      GHC.WarningTxt _ reasons -> prettyWithTitleReasons "WARNING" reasons
-    where
-      prettyWithTitleReasons title reasons =
-        lined
-          [ string $ "{-# " ++ title
-          , spaced
-              [hCommaSep $ fmap pretty names, hCommaSep $ fmap pretty reasons]
-          , string " #-}"
-          ]
-#endif
 #if MIN_VERSION_ghc_lib_parser(9,4,1)
 instance Pretty (GHC.WithHsDocIdentifiers GHC.StringLiteral GHC.GhcPs) where
   pretty' GHC.WithHsDocIdentifiers {..} = pretty hsDocString

src/HIndent/Pretty.hs-boot

@@ -11,6 +11,7 @@ import           Data.Void
 import qualified GHC.Core.Type                      as GHC
 import qualified GHC.Types.Basic                    as GHC
 import qualified GHC.Types.Name.Reader              as GHC
+import qualified GHC.Types.SourceText               as GHC
 import qualified GHC.Types.SrcLoc                   as GHC
 import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
 import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHc
@@ -77,7 +78,7 @@ instance Pretty (GHC.HsPatSynDir GHC.GhcPs)
 
 instance Pretty PatInsidePatDecl
 
-instance Pretty (GHC.WarnDecls GHC.GhcPs)
+instance Pretty GHC.StringLiteral
 
 instance Pretty (GHC.AnnDecl GHC.GhcPs)