Merge pull request #1544 from ndmitchell/ghc-9.8.1

[ghc-api]: upgrade to ghc-9.8

.github/workflows/ci.yml

@@ -12,12 +12,12 @@ jobs:
       fail-fast: false
       matrix:
         os: [ubuntu-latest]
-        ghc: ['9.6', '9.4', '9.2']
+        ghc: ['9.8', '9.6', '9.4']
         include:
         - os: windows-latest
-          ghc: '9.6'
+          ghc: '9.8'
         - os: macOS-latest
-          ghc: '9.6'
+          ghc: '9.8'
 
     steps:
     - run: git config --global core.autocrlf false

hlint.cabal

@@ -36,7 +36,7 @@ extra-source-files:
 extra-doc-files:
     README.md
     CHANGES.txt
-tested-with:        GHC==9.6, GHC==9.4, GHC==9.2
+tested-with:        GHC==9.8, GHC==9.6, GHC==9.4
 
 source-repository head
     type:     git
@@ -81,16 +81,16 @@ library
         deriving-aeson >= 0.2,
         filepattern >= 0.1.1
 
-    if !flag(ghc-lib) && impl(ghc >= 9.6.1) && impl(ghc < 9.7.0)
+    if !flag(ghc-lib) && impl(ghc >= 9.8.1) && impl(ghc < 9.9.0)
       build-depends:
-        ghc == 9.6.*,
+        ghc == 9.8.*,
         ghc-boot-th,
         ghc-boot
     else
       build-depends:
-          ghc-lib-parser == 9.6.*
+          ghc-lib-parser == 9.8.*
     build-depends:
-        ghc-lib-parser-ex >= 9.6.0.2 && < 9.6.1
+        ghc-lib-parser-ex >= 9.8.0.0 && < 9.8.1
 
     if flag(gpl)
         build-depends: hscolour >= 1.21

src/CmdLine.hs

@@ -12,6 +12,7 @@ import Control.Monad.Extra
 import Control.Exception.Extra
 import Data.ByteString qualified as BS
 import Data.Char
+import Data.List.NonEmpty qualified as NE
 import Data.List.Extra
 import Data.Maybe
 import Data.Functor
@@ -184,7 +185,7 @@ mode = cmdArgsMode $ modes
     ] &= program "hlint" &= verbosity
     &=  summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2024")
     where
-        nam xs = nam_ xs &= name [head xs]
+        nam xs = nam_ xs &= name [NE.head $ NE.fromList xs]
         nam_ xs = def &= explicit &= name xs
 
 -- | Where should we find the configuration files?

src/Config/Yaml.hs

@@ -29,6 +29,7 @@ import GHC.Types.Error hiding (Severity)
 import Config.Type
 import Data.Either.Extra
 import Data.Maybe
+import Data.List.NonEmpty qualified as NE
 import Data.List.Extra
 import Data.Tuple.Extra
 import Control.Monad.Extra
@@ -163,7 +164,7 @@ parseFail (Val focus path) msg = fail $
     -- aim to show a smallish but relevant context
     dotDot (fromMaybe (encode focus) $ listToMaybe $ dropWhile (\x -> BS.length x > 250) $ map encode contexts)
     where
-        (steps, contexts) = unzip $ reverse path
+        (steps, contexts) = Prelude.unzip $ reverse path
         dotDot x = let (a,b) = BS.splitAt 250 x in BS.unpack a ++ (if BS.null b then "" else "...")
 
 parseArray :: Val -> Parser [Val]
@@ -235,7 +236,7 @@ parseGHC parser v = do
     case parser defaultParseFlags{enabledExtensions=configExtensions, disabledExtensions=[]} x of
         POk _ x -> pure x
         PFailed ps ->
-          let errMsg = head . bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages ps)
+          let errMsg = NE.head . NE.fromList . bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages ps)
               msg = showSDoc baseDynFlags $ pprLocMsgEnvelopeDefault errMsg
           in parseFail v $ "Failed to parse " ++ msg ++ ", when parsing:\n " ++ x
 

