Define Module as a replacement for HsModule

hindent.cabal

@@ -36,6 +36,16 @@ library
       HIndent
   other-modules:
       HIndent.Applicative
+      HIndent.Ast
+      HIndent.Ast.Declaration.Collection
+      HIndent.Ast.FileHeaderPragma
+      HIndent.Ast.FileHeaderPragma.Collection
+      HIndent.Ast.Import.Collection
+      HIndent.Ast.Module
+      HIndent.Ast.Module.Declaration
+      HIndent.Ast.Module.Name
+      HIndent.Ast.NodeComments
+      HIndent.Ast.WithComments
       HIndent.ByteString
       HIndent.CabalFile
       HIndent.CodeBlock
@@ -44,6 +54,7 @@ library
       HIndent.Error
       HIndent.Fixity
       HIndent.GhcLibParserWrapper.GHC.Hs
+      HIndent.GhcLibParserWrapper.GHC.Unit.Module.Warnings
       HIndent.Language
       HIndent.LanguageExtension
       HIndent.LanguageExtension.Conversion
@@ -68,7 +79,6 @@ library
       HIndent.Pretty.Import
       HIndent.Pretty.Import.Sort
       HIndent.Pretty.NodeComments
-      HIndent.Pretty.Pragma
       HIndent.Pretty.SigBindFamily
       HIndent.Pretty.Types
       HIndent.Printer

src/HIndent.hs

@@ -39,6 +39,7 @@ import Foreign.C
 import GHC.IO.Exception
 import GHC.Parser.Lexer hiding (buffer, options)
 import GHC.Types.SrcLoc
+import HIndent.Ast
 import HIndent.ByteString
 import HIndent.CabalFile
 import HIndent.CodeBlock
@@ -181,5 +182,5 @@ testAst x =
 
 -- | Print the module.
 prettyPrint :: Config -> HsModule' -> Builder
-prettyPrint config m =
-  runPrinterStyle config (pretty $ modifyASTForPrettyPrinting m)
+prettyPrint config =
+  runPrinterStyle config . pretty . mkModule . modifyASTForPrettyPrinting

src/HIndent/Ast.hs

@@ -0,0 +1,17 @@
+-- | This module defines the AST for Haskell code.
+--
+-- GHC provides its AST for Haskell code, but the structure it offers may change
+-- with version updates. In other words, when directly using GHC's AST as the
+-- AST for pretty-printing, updates in GHC require direct modifications to the
+-- pretty-printing functions. On the other hand, when there is a need to change
+-- the pretty-printing style, corresponding modifications to the functions are
+-- also necessary. The presence of these two reasons for modification leads to a
+-- suboptimal design state.
+--
+-- Therefore, this module defines a custom AST for HIndent, allowing flexibility
+-- to adapt to changes in GHC's AST across different versions.
+module HIndent.Ast
+  ( mkModule
+  ) where
+
+import HIndent.Ast.Module

src/HIndent/Ast/Declaration/Collection.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module HIndent.Ast.Declaration.Collection
+  ( DeclarationCollection
+  , mkDeclarationCollection
+  , hasDeclarations
+  ) where
+
+import Data.Maybe
+import qualified GHC.Hs as GHC
+import qualified GHC.Types.SrcLoc as GHC
+import HIndent.Ast.NodeComments
+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
+import HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+newtype DeclarationCollection =
+  DeclarationCollection [GHC.LHsDecl GHC.GhcPs]
+
+instance CommentExtraction DeclarationCollection where
+  nodeComments DeclarationCollection {} = NodeComments [] [] []
+
+instance Pretty DeclarationCollection where
+  pretty' (DeclarationCollection decls) =
+    mapM_ (\(x, sp) -> pretty x >> fromMaybe (return ()) sp)
+      $ addDeclSeparator decls
+    where
+      addDeclSeparator [] = []
+      addDeclSeparator [x] = [(x, Nothing)]
+      addDeclSeparator (x:xs) =
+        (x, Just $ declSeparator $ GHC.unLoc x) : addDeclSeparator xs
+      declSeparator (GHC.SigD _ GHC.TypeSig {}) = newline
+      declSeparator (GHC.SigD _ GHC.InlineSig {}) = newline
+      declSeparator (GHC.SigD _ GHC.PatSynSig {}) = newline
+      declSeparator _ = blankline
+
+mkDeclarationCollection :: GHC.HsModule' -> DeclarationCollection
+mkDeclarationCollection GHC.HsModule {..} = DeclarationCollection hsmodDecls
+
+hasDeclarations :: DeclarationCollection -> Bool
+hasDeclarations (DeclarationCollection xs) = not $ null xs

