updates for compatibility with ghc HEAD

cabal.project

@@ -1 +1,2 @@
+allow-newer: all
 packages: ./hlint.cabal

src/Config/Compute.hs

@@ -12,7 +12,6 @@ import Data.Generics.Uniplate.DataOnly
 import GHC.Hs hiding (Warning)
 import GHC.Types.Name.Reader
 import GHC.Types.Name
-import GHC.Data.Bag
 import GHC.Types.SrcLoc
 import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
 import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
@@ -46,7 +45,7 @@ renderSetting _ = []
 findSetting :: LocatedA (HsDecl GhcPs) -> [Setting]
 findSetting (L _ (ValD _ x)) = findBind x
 findSetting (L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =
-    concatMap (findBind . unLoc) $ bagToList cid_binds
+    concatMap (findBind . unLoc) cid_binds
 findSetting (L _ (SigD _ (FixSig _ x))) = map Infix $ fromFixitySig x
 findSetting x = []
 
@@ -57,9 +56,9 @@ findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noAnn
 findBind _ = []
 
 findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]
-findExp name vs (HsLam _ LamSingle MG{mg_alts=L _ [L _ Match{m_pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=(EmptyLocalBinds _)}}]})
-    = if length m_pats == length ps then findExp name (vs++ps) $ unLoc x else []
-    where ps = [rdrNameStr x | L _ (VarPat _ x) <- m_pats]
+findExp name vs (HsLam _ LamSingle MG{mg_alts=L _ [L _ Match{m_pats=L _ pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=(EmptyLocalBinds _)}}]})
+    = if length pats == length ps then findExp name (vs++ps) $ unLoc x else []
+    where ps = [rdrNameStr x | L _ (VarPat _ x) <- pats]
 findExp name vs HsLam{} = []
 findExp name vs HsVar{} = []
 findExp name vs (OpApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $

src/Fixity.hs

@@ -12,7 +12,6 @@ import GHC.Hs.Extension
 import GHC.Types.Name.Occurrence
 import GHC.Types.Name.Reader
 import GHC.Types.Fixity
-import GHC.Types.SourceText
 import GHC.Parser.Annotation
 import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
 import Language.Haskell.GhclibParserEx.Fixity
@@ -28,22 +27,22 @@ import Language.Haskell.GhclibParserEx.Fixity
 type FixityInfo = (String, Associativity, Int)
 
 fromFixitySig :: FixitySig GhcPs -> [FixityInfo]
-fromFixitySig (FixitySig _ names (Fixity _ i dir)) =
+fromFixitySig (FixitySig _ names (Fixity i dir)) =
     [(rdrNameStr name, f dir, i) | name <- names]
     where
         f InfixL = LeftAssociative
         f InfixR = RightAssociative
         f InfixN = NotAssociative
 
 toFixity :: FixityInfo -> (String, Fixity)
-toFixity (name, dir, i) = (name, Fixity NoSourceText i $ f dir)
+toFixity (name, dir, i) = (name, Fixity i $ f dir)
     where
         f LeftAssociative = InfixL
         f RightAssociative = InfixR
         f NotAssociative = InfixN
 
 fromFixity :: (String, Fixity) -> FixityInfo
-fromFixity (name, Fixity _ i dir) = (name, assoc dir, i)
+fromFixity (name, Fixity i dir) = (name, assoc dir, i)
   where
     assoc dir = case dir of
       InfixL -> LeftAssociative

src/GHC/Util/FreeVars.hs

@@ -13,7 +13,6 @@ import GHC.Types.Name.Occurrence
 import GHC.Types.Name
 import GHC.Hs
 import GHC.Types.SrcLoc
-import GHC.Data.Bag (bagToList)
 
 import Data.Generics.Uniplate.DataOnly
 import Data.Monoid
@@ -119,7 +118,7 @@ instance FreeVars (LocatedA (HsExpr GhcPs)) where
                      _ -> mempty
                  )
           accFree = accFree0 ^+ (free (allVars stmt) ^- accBound0)
-  freeVars (L _ (RecordCon _ _ (HsRecFields flds _))) = Set.unions $ map freeVars flds -- Record construction.
+  freeVars (L _ (RecordCon _ _ (HsRecFields _ flds _))) = Set.unions $ map freeVars flds -- Record construction.
   freeVars (L _ (RecordUpd _ e flds)) =
     case flds of
       RegularRecUpdFields _ fs -> Set.unions $ freeVars e : map freeVars fs
