From 38e8658ce0a4ab514b808a4e7eee916e6462a6c3 Mon Sep 17 00:00:00 2001 From: Shayne Fletcher Date: Fri, 3 Jan 2025 11:49:07 -0500 Subject: [PATCH] updates for compatibility with ghc-9.12 --- .github/workflows/ci.yml | 10 +++++----- cabal.project | 3 +++ hlint.cabal | 8 ++++---- src/Config/Compute.hs | 9 ++++----- src/Config/Haskell.hs | 2 +- src/Fixity.hs | 7 +++---- src/GHC/Util/ApiAnnotation.hs | 4 ++-- src/GHC/Util/Brackets.hs | 2 -- src/GHC/Util/FreeVars.hs | 24 ++++++++---------------- src/GHC/Util/HsExpr.hs | 13 ++++++------- src/GHC/Util/Scope.hs | 2 +- src/GHC/Util/SrcLoc.hs | 2 +- src/GHC/Util/Unify.hs | 10 ++++------ src/GHC/Util/View.hs | 4 ++-- src/Hint/Bracket.hs | 6 +++--- src/Hint/Comment.hs | 2 +- src/Hint/Duplicate.hs | 3 +-- src/Hint/Extensions.hs | 2 +- src/Hint/Lambda.hs | 10 +++++----- src/Hint/List.hs | 2 +- src/Hint/ListRec.hs | 6 +++--- src/Hint/Match.hs | 3 +-- src/Hint/Monad.hs | 15 +++++++-------- src/Hint/NewType.hs | 2 +- src/Hint/Pattern.hs | 13 ++++++------- src/Hint/Smell.hs | 3 +-- src/Hint/Unsafe.hs | 2 +- 27 files changed, 76 insertions(+), 93 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index b1b46d929..75063c494 100644 --- a/.github/workflows/ci.yml +++ b/.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 diff --git a/cabal.project b/cabal.project index 575fc59ff..81cbe7bae 100644 --- a/cabal.project +++ b/cabal.project @@ -1 +1,4 @@ +if impl(ghc == 9.12.1) + allow-newer: ghc-prim, base, template-haskell + packages: ./hlint.cabal diff --git a/hlint.cabal b/hlint.cabal index 688c48640..7e950387a 100644 --- a/hlint.cabal +++ b/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 diff --git a/src/Config/Compute.hs b/src/Config/Compute.hs index a11abd857..e916179a2 100644 --- a/src/Config/Compute.hs +++ b/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"]) $ diff --git a/src/Config/Haskell.hs b/src/Config/Haskell.hs index dd79af992..2be9201ea 100644 --- a/src/Config/Haskell.hs +++ b/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 "") diff --git a/src/Fixity.hs b/src/Fixity.hs index 06e88418b..63c05c027 100644 --- a/src/Fixity.hs +++ b/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,7 +27,7 @@ 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 @@ -36,14 +35,14 @@ fromFixitySig (FixitySig _ names (Fixity _ i dir)) = 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 diff --git a/src/GHC/Util/ApiAnnotation.hs b/src/GHC/Util/ApiAnnotation.hs index 5497e4c9a..d613e40da 100644 --- a/src/GHC/Util/ApiAnnotation.hs +++ b/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) diff --git a/src/GHC/Util/Brackets.hs b/src/GHC/Util/Brackets.hs index 020b60c61..c3f27c8a0 100644 --- a/src/GHC/Util/Brackets.hs +++ b/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 diff --git a/src/GHC/Util/FreeVars.hs b/src/GHC/Util/FreeVars.hs index 436afb3bb..315150c33 100644 --- a/src/GHC/Util/FreeVars.hs +++ b/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)) diff --git a/src/GHC/Util/HsExpr.hs b/src/GHC/Util/HsExpr.hs index 9b58002c5..a75369555 100644 --- a/src/GHC/Util/HsExpr.hs +++ b/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" diff --git a/src/GHC/Util/Scope.hs b/src/GHC/Util/Scope.hs index 8fe17c5d2..c98ca5739 100644 --- a/src/GHC/Util/Scope.hs +++ b/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 diff --git a/src/GHC/Util/SrcLoc.hs b/src/GHC/Util/SrcLoc.hs index de3942d6d..84b4c0e03 100644 --- a/src/GHC/Util/SrcLoc.hs +++ b/src/GHC/Util/SrcLoc.hs @@ -20,7 +20,7 @@ import Data.Generics.Uniplate.DataOnly -- Get the 'SrcSpan' out of a value located by an 'NoCommentsLocation' -- (e.g. comments). getAncLoc :: GenLocated NoCommentsLocation a -> SrcSpan -getAncLoc o = RealSrcSpan (GHC.Parser.Annotation.anchor (GHC.Types.SrcLoc.getLoc o)) GHC.Data.Strict.Nothing +getAncLoc o = RealSrcSpan (GHC.Parser.Annotation.epaLocationRealSrcSpan (GHC.Types.SrcLoc.getLoc o)) GHC.Data.Strict.Nothing -- 'stripLocs x' is 'x' with all contained source locs replaced by -- 'noSrcSpan'. diff --git a/src/GHC/Util/Unify.hs b/src/GHC/Util/Unify.hs index 086164106..66f3a4976 100644 --- a/src/GHC/Util/Unify.hs +++ b/src/GHC/Util/Unify.hs @@ -78,7 +78,7 @@ substitute (Subst bind) = transformBracketOld exp . transformBi pat . transformB exp (L _ (HsVar _ x)) = lookup (rdrNameStr x) bind -- Operator applications. exp (L loc (OpApp _ lhs (L _ (HsVar _ x)) rhs)) - | Just y <- lookup (rdrNameStr x) bind = Just (L loc (OpApp noAnn lhs y rhs)) + | Just y <- lookup (rdrNameStr x) bind = Just (L loc (OpApp noExtField lhs y rhs)) -- Left sections. exp (L loc (SectionL _ exp (L _ (HsVar _ x)))) | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionL noExtField exp y)) @@ -115,11 +115,11 @@ unify' nm root x y | Just (x, y) <- cast (x, y) = if (x :: FastString) == y then Just mempty else Nothing -- We need some type magic to reduce this. - | Just (x :: EpAnn Anchor) <- cast x = Just mempty + | Just (x :: EpAnn EpaLocation) <- cast x = Just mempty | Just (x :: EpAnn AnnContext) <- cast x = Just mempty | Just (x :: EpAnn AnnExplicitSum) <- cast x = Just mempty | Just (x :: EpAnn AnnFieldLabel) <- cast x = Just mempty - | Just (x :: EpAnn AnnList) <- cast x = Just mempty + | Just (x :: EpAnn (AnnList [EpToken ","])) <- cast x = Just mempty | Just (x :: EpAnn AnnListItem) <- cast x = Just mempty | Just (x :: EpAnn AnnParen) <- cast x = Just mempty | Just (x :: EpAnn AnnPragma) <- cast x = Just mempty @@ -135,8 +135,6 @@ unify' nm root x y | Just (x :: EpAnn HsRuleAnn) <- cast x = Just mempty | Just (x :: EpAnn NameAnn) <- cast x = Just mempty | Just (x :: EpAnn NoEpAnns) <- cast x = Just mempty - | Just (x :: EpAnn [AddEpAnn]) <- cast x = Just mempty - | Just (x :: EpAnn (AddEpAnn, AddEpAnn)) <- cast x = Just mempty | Just (x :: EpToken "let") <- cast x = Just mempty | Just (x :: EpToken "in") <- cast x = Just mempty | Just (x :: EpToken "@") <- cast x = Just mempty @@ -164,7 +162,7 @@ unifyComposed' nm x1 y11 dot y12 = ((, Just y11) <$> unifyExp' nm False x1 y12) <|> case y12 of (L _ (OpApp _ y121 dot' y122)) | isDot dot' -> - unifyComposed' nm x1 (noLocA (OpApp noAnn y11 dot y121)) dot' y122 + unifyComposed' nm x1 (noLocA (OpApp noExtField y11 dot y121)) dot' y122 _ -> Nothing -- unifyExp handles the cases where both x and y are HsApp, or y is OpApp. Otherwise, diff --git a/src/GHC/Util/View.hs b/src/GHC/Util/View.hs index fd392dba1..e283a63fa 100644 --- a/src/GHC/Util/View.hs +++ b/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 _))))]))) diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs index 57a214c90..7ecce269d 100644 --- a/src/Hint/Bracket.hs +++ b/src/Hint/Bracket.hs @@ -287,16 +287,16 @@ dollar = concatMap f . universe ++ -- Special case of (v1 . v2) <$> v3 [ (suggest "Redundant bracket" (reLoc x) (reLoc y) [r]){ideaSpan = locA locPar} | L _ (OpApp _ (L locPar (HsPar _ o1@(L locNoPar (OpApp _ _ (isDot -> True) _)))) o2 v3) <- [x], varToStr o2 == "<$>" - , let y = noLocA (OpApp noAnn o1 o2 v3) :: LHsExpr GhcPs + , let y = noLocA (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs , let r = Replace Expr (toRefactSrcSpan (locA locPar)) [("a", toRefactSrcSpan (locA locNoPar))] "a"] ++ [ suggest "Redundant section" (reLoc x) (reLoc y) [r] | L _ (HsApp _ (L _ (HsPar _ (L _ (SectionL _ a b)))) c) <- [x] -- , error $ show (unsafePrettyPrint a, gshow b, unsafePrettyPrint c) - , let y = noLocA $ OpApp noAnn a b c :: LHsExpr GhcPs + , let y = noLocA $ OpApp noExtField a b c :: LHsExpr GhcPs , let r = Replace Expr (toSSA x) [("x", toSSA a), ("op", toSSA b), ("y", toSSA c)] "x op y"] splitInfix :: LHsExpr GhcPs -> [(LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)] splitInfix (L l (OpApp _ lhs op rhs)) = - [(L l . OpApp noAnn lhs op, rhs), (\lhs -> L l (OpApp noAnn lhs op rhs), lhs)] + [(L l . OpApp noExtField lhs op, rhs), (\lhs -> L l (OpApp noExtField lhs op rhs), lhs)] splitInfix _ = [] diff --git a/src/Hint/Comment.hs b/src/Hint/Comment.hs index b66c632ab..b8ae2be78 100644 --- a/src/Hint/Comment.hs +++ b/src/Hint/Comment.hs @@ -46,7 +46,7 @@ commentHint _ m = concatMap chk (ghcComments m) grab :: String -> LEpaComment -> String -> Idea grab msg o@(L pos _) s2 = let s1 = commentText o - loc = RealSrcSpan (anchor pos) GHC.Data.Strict.Nothing + loc = RealSrcSpan (epaLocationRealSrcSpan pos) GHC.Data.Strict.Nothing in rawIdea Suggestion msg loc (f s1) (Just $ f s2) [] (refact loc) where f s = if isCommentMultiline o then "{-" ++ s ++ "-}" else "--" ++ s diff --git a/src/Hint/Duplicate.hs b/src/Hint/Duplicate.hs index 166de9b6e..8ff83db0c 100644 --- a/src/Hint/Duplicate.hs +++ b/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) diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs index a8577ec02..a2f6ddf37 100644 --- a/src/Hint/Extensions.hs +++ b/src/Hint/Extensions.hs @@ -301,7 +301,7 @@ extensionsHint :: ModuHint extensionsHint _ x = [ rawIdea Hint.Type.Warning "Unused LANGUAGE pragma" - (RealSrcSpan (anchor sl) GHC.Data.Strict.Nothing) + (RealSrcSpan (epaLocationRealSrcSpan sl) GHC.Data.Strict.Nothing) (comment_ (mkLanguagePragmas sl exts)) (Just newPragma) ( [RequiresExtension (show gone) | (_, Just x) <- before \\ after, gone <- Map.findWithDefault [] x disappear] ++ diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs index ce27bf199..dbdb1411a 100644 --- a/src/Hint/Lambda.hs +++ b/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 noExtField 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 } ] diff --git a/src/Hint/List.hs b/src/Hint/List.hs index f78e4128e..93fbf86ab 100644 --- a/src/Hint/List.hs +++ b/src/Hint/List.hs @@ -260,7 +260,7 @@ useCons False (view -> App2 op x y) | varToStr op == "++" f _ = Nothing gen :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs - gen x = noLocA . OpApp noAnn x (noLocA (HsVar noExtField (noLocA consDataCon_RDR))) + gen x = noLocA . OpApp noExtField x (noLocA (HsVar noExtField (noLocA consDataCon_RDR))) useCons _ _ = Nothing typeListChar :: LHsType GhcPs diff --git a/src/Hint/ListRec.hs b/src/Hint/ListRec.hs index f609849e4..53c0e62ab 100644 --- a/src/Hint/ListRec.hs +++ b/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=noExtField,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) diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs index e6568dbcb..e5c5e10e4 100644 --- a/src/Hint/Match.hs +++ b/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 diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs index 49fd016b3..07a1198a0 100644 --- a/src/Hint/Monad.hs +++ b/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 @@ -121,7 +120,7 @@ monadExp decl parentDo parentExpr x = (view -> App2 op x1 x2) | isTag ">>" op -> f x1 (view -> App2 op x1 (view -> LamConst1 _)) | isTag ">>=" op -> f x1 (L l (HsApp _ op x)) | isTag "void" op -> seenVoid (L l . HsApp noExtField op) x - (L l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (L l . OpApp noAnn op dol) x + (L l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (L l . OpApp noExtField op dol) x (L loc (HsDo _ ctx (L loc2 [L loc3 (BodyStmt _ y _ _ )]))) -> let doOrMDo = case ctx of MDoExpr _ -> "mdo"; _ -> "do" in [ ideaRemove Ignore ("Redundant " ++ doOrMDo) (doSpan doOrMDo (locA loc)) doOrMDo [Replace Expr (toSSA x) [("y", toSSA y)] "y"] @@ -192,7 +191,7 @@ modifyAppHead f = go id go :: (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> (LHsExpr GhcPs, Maybe a) go wrap (L l (HsPar _ x)) = go (wrap . L l . \y -> HsPar noAnn y) x go wrap (L l (HsApp _ x y)) = go (\x -> wrap $ L l (HsApp noExtField x y)) x - go wrap (L l (OpApp _ x op y)) | isDol op = go (\x -> wrap $ L l (OpApp noAnn x op y)) x + go wrap (L l (OpApp _ x op y)) | isDol op = go (\x -> wrap $ L l (OpApp noExtField x op y)) x go wrap (L l (HsVar _ x)) = (wrap (L l (HsVar NoExtField x')), Just a) where (x', a) = f x go _ expr = (expr, Nothing) @@ -208,8 +207,8 @@ monadNoResult :: String -> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> monadNoResult inside wrap (L l (HsPar _ x)) = monadNoResult inside (wrap . nlHsPar) x monadNoResult inside wrap (L l (HsApp _ x y)) = monadNoResult inside (\x -> wrap $ L l (HsApp noExtField x y)) x monadNoResult inside wrap (L l (OpApp _ x tag@(L _ (HsVar _ (L _ op))) y)) - | isDol tag = monadNoResult inside (\x -> wrap $ L l (OpApp noAnn x tag y)) x - | occNameStr op == ">>=" = monadNoResult inside (wrap . L l . OpApp noAnn x tag) y + | isDol tag = monadNoResult inside (\x -> wrap $ L l (OpApp noExtField x tag y)) x + | occNameStr op == ">>=" = monadNoResult inside (wrap . L l . OpApp noExtField x tag) y monadNoResult inside wrap x | x2 : _ <- filter (`isTag` x) badFuncs , let x3 = x2 ++ "_" @@ -261,7 +260,7 @@ monadStep wrap , q@(L _ (BodyStmt _ (fromApplies -> (ret:f:fs, view -> Var_ v)) _ _))] | isReturn ret, notDol x, u == v, length fs < 3, all isSimple (f : fs), v `notElem` vars (f : fs) = - [warn "Use <$>" (reLoc (wrap o)) (reLoc (wrap [noLocA $ BodyStmt noExtField (noLocA $ OpApp noAnn (foldl' (\acc e -> noLocA $ OpApp noAnn acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr])) + [warn "Use <$>" (reLoc (wrap o)) (reLoc (wrap [noLocA $ BodyStmt noExtField (noLocA $ OpApp noExtField (foldl' (\acc e -> noLocA $ OpApp noExtField acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr])) [Replace Stmt (toSSA g) (("x", toSSA x):zip vs (toSSA <$> f:fs)) (intercalate " . " (take (length fs + 1) vs) ++ " <$> x"), Delete Stmt (toSSA q)]] where isSimple (fromApps -> xs) = all isAtom (x : xs) @@ -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 noExtField (FunRhs p Prefix NoSrcStrict noAnn) (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 diff --git a/src/Hint/NewType.hs b/src/Hint/NewType.hs index b63109862..d06be1a36 100644 --- a/src/Hint/NewType.hs +++ b/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 diff --git a/src/Hint/Pattern.hs b/src/Hint/Pattern.hs index 212e9c082..1b6425479 100644 --- a/src/Hint/Pattern.hs +++ b/src/Hint/Pattern.hs @@ -69,11 +69,10 @@ import Data.Either import Refact.Types hiding (RType(Pattern, Match), SrcSpan) import Refact.Types qualified as R (RType(Pattern, Match), SrcSpan) -import GHC.Hs +import GHC.Hs hiding(asPattern) import GHC.Types.SrcLoc import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence -import GHC.Data.Bag import GHC.Types.Basic hiding (Pattern) import GHC.Data.Strict qualified @@ -163,7 +162,7 @@ hints _ (Pattern l t pats bod@(GRHSs _ _ binds)) | f binds = [suggestRemove "Redundant where" whereSpan "where" [ {- TODO refactoring for redundant where -} ]] where f :: HsLocalBinds GhcPs -> Bool - f (HsValBinds _ (ValBinds _ bag _)) = isEmptyBag bag + f (HsValBinds _ (ValBinds _ l _)) = null l f (HsIPBinds _ (IPBinds _ l)) = null l f _ = False whereSpan = case l of @@ -195,14 +194,14 @@ 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 noExtField 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. patHint :: Bool -> Bool -> LPat GhcPs -> [Idea] patHint _ _ o@(L _ (ConPat _ name (PrefixCon _ args))) | length args >= 3 && all isPWildcard args = - let rec_fields = HsRecFields [] Nothing :: HsRecFields GhcPs (LPat GhcPs) + let rec_fields = HsRecFields noExtField [] Nothing :: HsRecFields GhcPs (LPat GhcPs) new = noLocA $ ConPat noAnn name (RecCon rec_fields) :: LPat GhcPs in [suggest "Use record patterns" (reLoc o) (reLoc new) [Replace R.Pattern (toSSA o) [] (unsafePrettyPrint new)]] @@ -239,11 +238,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 diff --git a/src/Hint/Smell.hs b/src/Hint/Smell.hs index f14798fcd..780923c8c 100644 --- a/src/Hint/Smell.hs +++ b/src/Hint/Smell.hs @@ -86,7 +86,6 @@ import Data.Map qualified as Map import GHC.Utils.Outputable import GHC.Types.Basic import GHC.Hs -import GHC.Data.Bag import GHC.Types.SrcLoc import GHC.Types.Name.Reader import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable @@ -151,7 +150,7 @@ rhsSpans ctx (L _ r@(GRHS _ _ (L l _))) = -- The spans of a 'where' clause are the spans of its bindings. whereSpans :: HsLocalBinds GhcPs -> [(SrcSpan, Idea)] whereSpans (HsValBinds _ (ValBinds _ bs _)) = - concatMap (declSpans . (\(L loc bind) -> L loc (ValD noExtField bind))) (bagToList bs) + concatMap (declSpans . (\(L loc bind) -> L loc (ValD noExtField bind))) bs whereSpans _ = [] spanLength :: SrcSpan -> Int diff --git a/src/Hint/Unsafe.hs b/src/Hint/Unsafe.hs index f7370deaa..b02aee30e 100644 --- a/src/Hint/Unsafe.hs +++ b/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'.