Merge pull request #1629 from ndmitchell/ghc-9.12.1

updates for compatibility with ghc-9.12

Author: ndmitchell

.github/workflows/ci.yml

@@ -16,21 +16,21 @@ jobs:
       fail-fast: false
       matrix:
         os: [ubuntu-latest]
-        ghc: ['9.10', '9.8', '9.6']
+        ghc: ['9.12', '9.10', '9.8']
         include:
         - os: windows-latest
-          ghc: '9.8'
+          ghc: '9.10'
         - os: macOS-latest
-          ghc: '9.8'
+          ghc: '9.10'
     steps:
     - run: git config --global core.autocrlf false
     - uses: actions/checkout@v2
-    - uses: haskell/actions/setup@v2
+    - uses: haskell-actions/setup@v2
       id: setup-haskell
       with:
         ghc-version: ${{ matrix.ghc }}
     - run: cabal install apply-refact --install-method=copy
-      if: matrix.ghc == '9.8' || matrix.ghc == '9.6'
+      if: matrix.ghc == '9.8'
     - name: Get GHC libdir
       id: get-ghc-libdir
       run: echo "libdir=$(ghc --print-libdir)" >> $GITHUB_OUTPUT

hlint.cabal

@@ -81,16 +81,16 @@ library
         deriving-aeson >= 0.2,
         filepattern >= 0.1.1
 
-    if !flag(ghc-lib) && impl(ghc >= 9.10.1) && impl(ghc < 9.11.0)
+    if !flag(ghc-lib) && impl(ghc >= 9.12.1) && impl(ghc < 9.13.0)
       build-depends:
-        ghc == 9.10.*,
+        ghc == 9.12.*,
         ghc-boot-th,
         ghc-boot
     else
       build-depends:
-          ghc-lib-parser == 9.10.*
+          ghc-lib-parser == 9.12.*
     build-depends:
-        ghc-lib-parser-ex >= 9.10.0.0 && < 9.11.0
+        ghc-lib-parser-ex >= 9.12.0.0 && < 9.13.0
 
     if flag(gpl)
         build-depends: hscolour >= 1.21

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/Config/Haskell.hs

@@ -85,6 +85,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) GHC.Data.Strict.Nothing) ++
+    showSrcSpan (RealSrcSpan (epaLocationRealSrcSpan s) GHC.Data.Strict.Nothing) ++
     ": Error while reading hint file, " ++ msg ++ "\n" ++
     (if isMultiline then "{-" else "--") ++ commentText c ++ (if isMultiline then "-}" else "")

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/ApiAnnotation.hs

@@ -107,8 +107,8 @@ languagePragmas ps =
 -- Given a list of flags, make a GHC options pragma.
 mkFlags :: NoCommentsLocation -> [String] -> LEpaComment
 mkFlags anc flags =
-  L anc $ EpaComment (EpaBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")) (anchor anc)
+  L anc $ EpaComment (EpaBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")) (epaLocationRealSrcSpan anc)
 
 mkLanguagePragmas :: NoCommentsLocation -> [String] -> LEpaComment
 mkLanguagePragmas anc exts =
-  L anc $ EpaComment (EpaBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")) (anchor anc)
+  L anc $ EpaComment (EpaBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")) (epaLocationRealSrcSpan anc)

src/GHC/Util/Brackets.hs

@@ -36,8 +36,6 @@ instance Brackets (LocatedA (HsExpr GhcPs)) where
   isAtom (L _ x) = case x of
       HsVar{} -> True
       HsUnboundVar{} -> True
-      -- Technically atomic, but lots of people think it shouldn't be
-      HsRecSel{} -> False
       -- Only relevant for OverloadedRecordDot extension
       HsGetField{} -> True
       HsOverLabel{} -> True

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
@@ -129,7 +128,6 @@ instance FreeVars (LocatedA (HsExpr GhcPs)) where
   freeVars (L _ (HsUntypedBracket _ (ExpBr _ e))) = freeVars e
   freeVars (L _ (HsUntypedBracket _ (VarBr _ _ v))) = Set.fromList [occName (unLoc v)]
 
-  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.
@@ -173,23 +171,19 @@ instance FreeVars (LocatedA (HsFieldBind (LocatedA (FieldOcc GhcPs)) (LocatedA (
    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 (HsFieldBind (LocatedA (AmbiguousFieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where
-  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
   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.
   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 +207,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 +225,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
@@ -49,7 +48,7 @@ import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
 
 -- | 'dotApp a b' makes 'a . b'.
 dotApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-dotApp x y = noLocA $ OpApp noAnn x (noLocA $ HsVar noExtField (noLocA $ mkVarUnqual (fsLit "."))) y
+dotApp x y = noLocA $ OpApp noExtField x (noLocA $ HsVar noExtField (noLocA $ mkVarUnqual (fsLit "."))) y
 
 dotApps :: [LHsExpr GhcPs] -> LHsExpr GhcPs
 dotApps [] = error "GHC.Util.HsExpr.dotApps', does not work on an empty list"
@@ -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 noExtField (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=noExtField, 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 [])
 
@@ -260,7 +259,7 @@ replaceBranches (L s (HsCase _ a (MG FromSource (L l bs)))) =
 
     g :: [LMatch GhcPs (LHsExpr GhcPs)] -> [LHsExpr GhcPs] -> [LMatch GhcPs (LHsExpr GhcPs)]
     g (L s1 (Match _ CaseAlt a (GRHSs _ ns b)) : rest) xs =
-      L s1 (Match noAnn CaseAlt a (GRHSs emptyComments [L a (GRHS noAnn gs x) | (L a (GRHS _ gs _), x) <- zip ns as] b)) : g rest bs
+      L s1 (Match noExtField CaseAlt a (GRHSs emptyComments [L a (GRHS noAnn gs x) | (L a (GRHS _ gs _), x) <- zip ns as] b)) : g rest bs
       where  (as, bs) = splitAt (length ns) xs
     g [] [] = []
     g _ _ = error "GHC.Util.HsExpr.replaceBranches': internal invariant failed, lists are of differing lengths"

src/GHC/Util/Scope.hs

@@ -119,7 +119,7 @@ possImport (L _ i) (L _ (Unqual x)) =
     then maybe PossiblyImported (f . first (== EverythingBut)) (ideclImportList i)
     else NotImported
   where
-    f :: (Bool, LocatedL [LIE GhcPs]) -> IsImported
+    f :: (Bool, LocatedLI [LocatedA (IE GhcPs)]) -> IsImported
     f (hide, L _ xs)
       | hide = if Just True `elem` ms then NotImported else PossiblyImported
       | Just True `elem` ms = Imported