@@ -183,13 +182,13 @@ instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings
 instance AllVars (LocatedA (Pat GhcPs)) where
   allVars (L _ (VarPat _ (L _ x))) = Vars (Set.singleton $ rdrNameOcc x) Set.empty -- Variable pattern.
   allVars (L _ (AsPat _ n x)) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) <> allVars x -- As pattern.
-  allVars (L _ (ConPat _ _ (RecCon (HsRecFields flds _)))) = allVars flds
+  allVars (L _ (ConPat _ _ (RecCon (HsRecFields _ flds _)))) = allVars flds
   allVars (L _ (NPlusKPat _ n _ _ _ _)) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) -- n+k pattern.
   allVars (L _ (ViewPat _ e p)) = freeVars_ e <> allVars p -- View pattern.
-
   allVars (L _ WildPat{}) = mempty -- Wildcard pattern.
   allVars (L _ LitPat{}) = mempty -- Literal pattern.
   allVars (L _ NPat{}) = mempty -- Natural pattern.
+  allVars (L _ InvisPat {}) = mempty -- since ghc-9.10.1
 
   -- allVars p@SplicePat{} = allVars $ children p -- Splice pattern (includes quasi-quotes).
   -- allVars p@SigPat{} = allVars $ children p -- Pattern with a type signature.
@@ -213,12 +212,10 @@ instance AllVars (LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))) where
   allVars (L _ (LetStmt _ binds)) = allVars binds -- A local declaration e.g. let y = x + 1
   allVars (L _ (TransStmt _ _ stmts _ using by _ _ fmap_)) = allVars stmts <> freeVars_ using <> maybe mempty freeVars_ by <> freeVars_ (noLocA fmap_ :: LocatedA (HsExpr GhcPs)) -- Apply a function to a list of statements in order.
   allVars (L _ (RecStmt _ stmts _ _ _ _ _)) = allVars (unLoc stmts) -- A recursive binding for a group of arrows.
-
-  allVars (L _ ApplicativeStmt{}) = mempty -- Generated by the renamer.
   allVars (L _ ParStmt{}) = mempty -- Parallel list thing. Come back to it.
 
 instance AllVars (HsLocalBinds GhcPs) where
-  allVars (HsValBinds _ (ValBinds _ binds _)) = allVars (bagToList binds) -- Value bindings.
+  allVars (HsValBinds _ (ValBinds _ binds _)) = allVars binds -- Value bindings.
   allVars (HsIPBinds _ (IPBinds _ binds)) = allVars binds -- Implicit parameter bindings.
   allVars EmptyLocalBinds{} =  mempty -- The case of no local bindings (signals the empty `let` or `where` clause).
   allVars _ = mempty -- extension points
@@ -233,13 +230,13 @@ instance AllVars (LocatedA (HsBindLR GhcPs GhcPs)) where
   allVars (L _ (PatSynBind _ PSB{})) = mempty -- Come back to it.
 
 instance AllVars (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where
-  allVars (MG _ _alts@(L _ alts)) = foldMap (\m -> inVars (allVars (m_pats m)) (allVars (m_grhss m))) ms
+  allVars (MG _ _alts@(L _ alts)) = foldMap (\m -> inVars (allVars ((unLoc . m_pats) m)) (allVars (m_grhss m))) ms
     where ms = map unLoc alts
 
 instance AllVars (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where
-  allVars (L _ (Match _ FunRhs {mc_fun=name} pats grhss)) = allVars (noLocA $ VarPat noExtField name :: LocatedA (Pat GhcPs)) <> allVars pats <> allVars grhss -- A pattern matching on an argument of a function binding.
-  allVars (L _ (Match _ (StmtCtxt ctxt) pats grhss)) = allVars ctxt <> allVars pats <> allVars grhss -- Pattern of a do-stmt, list comprehension, pattern guard etc.
-  allVars (L _ (Match _ _ pats grhss)) = inVars (allVars pats) (allVars grhss) -- Everything else.
+  allVars (L _ (Match _ FunRhs {mc_fun=name} pats grhss)) = allVars (noLocA $ VarPat noExtField name :: LocatedA (Pat GhcPs)) <> (allVars . unLoc) pats <> allVars grhss -- A pattern matching on an argument of a function binding.
+  allVars (L _ (Match _ (StmtCtxt ctxt) pats grhss)) = allVars ctxt <> (allVars . unLoc) pats <> allVars grhss -- Pattern of a do-stmt, list comprehension, pattern guard etc.
+  allVars (L _ (Match _ _ pats grhss)) = inVars ((allVars . unLoc) pats) (allVars grhss) -- Everything else.
 
 instance AllVars (HsStmtContext (GenLocated SrcSpanAnnN RdrName)) where
   allVars (PatGuard FunRhs{mc_fun=n}) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs))

