upgrade to ghc-9.4 parse tree

.github/workflows/ci.yml

@@ -13,12 +13,16 @@ jobs:
       matrix:
         os: [ubuntu-latest]
         # GHC 9.2.1 had a bug, so we treat it differently to 9.2.2
-        ghc: ['9.2', '9.2.1', '9.0', '8.10']
+        ghc: ['9.2', '9.2.1', '9.0']
         include:
         - os: windows-latest
           ghc: '9.2'
         - os: macOS-latest
-          ghc: '9.2'
+          # GHC 9.2.2 afflicted with a hadrian bug that results in
+          # 'ffitarget_XXX.h' file not found errors that manifest
+          # building ghc-lib-parser (see issue
+          # https://gitlab.haskell.org/ghc/ghc/-/issues/20592)
+          ghc: '9.2.3'
 
     steps:
     - run: git config --global core.autocrlf false

.gitignore

@@ -7,7 +7,7 @@ TAGS
 /.hpc/
 /.stack-work/
 /cc/.stack-work/
-stack.yaml.lock
+stack*.yaml.lock
 /issues/
 /Sample.hs
 /hlint.prof

hints.md

@@ -1420,13 +1420,13 @@ Example:
 </pre>
 Found:
 <pre>
-{-# LANGUAGE RebindableSyntax #-}
 {-# LANGUAGE EmptyCase, RebindableSyntax #-}
+{-# LANGUAGE RebindableSyntax #-}
 
 </pre>
 Suggestion:
 <code>
-{-# LANGUAGE RebindableSyntax, EmptyCase #-}
+{-# LANGUAGE EmptyCase, RebindableSyntax #-}
 </code>
 <br>
 </td>

hlint.cabal

@@ -53,7 +53,7 @@ flag gpl
     description: Use GPL libraries, specifically hscolour
 
 flag ghc-lib
-  default: False
+  default: True
   manual: True
   description: Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported
 
@@ -81,16 +81,16 @@ library
         deriving-aeson >= 0.2,
         filepattern >= 0.1.1
 
-    if !flag(ghc-lib) && impl(ghc >= 9.2.2) && impl(ghc < 9.3.0)
+    if !flag(ghc-lib) && impl(ghc >= 9.4.1) && impl(ghc < 9.5.0)
       build-depends:
-        ghc == 9.2.*,
+        ghc == 9.4.*,
         ghc-boot-th,
         ghc-boot
     else
       build-depends:
-          ghc-lib-parser == 9.2.*
+          ghc-lib-parser == 9.4.*
     build-depends:
-        ghc-lib-parser-ex >= 9.2.0.3 && < 9.2.1
+        ghc-lib-parser-ex >= 9.4.0.0 && < 9.4.1
 
     if flag(gpl)
         build-depends: hscolour >= 1.21

src/Config/Compute.hs

@@ -63,7 +63,7 @@ findExp name vs (HsLam _ MG{mg_alts=L _ [L _ Match{m_pats, m_grhss=GRHSs{grhssGR
 findExp name vs HsLam{} = []
 findExp name vs HsVar{} = []
 findExp name vs (OpApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $
-    HsApp EpAnnNotUsed x $ noLocA $ HsPar EpAnnNotUsed $ noLocA $ HsApp EpAnnNotUsed y $ noLocA $ mkVar "_hlint"
+    HsApp EpAnnNotUsed x $ nlHsPar $ noLocA $ HsApp EpAnnNotUsed y $ noLocA $ mkVar "_hlint"
 
 findExp name vs bod = [SettingMatchExp $
         HintRule Warning defaultHintName []
@@ -74,7 +74,7 @@ findExp name vs bod = [SettingMatchExp $
 
         rep = zip vs $ map (mkVar . pure) ['a'..]
         f (HsVar _ x) | Just y <- lookup (rdrNameStr x) rep = y
-        f (OpApp _ x dol y) | isDol dol = HsApp EpAnnNotUsed x $ noLocA $ HsPar EpAnnNotUsed y
+        f (OpApp _ x dol y) | isDol dol = HsApp EpAnnNotUsed x $ nlHsPar y
         f x = x
 
 

src/Config/Haskell.hs

@@ -23,6 +23,7 @@ import GHC.Hs.Lit
 import GHC.Data.FastString
 import GHC.Parser.Annotation
 import GHC.Utils.Outputable
+import qualified GHC.Data.Strict
 
 import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
 import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
@@ -43,7 +44,7 @@ readPragma (HsAnnotation _ _ provenance expr) = f expr
                     Nothing -> errorOn expr "bad classify pragma"
                     Just severity -> Just $ Classify severity (trimStart b) "" name
             where (a,b) = break isSpace $ trimStart $ drop 6 s
-        f (L _ (HsPar _ x)) = f x
+        f (L _ (HsPar _ _ x _)) = f x
         f (L _ (ExprWithTySig _ x _)) = f x
         f _ = Nothing
 
@@ -83,6 +84,6 @@ errorOn (L pos val) msg = exitMessageImpure $
 errorOnComment :: LEpaComment -> String -> b
 errorOnComment c@(L s _) msg = exitMessageImpure $
     let isMultiline = isCommentMultiline c in
-    showSrcSpan (RealSrcSpan (anchor s) Nothing) ++
+    showSrcSpan (RealSrcSpan (anchor s) GHC.Data.Strict.Nothing) ++
     ": Error while reading hint file, " ++ msg ++ "\n" ++
     (if isMultiline then "{-" else "--") ++ commentText c ++ (if isMultiline then "-}" else "")

src/Config/Yaml.hs

@@ -22,7 +22,9 @@ module Config.Yaml(
 #endif
 
 import GHC.Driver.Ppr
-import GHC.Parser.Errors.Ppr
+import GHC.Driver.Errors.Types
+import GHC.Types.Error hiding (Severity)
+
 import Config.Type
 import Data.Either.Extra
 import Data.Maybe
@@ -232,7 +234,7 @@ parseGHC parser v = do
     case parser defaultParseFlags{enabledExtensions=configExtensions, disabledExtensions=[]} x of
         POk _ x -> pure x
         PFailed ps ->
-          let errMsg = pprError . head . bagToList . snd $ getMessages ps
+          let errMsg = head . bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages ps)
               msg = showSDoc baseDynFlags $ pprLocMsgEnvelope errMsg
           in parseFail v $ "Failed to parse " ++ msg ++ ", when parsing:\n " ++ x
 

src/GHC/All.hs

@@ -25,11 +25,13 @@ import GHC.Data.FastString
 import GHC.Hs
 import GHC.Types.SrcLoc
 import GHC.Types.Fixity
+import GHC.Types.Error
+import GHC.Driver.Errors.Types
+
 import GHC.Utils.Error
 import GHC.Parser.Lexer hiding (context)
 import GHC.LanguageExtensions.Type
 import GHC.Driver.Session hiding (extensions)
-import GHC.Parser.Errors.Ppr
 import GHC.Data.Bag
 import Data.Generics.Uniplate.DataOnly
 
@@ -181,14 +183,14 @@ parseModuleEx flags file str = timedIO "Parse" file $ runExceptT $ do
   -- Done with pragmas. Proceed to parsing.
   case fileToModule file str dynFlags of
     POk s a -> do
-      let errs = bagToList . snd $ getMessages s
+      let errs = bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages s)
       if not $ null errs then
         ExceptT $ parseFailureErr dynFlags str file str errs
       else do
         let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags
         pure $ ModuleEx (applyFixities fixes a)
     PFailed s ->
-      ExceptT $ parseFailureErr dynFlags str file str $  bagToList . snd $ getMessages s
+      ExceptT $ parseFailureErr dynFlags str file str $ bagToList . getMessages  $ GhcPsMessage <$> snd (getPsMessages s)
   where
     -- If parsing pragmas fails, synthesize a parse error from the
     -- error message.
@@ -197,7 +199,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 = pprError (head errs)
+      let errMsg = head errs
           loc = errMsgSpan errMsg
           doc = pprLocMsgEnvelope errMsg
       in ghcFailOpParseModuleEx ppstr file str (loc, doc)

src/GHC/Util/ApiAnnotation.hs

@@ -8,6 +8,7 @@ module GHC.Util.ApiAnnotation (
 
 import GHC.LanguageExtensions.Type (Extension)
 import GHC.Parser.Annotation
+import GHC.Hs.DocString
 import GHC.Types.SrcLoc
 
 import Language.Haskell.GhclibParserEx.GHC.Driver.Session
@@ -33,14 +34,11 @@ trimCommentDelims = trimCommentEnd . trimCommentStart
 
 -- | A comment as a string.
 comment_ :: LEpaComment -> String
-comment_ (L _ (EpaComment (EpaBlockComment s ) _)) = s
-comment_ (L _ (EpaComment (EpaLineComment s) _)) = s
+comment_ (L _ (EpaComment (EpaDocComment ds ) _)) = renderHsDocString ds
 comment_ (L _ (EpaComment (EpaDocOptions s) _)) = s
-comment_ (L _ (EpaComment (EpaDocCommentNamed s) _)) = s
-comment_ (L _ (EpaComment (EpaDocCommentPrev s) _)) = s
-comment_ (L _ (EpaComment (EpaDocCommentNext s) _)) = s
-comment_ (L _ (EpaComment (EpaDocSection _ s) _)) = s
-comment_ (L _ (EpaComment  EpaEofComment _)) = ""
+comment_ (L _ (EpaComment (EpaLineComment s) _)) = s
+comment_ (L _ (EpaComment (EpaBlockComment s) _)) = s
+comment_ (L _ (EpaComment EpaEofComment _)) = ""
 
 -- | The comment string with delimiters removed.
 commentText :: LEpaComment -> String

src/GHC/Util/Brackets.hs

@@ -26,18 +26,18 @@ instance Brackets (LocatedA (HsExpr GhcPs)) where
   -- result in a "naked" section. Consequently, given an expression,
   -- when stripping brackets (c.f. 'Hint.Brackets), don't remove the
   -- paren's surrounding a section - they are required.
-  remParen (L _ (HsPar _ (L _ SectionL{}))) = Nothing
-  remParen (L _ (HsPar _ (L _ SectionR{}))) = Nothing
-  remParen (L _ (HsPar _ x)) = Just x
+  remParen (L _ (HsPar _ _ (L _ SectionL{}) _)) = Nothing
+  remParen (L _ (HsPar _ _ (L _ SectionR{}) _)) = Nothing
+  remParen (L _ (HsPar _ _ x _)) = Just x
   remParen _ = Nothing
 
-  addParen e = noLocA $ HsPar EpAnnNotUsed e
+  addParen = nlHsPar
 
   isAtom (L _ x) = case x of
       HsVar{} -> True
       HsUnboundVar{} -> True
       -- Technically atomic, but lots of people think it shouldn't be
-      HsRecFld{} -> False
+      HsRecSel{} -> False
       HsOverLabel{} -> True
       HsIPVar{} -> True
       -- Note that sections aren't atoms (but parenthesized sections are).
@@ -48,7 +48,8 @@ instance Brackets (LocatedA (HsExpr GhcPs)) where
       RecordCon{} -> True
       RecordUpd{} -> True
       ArithSeq{}-> True
-      HsBracket{} -> True
+      HsTypedBracket{} -> True
+      HsUntypedBracket{} -> True
       -- HsSplice might be $foo, where @($foo) would require brackets,
       -- but in that case the $foo is a type, so we can still mark Splice as atomic
       HsSpliceE{} -> True
@@ -104,9 +105,9 @@ isAtomOrApp (L _ (HsApp _ _ x)) = isAtomOrApp x
 isAtomOrApp _ = False
 
 instance Brackets (LocatedA (Pat GhcPs)) where
-  remParen (L _ (ParPat _ x)) = Just x
+  remParen (L _ (ParPat _ _ x _)) = Just x
   remParen _ = Nothing
-  addParen e = noLocA $ ParPat EpAnnNotUsed e
+  addParen = nlParPat
 
   isAtom (L _ x) = case x of
     ParPat{} -> True

src/GHC/Util/FreeVars.hs

@@ -99,27 +99,25 @@ instance FreeVars (LocatedA (HsExpr GhcPs)) where
   freeVars (L _ (HsVar _ x)) = Set.fromList $ unqualNames x -- Variable.
   freeVars (L _ (HsUnboundVar _ x)) = Set.fromList [x] -- Unbound variable; also used for "holes".
   freeVars (L _ (HsLam _ mg)) = free (allVars mg) -- Lambda abstraction. Currently always a single match.
-  freeVars (L _ (HsLamCase _ MG{mg_alts=(L _ ms)})) = free (allVars ms) -- Lambda case
+  freeVars (L _ (HsLamCase _ _ MG{mg_alts=(L _ ms)})) = free (allVars ms) -- Lambda case
   freeVars (L _ (HsCase _ of_ MG{mg_alts=(L _ ms)})) = freeVars of_ ^+ free (allVars ms) -- Case expr.
-  freeVars (L _ (HsLet _ binds e)) = inFree binds e -- Let (rec).
+  freeVars (L _ (HsLet _ _ binds _ e)) = inFree binds e -- Let (rec).
   freeVars (L _ (HsDo _ ctxt (L _ stmts))) = free (allVars stmts) -- Do block.
   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
   freeVars (L _ (HsMultiIf _ grhss)) = free (allVars grhss) -- Multi-way if.
-  freeVars (L _ (HsBracket _ (ExpBr _ e))) = freeVars e
-  freeVars (L _ (HsBracket _ (VarBr _ _ v))) = Set.fromList [occName (unLoc v)]
+  freeVars (L _ (HsTypedBracket _ e)) = freeVars e
+  freeVars (L _ (HsUntypedBracket _ (ExpBr _ e))) = freeVars e
+  freeVars (L _ (HsUntypedBracket _ (VarBr _ _ v))) = Set.fromList [occName (unLoc v)]
 
-  freeVars (L _ HsConLikeOut{}) = mempty -- After typechecker.
-  freeVars (L _ HsRecFld{}) = mempty -- Variable pointing to a record selector.
+  freeVars (L _ HsRecSel{}) = mempty -- Variable pointing to a record selector.
   freeVars (L _ HsOverLabel{}) = mempty -- Overloaded label. The id of the in-scope fromLabel.
   freeVars (L _ HsIPVar{}) = mempty -- Implicit parameter.
   freeVars (L _ HsOverLit{}) = mempty -- Overloaded literal.
   freeVars (L _ HsLit{}) = mempty -- Simple literal.
-  freeVars (L _ HsRnBracketOut{}) = mempty -- Renamer produces these.
-  freeVars (L _ HsTcBracketOut{}) = mempty -- Typechecker produces these.
 
   -- freeVars (e@(L _ HsAppType{})) = freeVars $ children e -- Visible type application e.g. f @ Int x y.
   -- freeVars (e@(L _ HsApp{})) = freeVars $ children e -- Application.
@@ -155,15 +153,15 @@ instance FreeVars (HsTupArg GhcPs) where
   freeVars (Present _ args) = freeVars args
   freeVars _ = mempty
 
-instance FreeVars (LocatedA (HsRecField GhcPs (LocatedA (HsExpr GhcPs)))) where
-   freeVars o@(L _ (HsRecField _ x _ True)) = Set.singleton $ occName $ unLoc $ rdrNameFieldOcc $ unLoc x -- a pun
-   freeVars o@(L _ (HsRecField _ _ x _)) = freeVars x
+instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where
+   freeVars o@(L _ (HsFieldBind _ x _ True)) = Set.singleton $ occName $ unLoc $ foLabel $ unLoc x -- a pun
+   freeVars o@(L _ (HsFieldBind _ _ x _)) = freeVars x
 
-instance FreeVars (LocatedA (HsRecField' (AmbiguousFieldOcc GhcPs) (LocatedA (HsExpr GhcPs)))) where
-  freeVars (L _ (HsRecField _ _ x _)) = freeVars x
+instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where
+  freeVars (L _ (HsFieldBind _ _ x _)) = freeVars x
 
-instance FreeVars (LocatedA (HsRecField' (FieldLabelStrings GhcPs) (LocatedA (HsExpr GhcPs)))) where
-  freeVars (L _ (HsRecField _ _ x _)) = freeVars x
+instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) (LocatedA (HsExpr GhcPs)))) where
+  freeVars (L _ (HsFieldBind _ _ x _)) = freeVars x
 
 instance AllVars (LocatedA (Pat GhcPs)) where
   allVars (L _ (VarPat _ (L _ x))) = Vars (Set.singleton $ rdrNameOcc x) Set.empty -- Variable pattern.
@@ -188,8 +186,8 @@ instance AllVars (LocatedA (Pat GhcPs)) where
 
   allVars p = allVars $ children p
 
-instance AllVars (LocatedA (HsRecField GhcPs (LocatedA (Pat GhcPs)))) where
-   allVars (L _ (HsRecField _ _ x _)) = allVars x
+instance AllVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) (LocatedA (Pat GhcPs)))) where
+   allVars (L _ (HsFieldBind _ _ x _)) = allVars x
 
 instance AllVars (LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))) where
   allVars (L _ (LastStmt _ expr _ _)) = freeVars_ expr -- The last stmt of a ListComp, MonadComp, DoExpr,MDoExpr.
@@ -216,8 +214,6 @@ instance AllVars (LocatedA (HsBindLR GhcPs GhcPs)) where
   allVars (L _ PatBind{pat_lhs=n, pat_rhs=grhss}) = allVars n <> allVars grhss -- Ctor patterns and some other interesting cases e.g. Just x = e, (x) = e, x :: Ty = e.
 
   allVars (L _ (PatSynBind _ PSB{})) = mempty -- Come back to it.
-  allVars (L _ VarBind{}) = mempty -- Typechecker.
-  allVars (L _ AbsBinds{}) = mempty -- Not sure but I think renamer.
 
 instance AllVars (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where
   allVars (MG _ _alts@(L _ alts) _) = inVars (foldMap (allVars . m_pats) ms) (allVars (map m_grhss ms))
@@ -237,7 +233,7 @@ instance AllVars (HsStmtContext GhcPs) where
 instance AllVars (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where
   allVars (GRHSs _ grhss binds) = inVars binds (mconcatMap allVars grhss)
 
-instance AllVars (Located (GRHS GhcPs (LocatedA (HsExpr GhcPs)))) where
+instance AllVars (LocatedAn NoEpAnns (GRHS GhcPs (LocatedA (HsExpr GhcPs)))) where
   allVars (L _ (GRHS _ guards expr)) = Vars (bound gs) (free gs ^+ (freeVars expr ^- bound gs)) where gs = allVars guards
 
 instance AllVars (LocatedA (HsDecl GhcPs)) where