src/GHC/All.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ViewPatterns #-}
 
@@ -14,6 +15,7 @@ import Control.Monad.Trans.Except
 import Control.Monad.IO.Class
 import Util
 import Data.Char
+import Data.List.NonEmpty qualified as NE
 import Data.List.Extra
 import Timing
 import Language.Preprocessor.Cpphs
@@ -192,12 +194,12 @@ parseModuleEx flags file str = timedIO "Parse" file $ runExceptT $ do
     POk s a -> do
       let errs = bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages s)
       if not $ null errs then
-        ExceptT $ parseFailureErr dynFlags str file str errs
+        ExceptT $ parseFailureErr dynFlags str file str $ NE.fromList errs
       else do
         let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags
         pure $ ModuleEx (applyFixities fixes a)
     PFailed s ->
-      ExceptT $ parseFailureErr dynFlags str file str $ bagToList . getMessages  $ GhcPsMessage <$> snd (getPsMessages s)
+      ExceptT $ parseFailureErr dynFlags str file str $ NE.fromList . bagToList . getMessages  $ GhcPsMessage <$> snd (getPsMessages s)
   where
     -- If parsing pragmas fails, synthesize a parse error from the
     -- error message.
@@ -206,7 +208,7 @@ parseModuleEx flags file str = timedIO "Parse" file $ runExceptT $ do
       in ParseError (mkSrcSpan loc loc) msg src
 
     parseFailureErr dynFlags ppstr file str errs =
-      let errMsg = head errs
+      let errMsg = NE.head errs
           loc = errMsgSpan errMsg
           doc = pprLocMsgEnvelopeDefault errMsg
       in ghcFailOpParseModuleEx ppstr file str (loc, doc)

src/GHC/Util/FreeVars.hs

@@ -122,8 +122,8 @@ instance FreeVars (LocatedA (HsExpr GhcPs)) where
   freeVars (L _ (RecordCon _ _ (HsRecFields flds _))) = Set.unions $ map freeVars flds -- Record construction.
   freeVars (L _ (RecordUpd _ e flds)) =
     case flds of
-      Left fs -> Set.unions $ freeVars e : map freeVars fs
-      Right ps -> Set.unions $ freeVars e : map freeVars ps
+      RegularRecUpdFields _ fs -> Set.unions $ freeVars e : map freeVars fs
+      OverloadedRecUpdFields _ ps -> Set.unions $ freeVars e : map freeVars ps
   freeVars (L _ (HsMultiIf _ grhss)) = free (allVars grhss) -- Multi-way if.
   freeVars (L _ (HsTypedBracket _ e)) = freeVars e
   freeVars (L _ (HsUntypedBracket _ (ExpBr _ e))) = freeVars e
@@ -174,7 +174,7 @@ instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) (
    freeVars o@(L _ (HsFieldBind _ _ x _)) = freeVars x
 
 instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where
-  freeVars (L _ (HsFieldBind _ x _ True)) = Set.singleton $ rdrNameOcc $ rdrNameAmbiguousFieldOcc $ unLoc x -- a pun
+  freeVars (L _ (HsFieldBind _ x _ True)) = Set.singleton $ rdrNameOcc $ ambiguousFieldOccRdrName $ unLoc x -- a pun
   freeVars (L _ (HsFieldBind _ _ x _)) = freeVars x
 
 instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) (LocatedA (HsExpr GhcPs)))) where

src/GHC/Util/HsExpr.hs

@@ -58,7 +58,7 @@ dotApps (x : xs) = dotApp x (dotApps xs)
 
 -- | @lambda [p0, p1..pn] body@ makes @\p1 p1 .. pn -> body@
 lambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