src/GHC/Util/HsExpr.hs

@@ -21,7 +21,6 @@ import GHC.Types.SrcLoc
 import GHC.Data.FastString
 import GHC.Types.Name.Reader
 import GHC.Types.Name.Occurrence
-import GHC.Data.Bag(bagToList)
 
 import GHC.Util.Brackets
 import GHC.Util.FreeVars
@@ -58,7 +57,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 noAnn LamSingle (MG (Generated OtherExpansion DoPmc) (noLocA [noLocA $ Match noAnn (LamAlt LamSingle) vs (GRHSs emptyComments [noLocA $ GRHS noAnn [] body] (EmptyLocalBinds noExtField))]))
+lambda vs body = noLocA $ HsLam noAnn LamSingle (MG (Generated OtherExpansion DoPmc) (noLocA [noLocA $ Match noAnn (LamAlt LamSingle) (L noSpanAnchor vs) (GRHSs emptyComments [noLocA $ GRHS noAnn [] body] (EmptyLocalBinds noExtField))]))
 
 -- | 'paren e' wraps 'e' in parens if 'e' is non-atomic.
 paren :: LHsExpr GhcPs -> LHsExpr GhcPs
@@ -124,8 +123,8 @@ simplifyExp :: LHsExpr GhcPs -> LHsExpr GhcPs
 simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp noExtField x (nlHsPar y))
 simplifyExp e@(L _ (HsLet _ ((HsValBinds _ (ValBinds _ binds []))) z)) =
   -- An expression of the form, 'let x = y in z'.
-  case bagToList binds of
-    [L _ (FunBind _ _ (MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _) [] (GRHSs _[L _ (GRHS _ [] y)] ((EmptyLocalBinds _))))])))]
+  case binds of
+    [L _ (FunBind _ _ (MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _) (L _ []) (GRHSs _ [L _ (GRHS _ [] y)] ((EmptyLocalBinds _))))])))]
          -- If 'x' is not in the free variables of 'y', beta-reduce to
          -- 'z[(y)/x]'.
       | occNameStr x `notElem` vars y && length [() | Unqual a <- universeBi z, a == rdrNameOcc x] <= 1 ->
@@ -241,7 +240,7 @@ niceLambdaR [] e = (e, \s -> [Replace Expr s [("a", toSSA e)] "a"])
 niceLambdaR ss e =
   let grhs = noLocA $ GRHS noAnn [] e :: LGRHS GhcPs (LHsExpr GhcPs)
       grhss = GRHSs {grhssExt = emptyComments, grhssGRHSs=[grhs], grhssLocalBinds=EmptyLocalBinds noExtField}
-      match = noLocA $ Match {m_ext=noAnn, m_ctxt=LamAlt LamSingle, m_pats=map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs)
+      match = noLocA $ Match {m_ext=noAnn, m_ctxt=LamAlt LamSingle, m_pats=noLocA $ map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs)
       matchGroup = MG {mg_ext=Generated OtherExpansion SkipPmc, mg_alts=noLocA [match]}
   in (noLocA $ HsLam noAnn LamSingle matchGroup, const [])
 

src/GHC/Util/View.hs

@@ -32,7 +32,7 @@ data App2  = NoApp2  | App2 (LocatedA (HsExpr GhcPs)) (LocatedA (HsExpr GhcPs))
 data LamConst1 = NoLamConst1 | LamConst1 (LocatedA (HsExpr GhcPs))
 
 instance View (LocatedA (HsExpr GhcPs)) LamConst1 where