src/HIndent/Ast/FileHeaderPragma.hs

@@ -0,0 +1,21 @@
+module HIndent.Ast.FileHeaderPragma
+  ( FileHeaderPragma
+  , mkFileHeaderPragma
+  ) where
+
+import HIndent.Ast.NodeComments
+import HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+newtype FileHeaderPragma =
+  FileHeaderPragma String
+
+instance CommentExtraction FileHeaderPragma where
+  nodeComments _ = NodeComments [] [] []
+
+instance Pretty FileHeaderPragma where
+  pretty' (FileHeaderPragma x) = string x
+
+mkFileHeaderPragma :: String -> FileHeaderPragma
+mkFileHeaderPragma = FileHeaderPragma

src/HIndent/Ast/FileHeaderPragma/Collection.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE CPP #-}
+
+module HIndent.Ast.FileHeaderPragma.Collection
+  ( FileHeaderPragmaCollection
+  , mkFileHeaderPragmaCollection
+  , hasPragmas
+  ) where
+
+import Data.Bifunctor
+import Data.Char
+import Data.List
+import Data.List.Split
+import Data.Maybe
+import Generics.SYB
+import HIndent.Ast.FileHeaderPragma
+import HIndent.Ast.NodeComments
+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
+import HIndent.Pragma
+import HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+newtype FileHeaderPragmaCollection =
+  FileHeaderPragmaCollection [FileHeaderPragma]
+
+instance CommentExtraction FileHeaderPragmaCollection where
+  nodeComments _ = NodeComments [] [] []
+
+instance Pretty FileHeaderPragmaCollection where
+  pretty' (FileHeaderPragmaCollection xs) = lined $ fmap pretty xs
+
+mkFileHeaderPragmaCollection :: GHC.HsModule' -> FileHeaderPragmaCollection
+mkFileHeaderPragmaCollection =
+  FileHeaderPragmaCollection . fmap mkFileHeaderPragma . collectPragmas
+
+hasPragmas :: FileHeaderPragmaCollection -> Bool
+hasPragmas (FileHeaderPragmaCollection xs) = not $ null xs
+
+-- | This function collects pragma comments from the
+-- given module and modifies them into 'String's.
+--
+-- A pragma's name is converted to the @SHOUT_CASE@ (e.g., @lAnGuAgE@ ->
+-- @LANGUAGE@).
+collectPragmas :: GHC.HsModule' -> [String]
+collectPragmas =
+  fmap (uncurry constructPragma)
+    . mapMaybe extractPragma
+    . listify isBlockComment
+    . GHC.getModuleAnn
+
+-- | This function returns a 'Just' value with the pragma
+-- extracted from the passed 'EpaCommentTok' if it has one. Otherwise, it
+-- returns a 'Nothing'.
+extractPragma :: GHC.EpaCommentTok -> Maybe (String, [String])
+extractPragma (GHC.EpaBlockComment c) =
+  second (fmap strip . splitOn ",") <$> extractPragmaNameAndElement c
+  where
+    strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+extractPragma _ = Nothing
+
+-- | Construct a pragma.
+constructPragma :: String -> [String] -> String
+constructPragma optionOrPragma xs =
+  "{-# " ++ fmap toUpper optionOrPragma ++ " " ++ intercalate ", " xs ++ " #-}"
+
+-- | Checks if the given comment is a block one.
+isBlockComment :: GHC.EpaCommentTok -> Bool
+isBlockComment GHC.EpaBlockComment {} = True
+isBlockComment _ = False

src/HIndent/Ast/Import/Collection.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module HIndent.Ast.Import.Collection
+  ( ImportCollection
+  , mkImportCollection
+  , hasImports
+  ) where
+
+import Control.Monad.RWS
+import qualified GHC.Hs as GHC
+import HIndent.Ast.NodeComments
+import HIndent.Config
+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
+import HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.Import
+import HIndent.Pretty.NodeComments
+import HIndent.Printer
+
+newtype ImportCollection =
+  ImportCollection [GHC.LImportDecl GHC.GhcPs]
+
+instance CommentExtraction ImportCollection where
+  nodeComments ImportCollection {} = NodeComments [] [] []
+
+instance Pretty ImportCollection where
+  pretty' (ImportCollection xs) =
+    importDecls >>= blanklined . fmap outputImportGroup
+    where
+      outputImportGroup = lined . fmap pretty
+      importDecls =
+        gets (configSortImports . psConfig) >>= \case
+          True -> pure $ extractImportsSorted' xs
+          False -> pure $ extractImports' xs
+
+mkImportCollection :: GHC.HsModule' -> ImportCollection
+mkImportCollection GHC.HsModule {..} = ImportCollection hsmodImports
+
+hasImports :: ImportCollection -> Bool
+hasImports (ImportCollection xs) = not $ null xs