-lambda vs body = noLocA $ HsLam noExtField (MG Generated (noLocA [noLocA $ Match EpAnnNotUsed LambdaExpr vs (GRHSs emptyComments [noLocA $ GRHS EpAnnNotUsed [] body] (EmptyLocalBinds noExtField))]))
+lambda vs body = noLocA $ HsLam noExtField (MG (Generated DoPmc) (noLocA [noLocA $ Match EpAnnNotUsed LambdaExpr vs (GRHSs emptyComments [noLocA $ GRHS EpAnnNotUsed [] body] (EmptyLocalBinds noExtField))]))
 
 -- | 'paren e' wraps 'e' in parens if 'e' is non-atomic.
 paren :: LHsExpr GhcPs -> LHsExpr GhcPs
@@ -242,7 +242,7 @@ niceLambdaR ss e =
   let grhs = noLocA $ GRHS EpAnnNotUsed [] e :: LGRHS GhcPs (LHsExpr GhcPs)
       grhss = GRHSs {grhssExt = emptyComments, grhssGRHSs=[grhs], grhssLocalBinds=EmptyLocalBinds noExtField}
       match = noLocA $ Match {m_ext=EpAnnNotUsed, m_ctxt=LambdaExpr, m_pats=map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs)
-      matchGroup = MG {mg_ext=Generated, mg_alts=noLocA [match]}
+      matchGroup = MG {mg_ext=Generated DoPmc, mg_alts=noLocA [match]}
   in (noLocA $ HsLam noExtField matchGroup, const [])
 
 
@@ -252,7 +252,7 @@ replaceBranches :: LHsExpr GhcPs -> ([LHsExpr GhcPs], [LHsExpr GhcPs] -> LHsExpr
 replaceBranches (L l (HsIf _ a b c)) = ([b, c], \[b, c] -> L l (HsIf EpAnnNotUsed a b c))
 
 replaceBranches (L s (HsCase _ a (MG FromSource (L l bs)))) =
-  (concatMap f bs, L s . HsCase EpAnnNotUsed a . MG Generated . L l . g bs)
+  (concatMap f bs, L s . HsCase EpAnnNotUsed a . MG (Generated DoPmc). L l . g bs)
   where
     f :: LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs]
     f (L _ (Match _ CaseAlt _ (GRHSs _ xs _))) = [x | (L _ (GRHS _ _ x)) <- xs]

src/Hint/Export.hs

@@ -23,7 +23,7 @@ import GHC.Types.Name.Reader
 exportHint :: ModuHint
 exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) )
   | Nothing <- exports =
-      let r = o{ hsmodExports = Just (noLocA [noLocA (IEModuleContents EpAnnNotUsed name)] )} in
+      let r = o{ hsmodExports = Just (noLocA [noLocA (IEModuleContents (Nothing, EpAnnNotUsed) name)] )} in
       [(ignore "Use module export list" (L s o) (noLoc r) []){ideaNote = [Note "an explicit list is usually better"]}]
   | Just (L _ xs) <- exports
   , mods <- [x | x <- xs, isMod x]
@@ -32,7 +32,7 @@ exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = ex
   , exports' <- [x | x <- xs, not (matchesModName modName x)]
   , modName `elem` names =
       let dots = mkRdrUnqual (mkVarOcc " ... ")