-  view (fromParen -> (L _ (HsLam _ _ (MG FromSource (L _ [L _ (Match _ (LamAlt _) [L _ WildPat {}]
+  view (fromParen -> (L _ (HsLam _ _ (MG FromSource (L _ [L _ (Match _ (LamAlt _) (L _ [L _ WildPat {}])
     (GRHSs _ [L _ (GRHS _ [] x)] ((EmptyLocalBinds _))))]))))) = LamConst1 x
   view _ = NoLamConst1
 
@@ -62,4 +62,4 @@ instance View (LocatedA (Pat GhcPs)) PApp_ where
 
 -- A lambda with no guards and no where clauses
 pattern SimpleLambda :: [LocatedA (Pat GhcPs)] -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
-pattern SimpleLambda vs body <- L _ (HsLam _ LamSingle (MG _ (L _ [L _ (Match _ _ vs (GRHSs _ [L _ (GRHS _ [] body)] ((EmptyLocalBinds _))))])))
+pattern SimpleLambda vs body <- L _ (HsLam _ LamSingle (MG _ (L _ [L _ (Match _ _ (L _ vs) (GRHSs _ [L _ (GRHS _ [] body)] ((EmptyLocalBinds _))))])))

src/Hint/Duplicate.hs

@@ -37,7 +37,6 @@ import Data.Map qualified as Map
 import GHC.Types.SrcLoc
 import GHC.Hs
 import GHC.Utils.Outputable
-import GHC.Data.Bag
 import GHC.Util
 import Language.Haskell.GhclibParserEx.GHC.Hs
 import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
@@ -54,7 +53,7 @@ duplicateHint ms =
    dupes [ (m, d, y)
          | (m, d, x) <- ds
          , HsValBinds _ (ValBinds _ b _ ) :: HsLocalBinds GhcPs <- universeBi x
-         , let y = bagToList b
+         , let y = b
          ]
     where
       ds = [(modName m, fromMaybe "" (declName d), unLoc d)

src/Hint/Lambda.hs

@@ -149,7 +149,7 @@ lambdaBind :: LHsBind GhcPs -> RType -> [Idea]
 lambdaBind
     o@(L _ origBind@FunBind {fun_id = funName@(L loc1 _), fun_matches =
         MG {mg_alts =
-            L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _) pats (GRHSs _ [L _ (GRHS _ [] origBody@(L loc2 _))] bind))]}}) rtype
+            L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _) (L _ pats) (GRHSs _ [L _ (GRHS _ [] origBody@(L loc2 _))] bind))]}}) rtype
     | EmptyLocalBinds _ <- bind
     , isLambda $ fromParen origBody
     , null (universeBi pats :: [HsExpr GhcPs])
@@ -172,7 +172,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 OtherExpansion SkipPmc) (noLocA [noLocA $ Match noAnn ctxt ps $ GRHSs emptyComments [noLocA $ GRHS noAnn [] b] $ EmptyLocalBinds noExtField])}
+             origBind {fun_matches = MG (Generated OtherExpansion SkipPmc) (noLocA [noLocA $ Match noAnn ctxt (L noSpanAnchor ps) $ GRHSs emptyComments [noLocA $ GRHS noAnn [] b] $ EmptyLocalBinds noExtField])}
 
           mkSubtsAndTpl newPats newBody = (sub, tpl)
             where
@@ -270,7 +270,7 @@ lambdaExp _ o@(SimpleLambda [view -> PVar_ x] (L _ expr)) =
                  --     * mark match as being in a lambda context so that it's printed properly
                  oldMG@(MG _ (L _ [L _ oldmatch]))
                    | all (\(L _ (GRHS _ stmts _)) -> null stmts) (grhssGRHSs (m_grhss oldmatch)) ->
-                     let patLocs = fmap (locA . getLoc) (m_pats oldmatch)
+                     let patLocs = fmap (locA . getLoc) ((unLoc . m_pats) oldmatch)
                          bodyLocs = concatMap (\case L _ (GRHS _ _ body) -> [locA (getLoc body)])
                                         $ grhssGRHSs (m_grhss oldmatch)
                          r | notNull patLocs && notNull bodyLocs =
@@ -280,12 +280,12 @@ lambdaExp _ o@(SimpleLambda [view -> PVar_ x] (L _ expr)) =
                                      ((if needParens then "\\(x)" else "\\x") ++ " -> y")
                                  ]
                            | otherwise = []
