Add GHC 9.8.1 to the cabal CI (#775)

* Add GHC 9.8.1 to the cabal CI Signed-off-by: Mihai Maruseac <[email protected]> * Bump `ghc-lib-parser` upper bound Signed-off-by: Mihai Maruseac <[email protected]> * At least fix all compile errors * Fix * Remove unused functions * Fix compile errors * Fix * Format * Pass the test * Fix a merging issue * Format * Pass tests --------- Signed-off-by: Mihai Maruseac <[email protected]> Co-authored-by: Hiroki Tokunaga <[email protected]>
mihaimaruseac · Nov 12, 2023 · 39091d2 · 39091d2
1 parent 3f06de6
commit 39091d2
Show file tree

Hide file tree

Showing 7 changed files with 150 additions and 20 deletions.
diff --git a/.github/workflows/presubmit-cabal.yaml b/.github/workflows/presubmit-cabal.yaml
@@ -17,7 +17,7 @@ jobs:
       fail-fast: false # don't cancel other jobs if one fails
       matrix:
         os: [ubuntu-latest, macos-latest, windows-latest]
-        ghc: [8.10.7, 9.0.2, 9.2.8, 9.4.7, 9.6.3]
+        ghc: [8.10.7, 9.0.2, 9.2.8, 9.4.7, 9.6.3, 9.8.1]
     defaults:
       run:
         # The default shell on Windows is `pwsh`. However, it doesn't expand

diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -4,6 +4,8 @@
 
 ### Added
 
+- Support for GHC 9.8 ([#775]).
+
 ### Changed
 
 ### Fixed
@@ -368,6 +370,7 @@ This version is accidentally pushlished, and is the same as 5.3.3.
 
 [#784]: https://github.com/mihaimaruseac/hindent/pull/784
 [#780]: https://github.com/mihaimaruseac/hindent/pull/780
+[#775]: https://github.com/mihaimaruseac/hindent/pull/775
 [#750]: https://github.com/mihaimaruseac/hindent/pull/750
 [#742]: https://github.com/mihaimaruseac/hindent/pull/742
 [#741]: https://github.com/mihaimaruseac/hindent/pull/741

diff --git a/hindent.cabal b/hindent.cabal
@@ -86,7 +86,7 @@ library
     , directory
     , exceptions
     , filepath
-    , ghc-lib-parser >=9.2 && <9.7
+    , ghc-lib-parser >=9.2 && <9.9
     , ghc-lib-parser-ex
     , monad-loops
     , mtl
@@ -121,7 +121,7 @@ library hindent-internal
     , directory
     , exceptions
     , filepath
-    , ghc-lib-parser >=9.2 && <9.7
+    , ghc-lib-parser >=9.2 && <9.9
     , ghc-lib-parser-ex
     , monad-loops
     , mtl
@@ -154,7 +154,7 @@ executable hindent
     , directory
     , exceptions
     , filepath
-    , ghc-lib-parser >=9.2 && <9.7
+    , ghc-lib-parser >=9.2 && <9.9
     , ghc-lib-parser-ex
     , hindent
     , monad-loops
@@ -190,7 +190,7 @@ test-suite hindent-test
     , directory
     , exceptions
     , filepath
-    , ghc-lib-parser >=9.2 && <9.7
+    , ghc-lib-parser >=9.2 && <9.9
     , ghc-lib-parser-ex
     , hindent
     , hindent-internal
@@ -229,7 +229,7 @@ benchmark hindent-bench
     , directory
     , exceptions
     , filepath
-    , ghc-lib-parser >=9.2 && <9.7
+    , ghc-lib-parser >=9.2 && <9.9
     , ghc-lib-parser-ex
     , hindent
     , hindent-internal

diff --git a/package.yaml b/package.yaml
@@ -34,7 +34,7 @@ dependencies:
   - directory
   - exceptions
   - filepath
-  - ghc-lib-parser >= 9.2 && < 9.7
+  - ghc-lib-parser >= 9.2 && < 9.9
   - ghc-lib-parser-ex
   - monad-loops
   - mtl

diff --git a/src/HIndent/Parse.hs b/src/HIndent/Parse.hs
@@ -20,6 +20,9 @@ import HIndent.GhcLibParserWrapper.GHC.Hs
 import GHC.Utils.Error
 import GHC.Utils.Outputable hiding ((<>), empty, text)
 #endif
+#if MIN_VERSION_ghc_lib_parser(9,8,1)
+import GHC.Unit.Module.Warnings
+#endif
 -- | This function parses the given Haskell source code with the given file
 -- path (if any) and parse options.
 parseModule ::
@@ -49,7 +52,30 @@ lexCode code
 -- The 'StarIsType' extension is always enabled to compile a code using
 -- kinds like '* -> *'.
 parserOptsFromExtensions :: [GLP.Extension] -> ParserOpts
-#if MIN_VERSION_ghc_lib_parser(9,4,1)
+#if MIN_VERSION_ghc_lib_parser(9,8,1)
+parserOptsFromExtensions opts =
+  mkParserOpts
+    opts'
+    diagOpts
+    [] -- There are no supported languages and extensions (this list is used only in error messages)
+    False -- Safe imports are off.
+    False -- Haddock comments are treated as normal comments.
+    True -- Comments are kept in an AST.
+    False -- Do not update the internal position of a comment.
+  where
+    opts' = ES.fromList $ GLP.StarIsType : opts
+    diagOpts =
+      DiagOpts
+        { diag_warning_flags = ES.empty
+        , diag_fatal_warning_flags = ES.empty
+        , diag_custom_warning_categories = emptyWarningCategorySet
+        , diag_fatal_custom_warning_categories = emptyWarningCategorySet
+        , diag_warn_is_error = False
+        , diag_reverse_errors = False
+        , diag_max_errors = Nothing
+        , diag_ppr_ctx = defaultSDocContext
+        }
+#elif MIN_VERSION_ghc_lib_parser(9,4,1)
 parserOptsFromExtensions opts =
   mkParserOpts
     opts'

diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs
@@ -782,7 +782,33 @@ prettyHsExpr (RecordCon _ name fields) = horizontal <-|> vertical
     vertical = do
       pretty name
       (space >> pretty fields) <-|> (newline >> indentedBlock (pretty fields))
-#if MIN_VERSION_ghc_lib_parser(9,4,1)
+#if MIN_VERSION_ghc_lib_parser(9,8,1)
+prettyHsExpr (RecordUpd _ name fields) = hor <-|> ver
+  where
+    hor = spaced [pretty name, printHorFields fields]
+    ver = do
+      pretty name
+      newline
+      indentedBlock $ printHorFields fields <-|> printVerFields fields
+    printHorFields RegularRecUpdFields {..} =
+      hFields $ fmap (`printCommentsAnd` horField) recUpdFields
+    printHorFields OverloadedRecUpdFields {..} =
+      hFields $ fmap (`printCommentsAnd` horField) olRecUpdFields
+    printVerFields RegularRecUpdFields {..} =
+      vFields $ fmap printField recUpdFields
+    printVerFields OverloadedRecUpdFields {..} =
+      vFields $ fmap printField olRecUpdFields
+    printField x = printCommentsAnd x $ (<-|>) <$> horField <*> verField
+    horField HsFieldBind {..} = do
+      pretty hfbLHS
+      string " = "
+      pretty hfbRHS
+    verField HsFieldBind {..} = do
+      pretty hfbLHS
+      string " ="
+      newline
+      indentedBlock $ pretty hfbRHS
+#elif MIN_VERSION_ghc_lib_parser(9,4,1)
 prettyHsExpr (RecordUpd _ name fields) = hor <-|> ver
   where
     hor = spaced [pretty name, either printHorFields printHorFields fields]
@@ -1293,7 +1319,11 @@ prettyHsType x@(HsAppTy _ l r) = hor <-|> ver
   where
     hor = spaced $ fmap pretty [l, r]
     ver = pretty $ HsTypeWithVerticalAppTy x
+#if MIN_VERSION_ghc_lib_parser(9,8,1)
+prettyHsType (HsAppKindTy _ l _ r) = pretty l >> string " @" >> pretty r
+#else
 prettyHsType (HsAppKindTy _ l r) = pretty l >> string " @" >> pretty r
+#endif
 prettyHsType (HsFunTy _ _ a b) = (pretty a >> string " -> ") |=> pretty b
 prettyHsType (HsListTy _ xs) = brackets $ pretty xs
 prettyHsType (HsTupleTy _ HsUnboxedTuple []) = string "(# #)"
@@ -2038,15 +2068,25 @@ instance Pretty FamEqn' where
         case famEqnFor of
           DataFamInstDeclForTopLevel -> "data instance"
           DataFamInstDeclForInsideClassInst -> "data"
-
 -- | HsArg (LHsType GhcPs) (LHsType GhcPs)
+#if MIN_VERSION_ghc_lib_parser(9,8,1)
+instance Pretty
+           (HsArg
+              GhcPs
+              (GenLocated SrcSpanAnnA (HsType GhcPs))
+              (GenLocated SrcSpanAnnA (HsType GhcPs))) where
+  pretty' (HsValArg x) = pretty x
+  pretty' (HsTypeArg _ x) = string "@" >> pretty x
+  pretty' HsArgPar {} = notUsedInParsedStage
+#else
 instance Pretty
            (HsArg
               (GenLocated SrcSpanAnnA (HsType GhcPs))
               (GenLocated SrcSpanAnnA (HsType GhcPs))) where
   pretty' (HsValArg x) = pretty x
   pretty' (HsTypeArg _ x) = string "@" >> pretty x
   pretty' HsArgPar {} = notUsedInParsedStage
+#endif
 #if MIN_VERSION_ghc_lib_parser(9,4,1)
 instance Pretty (HsQuote GhcPs) where
   pretty' (ExpBr _ x) = brackets $ wrapWithBars $ pretty x
@@ -2065,6 +2105,21 @@ instance Pretty (WarnDecls GhcPs) where
 instance Pretty (WarnDecls GhcPs) where
   pretty' (Warnings _ _ x) = lined $ fmap pretty x
 #endif
+#if MIN_VERSION_ghc_lib_parser(9,8,1)
+instance Pretty (WarnDecl GhcPs) where
+  pretty' (Warning _ names deprecatedOrWarning) =
+    case deprecatedOrWarning of
+      DeprecatedTxt _ reasons -> prettyWithTitleReasons "DEPRECATED" reasons
+      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 (WarnDecl GhcPs) where
   pretty' (Warning _ names deprecatedOrWarning) =
     case deprecatedOrWarning of
@@ -2078,6 +2133,7 @@ instance Pretty (WarnDecl GhcPs) where
               [hCommaSep $ fmap pretty names, hCommaSep $ fmap pretty reasons]
           , string " #-}"
           ]
+#endif
 #if MIN_VERSION_ghc_lib_parser(9,4,1)
 instance Pretty (WithHsDocIdentifiers StringLiteral GhcPs) where
   pretty' WithHsDocIdentifiers {..} = pretty hsDocString
@@ -2203,19 +2259,28 @@ instance Pretty (ForeignDecl GhcPs) where
       , string "::"
       , pretty fd_sig_ty
       ]
-#if MIN_VERSION_ghc_lib_parser(9,6,1)
+#if MIN_VERSION_ghc_lib_parser(9,8,0)
 instance Pretty (ForeignImport GhcPs) where
   pretty' (CImport (L _ (SourceText s)) conv safety _ _) =
-    spaced [pretty conv, pretty safety, string s]
+    spaced [pretty conv, pretty safety, output s]
   pretty' (CImport _ conv safety _ _) = spaced [pretty conv, pretty safety]
+#elif MIN_VERSION_ghc_lib_parser(9,6,0)
+instance Pretty (ForeignImport GhcPs) where
+  pretty' (CImport (L _ (SourceText s)) conv safety _ _ ) =
+    spaced [pretty conv, pretty safety, string s]
+  pretty' (CImport _ conv safety _  _) = spaced [pretty conv, pretty safety]
 #else
 instance Pretty ForeignImport where
   pretty' (CImport conv safety _ _ (L _ (SourceText s))) =
     spaced [pretty conv, pretty safety, string s]
   pretty' (CImport conv safety _ _ _) = spaced [pretty conv, pretty safety]
 #endif
 
-#if MIN_VERSION_ghc_lib_parser(9,6,1)
+#if MIN_VERSION_ghc_lib_parser(9,8,0)
+instance Pretty (ForeignExport GhcPs) where
+  pretty' (CExport (L _ (SourceText s)) conv) = spaced [pretty conv, output s]
+  pretty' (CExport _ conv) = pretty conv
+#elif MIN_VERSION_ghc_lib_parser(9,6,0)
 instance Pretty (ForeignExport GhcPs) where
   pretty' (CExport (L _ (SourceText s)) conv) = spaced [pretty conv, string s]
   pretty' (CExport _ conv) = pretty conv
@@ -2344,11 +2409,15 @@ instance Pretty OverLitVal where
   pretty' (HsIntegral x) = pretty x
   pretty' (HsFractional x) = pretty x
   pretty' (HsIsString _ x) = string $ unpackFS x
-
+#if MIN_VERSION_ghc_lib_parser(9,8,1)
+instance Pretty IntegralLit where
+  pretty' IL {il_text = SourceText s} = output s
+  pretty' IL {..} = string $ show il_value
+#else
 instance Pretty IntegralLit where
   pretty' IL {il_text = SourceText s} = string s
   pretty' IL {..} = string $ show il_value
-
+#endif
 instance Pretty FractionalLit where
   pretty' = output
 
@@ -2538,13 +2607,19 @@ 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 _ _ xs)) =
+    spaced [string "{-# WARNING", spaced $ fmap pretty xs, string "#-}"]
+  pretty' (ModuleDeprecatedPragma (DeprecatedTxt _ xs)) =
+    spaced [string "{-# DEPRECATED", spaced $ fmap pretty xs, 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 "#-}"]
-
+#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
@@ -620,7 +620,17 @@ instance CommentExtraction ModuleName where
 
 instance CommentExtraction ModuleNameWithPrefix where
   nodeComments ModuleNameWithPrefix {} = emptyNodeComments
-
+#if MIN_VERSION_ghc_lib_parser(9,8,1)
+instance CommentExtraction (IE GhcPs) where
+  nodeComments IEVar {} = emptyNodeComments
+  nodeComments (IEThingAbs (_, x) _) = nodeComments x
+  nodeComments (IEThingAll (_, x) _) = nodeComments x
+  nodeComments (IEThingWith (_, x) _ _ _) = nodeComments x
+  nodeComments (IEModuleContents (_, x) _) = nodeComments x
+  nodeComments IEGroup {} = emptyNodeComments
+  nodeComments IEDoc {} = emptyNodeComments
+  nodeComments IEDocNamed {} = emptyNodeComments
+#else
 instance CommentExtraction (IE GhcPs) where
   nodeComments IEVar {} = emptyNodeComments
   nodeComments (IEThingAbs x _) = nodeComments x
@@ -630,7 +640,7 @@ instance CommentExtraction (IE GhcPs) where
   nodeComments IEGroup {} = emptyNodeComments
   nodeComments IEDoc {} = emptyNodeComments
   nodeComments IEDocNamed {} = emptyNodeComments
-
+#endif
 instance CommentExtraction
            (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))) where
   nodeComments FamEqn {..} = nodeComments feqn_ext
@@ -641,15 +651,25 @@ instance CommentExtraction FamEqn' where
 -- | Pretty-print a data instance.
 instance CommentExtraction (FamEqn GhcPs (HsDataDefn GhcPs)) where
   nodeComments FamEqn {..} = nodeComments feqn_ext
-
 -- | HsArg (LHsType GhcPs) (LHsType GhcPs)
+#if MIN_VERSION_ghc_lib_parser(9,8,1)
 instance CommentExtraction
            (HsArg
+              GhcPs
               (GenLocated SrcSpanAnnA (HsType GhcPs))
               (GenLocated SrcSpanAnnA (HsType GhcPs))) where
   nodeComments HsValArg {} = emptyNodeComments
   nodeComments HsTypeArg {} = emptyNodeComments
   nodeComments HsArgPar {} = emptyNodeComments
+#else
+instance CommentExtraction
+           (HsArg
+              (GenLocated SrcSpanAnnA (HsType GhcPs))
+              (GenLocated SrcSpanAnnA (HsType GhcPs))) where
+  nodeComments HsValArg {} = emptyNodeComments
+  nodeComments HsTypeArg {} = emptyNodeComments
+  nodeComments HsArgPar {} = emptyNodeComments
+#endif
 #if MIN_VERSION_ghc_lib_parser(9,4,1)
 instance CommentExtraction (HsQuote GhcPs) where
   nodeComments ExpBr {} = emptyNodeComments
@@ -967,6 +987,12 @@ instance CommentExtraction (HsUntypedSplice GhcPs) where
   nodeComments (HsUntypedSpliceExpr x _) = nodeComments x
   nodeComments HsQuasiQuote {} = emptyNodeComments
 #endif
+
+#if MIN_VERSION_ghc_lib_parser(9,8,1)
+instance CommentExtraction (LHsRecUpdFields GhcPs) where
+  nodeComments RegularRecUpdFields {} = emptyNodeComments
+  nodeComments OverloadedRecUpdFields {} = emptyNodeComments
+#endif
 -- | Marks an AST node as never appearing in the AST.
 --
 -- Some AST node types are only used in the renaming or type-checking phase.