-          r = o{ hsmodExports = Just (noLocA (noLocA (IEVar noExtField (noLocA (IEName noExtField (noLocA dots)))) : exports') )}
+          r = o{ hsmodExports = Just (noLocA (noLocA (IEVar Nothing (noLocA (IEName noExtField (noLocA dots)))) : exports') )}
       in
         [ignore "Use explicit module export list" (L s o) (noLoc r) []]
       where

src/Hint/Extensions.hs

@@ -274,6 +274,7 @@ import Refact.Types
 import Data.Set qualified as Set
 import Data.Map qualified as Map
 
+import GHC.Data.FastString
 import GHC.Types.SrcLoc
 import GHC.Types.SourceText
 import GHC.Hs
@@ -492,8 +493,8 @@ used MultiWayIf = hasS isMultiIf
 used NumericUnderscores = hasS f
   where
     f :: OverLitVal -> Bool
-    f (HsIntegral (IL (SourceText t) _ _)) = '_' `elem` t
-    f (HsFractional (FL (SourceText t) _ _ _ _)) = '_' `elem` t
+    f (HsIntegral (IL (SourceText t) _ _)) = '_' `elem` unpackFS t
+    f (HsFractional (FL (SourceText t) _ _ _ _)) = '_' `elem` unpackFS t
     f _ = False
 
 used LambdaCase = hasS isLCase

src/Hint/Lambda.hs

@@ -170,7 +170,7 @@ lambdaBind
     where
           reform :: [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
           reform ps b = L (combineSrcSpans (locA loc1) (locA loc2)) $ ValD noExtField $
-             origBind {fun_matches = MG Generated (noLocA [noLocA $ Match EpAnnNotUsed ctxt ps $ GRHSs emptyComments [noLocA $ GRHS EpAnnNotUsed [] b] $ EmptyLocalBinds noExtField])}
+             origBind {fun_matches = MG (Generated DoPmc) (noLocA [noLocA $ Match EpAnnNotUsed ctxt ps $ GRHSs emptyComments [noLocA $ GRHS EpAnnNotUsed [] b] $ EmptyLocalBinds noExtField])}
 
           mkSubtsAndTpl newPats newBody = (sub, tpl)
             where

src/Hint/List.hs

@@ -44,6 +44,7 @@ module Hint.List(listHint) where
 
 import Control.Applicative
 import Data.Generics.Uniplate.DataOnly
+import Data.List.NonEmpty qualified as NE
 import Data.List.Extra
 import Data.Maybe
 import Prelude
@@ -103,9 +104,9 @@ listComp _ = []
 
 listCompCheckGuards :: LHsExpr GhcPs -> HsDoFlavour -> [ExprLStmt GhcPs] -> [Idea]
 listCompCheckGuards o ctx stmts =
-  let revs = reverse stmts
-      e@(L _ LastStmt{}) = head revs -- In a ListComp, this is always last.
-      xs = reverse (tail revs) in
+  let revs = NE.reverse $ NE.fromList stmts
+      e@(L _ LastStmt{}) = NE.head revs -- In a ListComp, this is always last.
+      xs = reverse (NE.tail revs) in
   list_comp_aux e xs
   where
     list_comp_aux e xs
@@ -128,10 +129,10 @@ listCompCheckMap ::
 listCompCheckMap o mp f ctx stmts  | varToStr mp == "map" =
     [suggest "Move map inside list comprehension" (reLoc o) (reLoc o2) (suggestExpr o o2)]
     where
-      revs = reverse stmts
-      L _ (LastStmt _ body b s) = head revs -- In a ListComp, this is always last.
+      revs = NE.reverse $ NE.fromList stmts
+      L _ (LastStmt _ body b s) = NE.head revs -- In a ListComp, this is always last.
       last = noLocA $ LastStmt noExtField (noLocA $ HsApp EpAnnNotUsed (paren f) (paren body)) b s
-      o2 =noLocA $ HsDo EpAnnNotUsed ctx (noLocA $ reverse (tail revs) ++ [last])
+      o2 =noLocA $ HsDo EpAnnNotUsed ctx (noLocA $ reverse (NE.tail revs) ++ [last])
 listCompCheckMap _ _ _ _ _ = []
 
 suggestExpr :: LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring R.SrcSpan]
@@ -162,15 +163,15 @@ listExp :: Bool -> Bool -> LHsExpr GhcPs -> [Idea]
 listExp overloadedListsOn b (fromParen -> x) =
   if null res
     then concatMap (listExp overloadedListsOn $ isAppend x) $ children x
-    else [head res]
+    else [NE.head $ NE.fromList res]
   where
     res = [suggest name (reLoc x) (reLoc x2) [r]
           | (name, f) <- checks overloadedListsOn
           , Just (x2, subts, temp) <- [f b x]
           , let r = Replace Expr (toSSA x) subts temp ]
 
 listPat :: LPat GhcPs -> [Idea]
-listPat x = if null res then concatMap listPat $ children x else [head res]
+listPat x = if null res then concatMap listPat $ children x else [NE.head $ NE.fromList res]
     where res = [suggest name (reLoc x) (reLoc x2) [r]
                   | (name, f) <- pchecks
                   , Just (x2, subts, temp) <- [f x]

src/Hint/ListRec.hs

@@ -176,7 +176,7 @@ findCase x = do
       gRHS e = noLocA $ GRHS EpAnnNotUsed [] e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs.
       gRHSSs e = GRHSs emptyComments [gRHS e] emptyLocalBinds -- Guarded rhs set.
       match e = Match{m_ext=EpAnnNotUsed,m_pats=ps12, m_grhss=gRHSSs e, ..} -- Match.
-      matchGroup e = MG{mg_alts=noLocA [noLocA $ match e], mg_ext=Generated, ..} -- Match group.
+      matchGroup e = MG{mg_alts=noLocA [noLocA $ match e], mg_ext=Generated DoPmc, ..} -- Match group.
       funBind e = FunBind {fun_matches=matchGroup e, ..} :: HsBindLR GhcPs GhcPs -- Fun bind.
 
   pure (ListCase ps b1 (x, xs, b2), noLocA . ValD noExtField . funBind)

src/Hint/Monad.hs

@@ -298,7 +298,7 @@ monadLet xs = mapMaybe mkLet xs
             grhs = noLocA (GRHS EpAnnNotUsed [] rhs)
             grhss = GRHSs emptyComments [grhs] (EmptyLocalBinds noExtField)
             match = noLocA $ Match EpAnnNotUsed (FunRhs p Prefix NoSrcStrict) [] grhss
-            fb = noLocA $ FunBind noExtField p (MG Generated (noLocA [match]))
+            fb = noLocA $ FunBind noExtField p (MG (Generated DoPmc) (noLocA [match]))
             binds = unitBag fb
             valBinds = ValBinds NoAnnSortKey binds []
             localBinds = HsValBinds EpAnnNotUsed valBinds

src/Hint/Naming.hs

@@ -102,7 +102,7 @@ shortenLGRHS (L locGRHS (GRHS ttg0 guards (L locExpr _))) =
     L locGRHS (GRHS ttg0 guards (L locExpr dots))
     where
         dots :: HsExpr GhcPs
-        dots = HsLit EpAnnNotUsed (HsString (SourceText "...") (mkFastString "..."))
+        dots = HsLit EpAnnNotUsed (HsString (SourceText (fsLit "...")) (fsLit "..."))
 
 getNames :: LHsDecl GhcPs -> [String]
 getNames decl = maybeToList (declName decl) ++ getConstructorNames (unLoc decl)

src/Hint/Negation.hs

@@ -45,7 +45,7 @@ negationParensHint _ _ x =
 negatedOp :: LHsExpr GhcPs -> [Idea]
 negatedOp e =
   case e of
-    L b1 (NegApp a1 inner@(L _ (OpApp {})) a2) ->
+    L b1 (NegApp a1 inner@(L _ OpApp {}) a2) ->
       pure $
         rawIdea
           Suggestion

src/Hint/NumLiteral.hs

@@ -22,6 +22,7 @@
 module Hint.NumLiteral (numLiteralHint) where
 
 import GHC.Hs
+import GHC.Data.FastString
 import GHC.LanguageExtensions.Type (Extension (..))
 import GHC.Types.SrcLoc
 import GHC.Types.SourceText
@@ -49,18 +50,20 @@ numLiteralHint _ modu =
 
 suggestUnderscore :: LHsExpr GhcPs -> [Idea]
 suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsIntegral intLit@(IL (SourceText srcTxt) _ _))))) =
-  [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` srcTxt, srcTxt /= underscoredSrcTxt ]
+  [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` srcTxt', srcTxt' /= underscoredSrcTxt ]
   where
-    underscoredSrcTxt = addUnderscore srcTxt
+    srcTxt' = unpackFS srcTxt
+    underscoredSrcTxt = addUnderscore srcTxt'
     y :: LocatedAn an (HsExpr GhcPs)
-    y = noLocA $ HsOverLit EpAnnNotUsed $ ol{ol_val = HsIntegral intLit{il_text = SourceText underscoredSrcTxt}}
+    y = noLocA $ HsOverLit EpAnnNotUsed $ ol{ol_val = HsIntegral intLit{il_text = SourceText (fsLit underscoredSrcTxt)}}
     r = Replace Expr (toSSA x) [("a", toSSA y)] "a"
 suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsFractional fracLit@(FL (SourceText srcTxt) _ _ _ _))))) =
