updates for compatibility with ghc HEAD

src/Config/Compute.hs

@@ -57,9 +57,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

@@ -186,10 +186,10 @@ instance AllVars (LocatedA (Pat GhcPs)) where
   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,8 +213,6 @@ 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
@@ -233,13 +231,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

@@ -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 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
@@ -125,7 +125,7 @@ simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp noExtField x (nlHsPar
 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 _))))])))]
+    [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 +241,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/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/Monad.hs

@@ -297,7 +297,7 @@ 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
             valBinds = ValBinds NoAnnSortKey binds []

src/Hint/Pattern.hs

@@ -195,7 +195,7 @@ asPattern (L loc x) = concatMap decl (universeBi x)
     decl _ = []
 
     match :: LMatch GhcPs (LHsExpr GhcPs) -> (Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)
-    match o@(L loc (Match _ ctx pats grhss)) = (Pattern (locA loc) R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest msg (reLoc o) (noLoc (Match noAnn ctx  pats grhss) :: Located (Match GhcPs (LHsExpr GhcPs))) rs)
+    match o@(L loc (Match _ ctx (L lpats pats) grhss)) = (Pattern (locA loc) R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest msg (reLoc o) (noLoc (Match noAnn ctx  (L lpats pats) grhss) :: Located (Match GhcPs (LHsExpr GhcPs))) rs)
 
 -- First Bool is if 'Strict' is a language extension. Second Bool is
 -- if this pattern in this context is going to be evaluated strictly.
@@ -239,11 +239,11 @@ patHint _ _ _ = []
 
 expHint :: LHsExpr GhcPs -> [Idea]
  -- Note the 'FromSource' in these equations (don't warn on generated match groups).
-expHint o@(L _ (HsCase _ _ (MG FromSource (L _ [L _ (Match _ CaseAlt [L _ (WildPat _)] (GRHSs _ [L _ (GRHS _ [] e)] (EmptyLocalBinds _))) ])))) =
+expHint o@(L _ (HsCase _ _ (MG FromSource (L _ [L _ (Match _ CaseAlt (L _ [L _ (WildPat _)]) (GRHSs _ [L _ (GRHS _ [] e)] (EmptyLocalBinds _))) ])))) =
   [suggest "Redundant case" (reLoc o) (reLoc e) [r]]
   where
     r = Replace Expr (toSSA o) [("x", toSSA e)] "x"
-expHint o@(L _ (HsCase _ (L _ (HsVar _ (L _ x))) (MG FromSource (L _ [L _ (Match _ CaseAlt [L _ (VarPat _ (L _ y))] (GRHSs _ [L _ (GRHS _ [] e)] (EmptyLocalBinds _))) ]))))
+expHint o@(L _ (HsCase _ (L _ (HsVar _ (L _ x))) (MG FromSource (L _ [L _ (Match _ CaseAlt (L _ [L _ (VarPat _ (L _ y))]) (GRHSs _ [L _ (GRHS _ [] e)] (EmptyLocalBinds _))) ]))))
   | occNameStr x == occNameStr y =
       [suggest "Redundant case" (reLoc o) (reLoc e) [r]]
   where

src/Hint/Unsafe.hs

@@ -54,7 +54,7 @@ unsafeHint _ (ModuleEx (L _ m)) = \ld@(L loc d) ->
      -- 'x' does not declare a new function.
      | d@(ValD _
            FunBind {fun_id=L _ (Unqual x)
-                      , fun_matches=MG{mg_ext=FromSource,mg_alts=L _ [L _ Match {m_pats=[]}]}}) <- [d]
+                      , fun_matches=MG{mg_ext=FromSource,mg_alts=L _ [L _ Match {m_pats=L _ []}]}}) <- [d]
      -- 'x' is a synonym for an application involving 'unsafePerformIO'
      , isUnsafeDecl d
      -- 'x' is not marked 'NOINLINE'.