src/HIndent/Ast/Module.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module HIndent.Ast.Module
+  ( Module
+  , mkModule
+  ) where
+
+import Data.Maybe
+import HIndent.Ast.Declaration.Collection
+import HIndent.Ast.FileHeaderPragma.Collection
+import HIndent.Ast.Import.Collection
+import HIndent.Ast.Module.Declaration
+import HIndent.Ast.NodeComments hiding (fromEpAnn)
+import HIndent.Ast.WithComments
+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
+import HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+data Module = Module
+  { pragmas :: FileHeaderPragmaCollection
+  , moduleDeclaration :: Maybe ModuleDeclaration
+  , imports :: ImportCollection
+  , declarations :: DeclarationCollection
+  }
+
+instance CommentExtraction Module where
+  nodeComments Module {} = NodeComments [] [] []
+
+instance Pretty Module where
+  pretty' Module {..}
+    | isEmpty = pure ()
+    | otherwise = blanklined printers >> newline
+    where
+      isEmpty =
+        not (hasPragmas pragmas)
+          && isNothing moduleDeclaration
+          && not (hasImports imports)
+          && not (hasDeclarations declarations)
+      printers =
+        catMaybes
+          [ toMaybe (hasPragmas pragmas) (pretty pragmas)
+          , fmap pretty moduleDeclaration
+          , toMaybe (hasImports imports) (pretty imports)
+          , toMaybe (hasDeclarations declarations) (pretty declarations)
+          ]
+      toMaybe cond x =
+        if cond
+          then Just x
+          else Nothing
+
+mkModule :: GHC.HsModule' -> WithComments Module
+mkModule m = fromEpAnn (GHC.getModuleAnn m) $ Module {..}
+  where
+    pragmas = mkFileHeaderPragmaCollection m
+    moduleDeclaration = mkModuleDeclaration m
+    imports = mkImportCollection m
+    declarations = mkDeclarationCollection m

src/HIndent/Ast/Module/Declaration.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module HIndent.Ast.Module.Declaration
+  ( ModuleDeclaration
+  , mkModuleDeclaration
+  ) where
+
+import HIndent.Applicative
+import HIndent.Ast.Module.Name
+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')
+  , exports :: Maybe (GHC.LocatedL [GHC.LIE GHC.GhcPs])
+  }
+
+instance CommentExtraction ModuleDeclaration where
+  nodeComments ModuleDeclaration {} = NodeComments [] [] []
+
+instance Pretty ModuleDeclaration where
+  pretty' ModuleDeclaration {..} = do
+    pretty name
+    whenJust warning $ \x -> do
+      space
+      pretty $ fmap ModuleDeprecatedPragma x
+    whenJust exports $ \xs -> do
+      newline
+      indentedBlock $ do
+        printCommentsAnd xs (vTuple . fmap pretty)
+    string " where"
+
+mkModuleDeclaration :: GHC.HsModule' -> Maybe ModuleDeclaration
+mkModuleDeclaration m =
+  case GHC.hsmodName m of
+    Nothing -> Nothing
+    Just name' -> Just ModuleDeclaration {..}
+      where name = mkModuleName <$> fromGenLocated name'
+            warning = GHC.getDeprecMessage m
+            exports = GHC.hsmodExports m

src/HIndent/Ast/Module/Name.hs

@@ -0,0 +1,22 @@
+module HIndent.Ast.Module.Name
+  ( ModuleName
+  , mkModuleName
+  ) where
+
+import qualified GHC.Unit as GHC
+import HIndent.Ast.NodeComments
+import HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+newtype ModuleName =
+  ModuleName String
+
+instance CommentExtraction ModuleName where
+  nodeComments _ = NodeComments [] [] []
+
+instance Pretty ModuleName where
+  pretty' (ModuleName x) = string "module " >> string x
+
+mkModuleName :: GHC.ModuleName -> ModuleName
+mkModuleName = ModuleName . showOutputable