-  [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` srcTxt, srcTxt /= underscoredSrcTxt ]
+  [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` srcTxt', srcTxt' /= underscoredSrcTxt ]
   where
-    underscoredSrcTxt = addUnderscore srcTxt
+    srcTxt' = unpackFS srcTxt
+    underscoredSrcTxt = addUnderscore srcTxt'
     y :: LocatedAn an (HsExpr GhcPs)
-    y = noLocA $ HsOverLit EpAnnNotUsed $ ol{ol_val = HsFractional fracLit{fl_text = SourceText underscoredSrcTxt}}
+    y = noLocA $ HsOverLit EpAnnNotUsed $ ol{ol_val = HsFractional fracLit{fl_text = SourceText (fsLit underscoredSrcTxt)}}
     r = Replace Expr (toSSA x) [("a", toSSA y)] "a"
 suggestUnderscore _ = mempty
 

src/Hint/Unsafe.hs

@@ -60,13 +60,15 @@ unsafeHint _ (ModuleEx (L _ m)) = \ld@(L loc d) ->
      -- 'x' is not marked 'NOINLINE'.
      , x `notElem` noinline]
   where
+    noInline :: FastString
+    noInline = fsLit "{-# NOINLINE"
     gen :: OccName -> LHsDecl GhcPs
     gen x = noLocA $
       SigD noExtField (InlineSig EpAnnNotUsed (noLocA (mkRdrUnqual x))
-                      (InlinePragma (SourceText "{-# NOINLINE") (NoInline (SourceText "{-# NOINLINE")) Nothing NeverActive FunLike))
+                      (InlinePragma (SourceText noInline) (NoInline (SourceText noInline)) Nothing NeverActive FunLike))
     noinline :: [OccName]
     noinline = [q | L _(SigD _ (InlineSig _ (L _ (Unqual q))
-                                                (InlinePragma _ (NoInline (SourceText "{-# NOINLINE")) Nothing NeverActive FunLike))
+                                                (InlinePragma _ (NoInline (SourceText noInline)) Nothing NeverActive FunLike))
         ) <- hsmodDecls m]
 
 isUnsafeDecl :: HsDecl GhcPs -> Bool

src/Refact.hs

@@ -10,6 +10,7 @@ module Refact
 
 import Control.Exception.Extra
 import Control.Monad
+import Data.List.NonEmpty qualified as NE
 import Data.Maybe
 import Data.Version.Extra
 import GHC.LanguageExtensions.Type
@@ -58,7 +59,7 @@ refactorPath rpath = do
     mexc <- findExecutable excPath
     case mexc of
         Just exc -> do
-            ver <- readVersion . tail <$> readProcess exc ["--version"] ""
+            ver <- readVersion . NE.tail . NE.fromList <$> readProcess exc ["--version"] ""
             pure $ if ver >= minRefactorVersion
                        then Right exc
                        else Left $ "Your version of refactor is too old, please install apply-refact "