-                         needParens = any (patNeedsParens appPrec . unLoc) (m_pats oldmatch)
+                         needParens = any (patNeedsParens appPrec . unLoc) ((unLoc . m_pats) oldmatch)
                       in [ suggest "Use lambda" (reLoc o)
                              ( noLoc $ HsLam noAnn LamSingle oldMG
                                  { mg_alts = noLocA
                                      [ noLocA oldmatch
-                                         { m_pats = map mkParPat $ m_pats oldmatch
+                                         { m_pats = L noSpanAnchor (map mkParPat $ (unLoc . m_pats) oldmatch)
                                          , m_ctxt = LamAlt LamSingle
                                          }
                                      ]

src/Hint/ListRec.hs

@@ -138,7 +138,7 @@ asDo (view ->
               mg_ext=FromSource
             , mg_alts=L _ [
                  L _ Match {  m_ctxt=(LamAlt LamSingle)
-                            , m_pats=[v@(L _ VarPat{})]
+                            , m_pats=L _ [v@(L _ VarPat{})]
                             , m_grhss=GRHSs _
                                         [L _ (GRHS _ [] rhs)]
                                         (EmptyLocalBinds _)}]}))
@@ -175,7 +175,7 @@ findCase x = do
       emptyLocalBinds = EmptyLocalBinds noExtField :: HsLocalBindsLR GhcPs GhcPs -- Empty where clause.
       gRHS e = noLocA $ GRHS noAnn [] e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs.
       gRHSSs e = GRHSs emptyComments [gRHS e] emptyLocalBinds -- Guarded rhs set.
-      match e = Match{m_ext=noAnn,m_pats=ps12, m_grhss=gRHSSs e, ..} -- Match.
+      match e = Match{m_ext=noAnn,m_pats=noLocA ps12, m_grhss=gRHSSs e, ..} -- Match.
       matchGroup e = MG{mg_alts=noLocA [noLocA $ match e], mg_ext=Generated OtherExpansion SkipPmc, ..} -- Match group.
       funBind e = FunBind {fun_matches=matchGroup e, ..} :: HsBindLR GhcPs GhcPs -- Fun bind.
 
@@ -212,7 +212,7 @@ findBranch (L _ x) = do
                         , grhssLocalBinds=EmptyLocalBinds _
                         }
             } <- pure x
-  (a, b, c) <- findPat ps
+  (a, b, c) <- findPat (unLoc ps)
   pure $ Branch (occNameStr name) a b c $ simplifyExp body
 
 findPat :: [LPat GhcPs] -> Maybe ([String], Int, BList)

src/Hint/Match.hs

@@ -53,7 +53,6 @@ import Data.Maybe
 import Config.Type
 import Data.Generics.Uniplate.DataOnly
 
-import GHC.Data.Bag
 import GHC.Hs
 import GHC.Types.SrcLoc
 import GHC.Types.SourceText
@@ -121,7 +120,7 @@ findIdeas matches s _ decl = timed "Hint" "Match apply" $ forceList
 -- | A list of root expressions, with their associated names
 findDecls :: LHsDecl GhcPs -> [(String, LHsExpr GhcPs)]
 findDecls x@(L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =
-    [(fromMaybe "" $ bindName xs, x) | xs <- bagToList cid_binds, x <- childrenBi xs]
+    [(fromMaybe "" $ bindName xs, x) | xs <- cid_binds, x <- childrenBi xs]
 findDecls (L _ RuleD{}) = [] -- Often rules contain things that HLint would rewrite.
 findDecls x = map (fromMaybe "" $ declName x,) $ childrenBi x
 

src/Hint/Monad.hs

@@ -77,7 +77,6 @@ import GHC.Types.SrcLoc
 import GHC.Types.Basic
 import GHC.Types.Name.Reader
 import GHC.Types.Name.Occurrence
-import GHC.Data.Bag
 import GHC.Data.Strict qualified
 
 import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
@@ -297,9 +296,9 @@ monadLet xs = mapMaybe mkLet xs
         let p = noLocA $ mkRdrUnqual (mkVarOcc lhs)
             grhs = noLocA (GRHS noAnn [] rhs)
             grhss = GRHSs emptyComments [grhs] (EmptyLocalBinds noExtField)
-            match = noLocA $ Match noAnn (FunRhs p Prefix NoSrcStrict) [] grhss
+            match = noLocA $ Match noAnn (FunRhs p Prefix NoSrcStrict) (noLocA []) grhss
             fb = noLocA $ FunBind noExtField p (MG (Generated OtherExpansion SkipPmc) (noLocA [match]))
-            binds = unitBag fb
+            binds = [fb]
             valBinds = ValBinds NoAnnSortKey binds []
             localBinds = HsValBinds noAnn valBinds
          in noLocA $ LetStmt noAnn localBinds

src/Hint/NewType.hs

@@ -151,7 +151,7 @@ isHashy :: HsType GhcPs -> Bool
 isHashy x = or ["#" `isSuffixOf` unsafePrettyPrint v | v@HsTyVar{} <- universe x]
 
 warnBang :: HsType GhcPs -> Bool
-warnBang (HsBangTy _ (HsSrcBang _ _ SrcStrict) _) = False
+warnBang (HsBangTy _ (HsBang _ SrcStrict) _) = False
 warnBang _ = True
 
 emptyOrNoContext :: Maybe (LHsContext GhcPs) -> Bool