diff --git a/.gitignore b/.gitignore index 56e532a2..ebc9e86a 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,4 @@ stack*.yaml.lock .\#*\# /.sl/ *.dump-hi +.DS_Store diff --git a/cabal.project b/cabal.project new file mode 100644 index 00000000..575fc59f --- /dev/null +++ b/cabal.project @@ -0,0 +1 @@ +packages: ./hlint.cabal diff --git a/hlint.cabal b/hlint.cabal index fbfd0069..a705e0db 100644 --- a/hlint.cabal +++ b/hlint.cabal @@ -1,7 +1,7 @@ cabal-version: 1.18 build-type: Simple name: hlint -version: 3.8 +version: 3.8.1 license: BSD3 license-file: LICENSE category: Development @@ -36,7 +36,7 @@ extra-source-files: extra-doc-files: README.md CHANGES.txt -tested-with: GHC==9.8, GHC==9.6, GHC==9.4 +tested-with: GHC==9.10, GHC==9.8, GHC==9.6 source-repository head type: git @@ -81,16 +81,16 @@ library deriving-aeson >= 0.2, filepattern >= 0.1.1 - if !flag(ghc-lib) && impl(ghc >= 9.8.1) && impl(ghc < 9.9.0) + if !flag(ghc-lib) && impl(ghc >= 9.10.1) && impl(ghc < 9.11.0) build-depends: - ghc == 9.8.*, + ghc == 9.10.*, ghc-boot-th, ghc-boot else build-depends: - ghc-lib-parser == 9.8.* + ghc-lib-parser == 9.10.* build-depends: - ghc-lib-parser-ex >= 9.8.0.2 && < 9.8.1 + ghc-lib-parser-ex >= 9.10.0.0 && < 9.11.0 if flag(gpl) build-depends: hscolour >= 1.21 diff --git a/src/CmdLine.hs b/src/CmdLine.hs index d318da2f..8f0c33db 100644 --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -327,7 +327,9 @@ getExtensions args = (lang, foldl f (startExts, []) exts) langs, exts :: [String] (langs, exts) = partition (isJust . flip lookup ls) args - ls = [ (show x, x) | x <- [Haskell98, Haskell2010 , GHC2021] ] + + ls :: [(String, Language)] + ls = [(show x, x) | x <- enumerate] f :: ([Extension], [Extension]) -> String -> ([Extension], [Extension]) f (a, e) ('N':'o':x) | Just x <- GhclibParserEx.readExtension x, let xs = expandDisable x = (deletes xs a, xs ++ deletes xs e) diff --git a/src/Config/Compute.hs b/src/Config/Compute.hs index 43973b42..a11abd85 100644 --- a/src/Config/Compute.hs +++ b/src/Config/Compute.hs @@ -53,17 +53,17 @@ findSetting x = [] findBind :: HsBind GhcPs -> [Setting] findBind VarBind{var_id, var_rhs} = findExp var_id [] $ unLoc var_rhs -findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noExtField fun_matches +findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noAnn LamSingle fun_matches findBind _ = [] findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting] -findExp name vs (HsLam _ MG{mg_alts=L _ [L _ Match{m_pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=(EmptyLocalBinds _)}}]}) +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{} = [] findExp name vs HsVar{} = [] findExp name vs (OpApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $ - HsApp EpAnnNotUsed x $ nlHsPar $ noLocA $ HsApp EpAnnNotUsed y $ noLocA $ mkVar "_hlint" + HsApp noExtField x $ nlHsPar $ noLocA $ HsApp noExtField 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 $ nlHsPar y + f (OpApp _ x dol y) | isDol dol = HsApp noExtField x $ nlHsPar y f x = x diff --git a/src/Config/Haskell.hs b/src/Config/Haskell.hs index 9de45382..dd79af99 100644 --- a/src/Config/Haskell.hs +++ b/src/Config/Haskell.hs @@ -45,7 +45,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 diff --git a/src/Config/Yaml.hs b/src/Config/Yaml.hs index 423150fe..6071c8e1 100644 --- a/src/Config/Yaml.hs +++ b/src/Config/Yaml.hs @@ -442,7 +442,7 @@ settingsFromConfigYaml (mconcat -> ConfigYaml configs) = settings ++ concatMap f scope'= asScope' packageMap' (map (fmap unextendInstances) groupImports) asScope' :: Map.HashMap String [LocatedA (ImportDecl GhcPs)] -> [Either String (LocatedA (ImportDecl GhcPs))] -> Scope -asScope' packages xs = scopeCreate (HsModule (XModulePs EpAnnNotUsed NoLayoutInfo Nothing Nothing) Nothing Nothing (concatMap f xs) []) +asScope' packages xs = scopeCreate (HsModule (XModulePs noAnn EpNoLayout Nothing Nothing) Nothing Nothing (concatMap f xs) []) where f (Right x) = [x] f (Left x) | Just pkg <- Map.lookup x packages = pkg diff --git a/src/Fixity.hs b/src/Fixity.hs index 48970e3d..06e88418 100644 --- a/src/Fixity.hs +++ b/src/Fixity.hs @@ -14,7 +14,6 @@ import GHC.Types.Name.Reader import GHC.Types.Fixity import GHC.Types.SourceText import GHC.Parser.Annotation -import Language.Haskell.Syntax.Extension import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import Language.Haskell.GhclibParserEx.Fixity @@ -52,7 +51,7 @@ fromFixity (name, Fixity _ i dir) = (name, assoc dir, i) InfixN -> NotAssociative toFixitySig :: FixityInfo -> FixitySig GhcPs -toFixitySig (toFixity -> (name, x)) = FixitySig noExtField [noLocA $ mkRdrUnqual (mkVarOcc name)] x +toFixitySig (toFixity -> (name, x)) = FixitySig NoNamespaceSpecifier [noLocA $ mkRdrUnqual (mkVarOcc name)] x defaultFixities :: [FixityInfo] defaultFixities = map fromFixity $ customFixities ++ baseFixities ++ lensFixities ++ otherFixities diff --git a/src/GHC/All.hs b/src/GHC/All.hs index 6ae63951..e72005c9 100644 --- a/src/GHC/All.hs +++ b/src/GHC/All.hs @@ -103,7 +103,7 @@ firstDeclComments :: ModuleEx -> EpAnnComments firstDeclComments m = case hsmodDecls . unLoc . ghcModule $ m of [] -> EpaCommentsBalanced [] [] - L (SrcSpanAnn ann _) _ : _ -> comments ann + L ann _ : _ -> comments ann -- | The error handler invoked when GHC parsing has failed. ghcFailOpParseModuleEx :: String diff --git a/src/GHC/Util/ApiAnnotation.hs b/src/GHC/Util/ApiAnnotation.hs index 48f92cbc..5497e4c9 100644 --- a/src/GHC/Util/ApiAnnotation.hs +++ b/src/GHC/Util/ApiAnnotation.hs @@ -45,7 +45,6 @@ comment_ (L _ (EpaComment (EpaDocComment ds ) _)) = renderHsDocString ds comment_ (L _ (EpaComment (EpaDocOptions s) _)) = s 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 @@ -55,7 +54,6 @@ commentText = trimCommentDelims . comment_ -- `EpAnn` comments :: EpAnn ann -> EpAnnComments comments EpAnn{ GHC.Parser.Annotation.comments = result } = result -comments EpAnnNotUsed = emptyComments isCommentMultiline :: LEpaComment -> Bool isCommentMultiline (L _ (EpaComment (EpaBlockComment _) _)) = True @@ -107,10 +105,10 @@ languagePragmas ps = , let exts = map trim (splitOn "," rest)] -- Given a list of flags, make a GHC options pragma. -mkFlags :: Anchor -> [String] -> LEpaComment +mkFlags :: NoCommentsLocation -> [String] -> LEpaComment mkFlags anc flags = L anc $ EpaComment (EpaBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")) (anchor anc) -mkLanguagePragmas :: Anchor -> [String] -> LEpaComment +mkLanguagePragmas :: NoCommentsLocation -> [String] -> LEpaComment mkLanguagePragmas anc exts = L anc $ EpaComment (EpaBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")) (anchor anc) diff --git a/src/GHC/Util/Brackets.hs b/src/GHC/Util/Brackets.hs index f344ded4..020b60c6 100644 --- a/src/GHC/Util/Brackets.hs +++ b/src/GHC/Util/Brackets.hs @@ -26,9 +26,9 @@ 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 = nlHsPar @@ -108,7 +108,7 @@ 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 = nlParPat @@ -151,7 +151,7 @@ instance Brackets (LocatedA (Pat GhcPs)) where instance Brackets (LocatedA (HsType GhcPs)) where remParen (L _ (HsParTy _ x)) = Just x remParen _ = Nothing - addParen e = noLocA $ HsParTy EpAnnNotUsed e + addParen e = noLocA $ HsParTy noAnn e isAtom (L _ x) = case x of HsParTy{} -> True diff --git a/src/GHC/Util/FreeVars.hs b/src/GHC/Util/FreeVars.hs index 89ca6552..436afb3b 100644 --- a/src/GHC/Util/FreeVars.hs +++ b/src/GHC/Util/FreeVars.hs @@ -99,10 +99,10 @@ unqualNames _ = [] instance FreeVars (LocatedA (HsExpr GhcPs)) where freeVars (L _ (HsVar _ x)) = Set.fromList $ unqualNames x -- Variable. freeVars (L _ (HsUnboundVar _ x)) = Set.fromList [rdrNameOcc 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 _ (HsLam _ LamSingle mg)) = free (allVars mg) -- Lambda abstraction. Currently always a single match. + freeVars (L _ (HsLam _ _ 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))) = snd $ foldl' alg mempty stmts -- Do block. where alg :: @@ -169,11 +169,11 @@ instance FreeVars (HsTupArg GhcPs) where freeVars (Present _ args) = freeVars args freeVars _ = mempty -instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where +instance FreeVars (LocatedA (HsFieldBind (LocatedA (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 (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where +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 @@ -182,7 +182,7 @@ 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 _ (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 _ (NPlusKPat _ n _ _ _ _)) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) -- n+k pattern. allVars (L _ (ViewPat _ e p)) = freeVars_ e <> allVars p -- View pattern. @@ -203,7 +203,7 @@ instance AllVars (LocatedA (Pat GhcPs)) where allVars p = allVars $ children p -instance AllVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) (LocatedA (Pat GhcPs)))) where +instance AllVars (LocatedA (HsFieldBind (LocatedA (FieldOcc GhcPs)) (LocatedA (Pat GhcPs)))) where allVars (L _ (HsFieldBind _ _ x _)) = allVars x instance AllVars (LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))) where @@ -241,7 +241,7 @@ instance AllVars (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where 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. -instance AllVars (HsStmtContext GhcPs) where +instance AllVars (HsStmtContext (GenLocated SrcSpanAnnN RdrName)) where allVars (PatGuard FunRhs{mc_fun=n}) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) allVars ParStmtCtxt{} = mempty -- Come back to it. allVars TransStmtCtxt{} = mempty -- Come back to it. diff --git a/src/GHC/Util/HsExpr.hs b/src/GHC/Util/HsExpr.hs index e9396bc0..9b58002c 100644 --- a/src/GHC/Util/HsExpr.hs +++ b/src/GHC/Util/HsExpr.hs @@ -49,7 +49,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 EpAnnNotUsed x (noLocA $ HsVar noExtField (noLocA $ mkVarUnqual (fsLit "."))) y +dotApp x y = noLocA $ OpApp noAnn 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 +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 noExtField (MG (Generated DoPmc) (noLocA [noLocA $ Match EpAnnNotUsed LambdaExpr vs (GRHSs emptyComments [noLocA $ GRHS EpAnnNotUsed [] body] (EmptyLocalBinds noExtField))])) +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))])) -- | 'paren e' wraps 'e' in parens if 'e' is non-atomic. paren :: LHsExpr GhcPs -> LHsExpr GhcPs @@ -72,7 +72,7 @@ universeParentExp xs = concat [(Nothing, x) : f x | x <- childrenBi xs] apps :: [LHsExpr GhcPs] -> LHsExpr GhcPs -apps = foldl1' mkApp where mkApp x y = noLocA (HsApp EpAnnNotUsed x y) +apps = foldl1' mkApp where mkApp x y = noLocA (HsApp noExtField x y) fromApps :: LHsExpr GhcPs -> [LHsExpr GhcPs] fromApps (L _ (HsApp _ x y)) = fromApps x ++ [y] @@ -86,7 +86,7 @@ universeApps :: LHsExpr GhcPs -> [LHsExpr GhcPs] universeApps x = x : concatMap universeApps (childrenApps x) descendAppsM :: Monad m => (LHsExpr GhcPs -> m (LHsExpr GhcPs)) -> LHsExpr GhcPs -> m (LHsExpr GhcPs) -descendAppsM f (L l (HsApp _ x y)) = (\x y -> L l $ HsApp EpAnnNotUsed x y) <$> descendAppsM f x <*> f y +descendAppsM f (L l (HsApp _ x y)) = (\x y -> L l $ HsApp noExtField x y) <$> descendAppsM f x <*> f y descendAppsM f x = descendM f x transformAppsM :: Monad m => (LHsExpr GhcPs -> m (LHsExpr GhcPs)) -> LHsExpr GhcPs -> m (LHsExpr GhcPs) @@ -117,12 +117,12 @@ rebracket1 = descendBracket (True, ) -- A list of application, with any necessary brackets. appsBracket :: [LHsExpr GhcPs] -> LHsExpr GhcPs appsBracket = foldl1 mkApp - where mkApp x y = rebracket1 (noLocA $ HsApp EpAnnNotUsed x y) + where mkApp x y = rebracket1 (noLocA $ HsApp noExtField x y) simplifyExp :: LHsExpr GhcPs -> LHsExpr GhcPs -- Replace appliciations 'f $ x' with 'f (x)'. -simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp EpAnnNotUsed x (nlHsPar y)) -simplifyExp e@(L _ (HsLet _ _ ((HsValBinds _ (ValBinds _ binds []))) _ z)) = +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 _))))])))] @@ -159,7 +159,7 @@ niceLambdaR :: [String] niceLambdaR xs (SimpleLambda [] x) = niceLambdaR xs x -- Rewrite @\xs -> (e)@ as @\xs -> e@. -niceLambdaR xs (L _ (HsPar _ _ x _)) = niceLambdaR xs x +niceLambdaR xs (L _ (HsPar _ x)) = niceLambdaR xs x -- @\vs v -> ($) e v@ ==> @\vs -> e@ -- @\vs v -> e $ v@ ==> @\vs -> e@ @@ -177,7 +177,7 @@ niceLambdaR [v] (L _ (OpApp _ e f (view -> Var_ v'))) , vars e `disjoint` [v] , L _ (HsVar _ (L _ fname)) <- f , isSymOcc $ rdrNameOcc fname - = let res = nlHsPar $ noLocA $ SectionL EpAnnNotUsed e f + = let res = nlHsPar $ noLocA $ SectionL noExtField e f in (res, \s -> [Replace Expr s [] (unsafePrettyPrint res)]) -- @\vs v -> f x v@ ==> @\vs -> f x@ @@ -198,7 +198,7 @@ niceLambdaR xs (SimpleLambda ((view -> PVar_ v):vs) x) -- lexeme, or it all gets too complex). niceLambdaR [x] (view -> App2 op@(L _ (HsVar _ (L _ tag))) l r) | isLexeme r, view l == Var_ x, x `notElem` vars r, allowRightSection (occNameStr tag) = - let e = rebracket1 $ addParen (noLocA $ SectionR EpAnnNotUsed op r) + let e = rebracket1 $ addParen (noLocA $ SectionR noExtField op r) in (e, \s -> [Replace Expr s [] (unsafePrettyPrint e)]) -- Rewrite (1) @\x -> f (b x)@ as @f . b@, (2) @\x -> f $ b x@ as @f . b@. niceLambdaR [x] y @@ -213,7 +213,7 @@ niceLambdaR [x] y factor (L _ (OpApp _ y op (factor -> Just (z, ss))))| isDol op = let r = niceDotApp y z in if astEq r z then Just (r, ss) else Just (r, y : ss) - factor (L _ (HsPar _ _ y@(L _ HsApp{}) _)) = factor y + factor (L _ (HsPar _ y@(L _ HsApp{}))) = factor y factor _ = Nothing mkRefact :: [LHsExpr GhcPs] -> R.SrcSpan -> Refactoring R.SrcSpan mkRefact subts s = @@ -231,7 +231,7 @@ niceLambdaR [x, y] (view -> App2 op (view -> Var_ y1) (view -> Var_ x1)) ) where gen :: LHsExpr GhcPs -> LHsExpr GhcPs - gen = noLocA . HsApp EpAnnNotUsed (strToVar "flip") + gen = noLocA . HsApp noExtField (strToVar "flip") . if isAtom op then id else addParen -- We're done factoring, but have no variables left, so we shouldn't make a lambda. @@ -239,20 +239,20 @@ niceLambdaR [x, y] (view -> App2 op (view -> Var_ y1) (view -> Var_ x1)) niceLambdaR [] e = (e, \s -> [Replace Expr s [("a", toSSA e)] "a"]) -- Base case. Just a good old fashioned lambda. niceLambdaR ss e = - let grhs = noLocA $ GRHS EpAnnNotUsed [] e :: LGRHS GhcPs (LHsExpr GhcPs) + let grhs = noLocA $ GRHS noAnn [] e :: LGRHS GhcPs (LHsExpr GhcPs) grhss = GRHSs {grhssExt = emptyComments, grhssGRHSs=[grhs], grhssLocalBinds=EmptyLocalBinds noExtField} - match = noLocA $ Match {m_ext=EpAnnNotUsed, m_ctxt=LambdaExpr, m_pats=map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs) - matchGroup = MG {mg_ext=Generated DoPmc, mg_alts=noLocA [match]} - in (noLocA $ HsLam noExtField matchGroup, const []) + match = noLocA $ Match {m_ext=noAnn, m_ctxt=LamAlt LamSingle, m_pats=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 []) -- 'case' and 'if' expressions have branches, nothing else does (this -- doesn't consider 'HsMultiIf' perhaps it should?). replaceBranches :: LHsExpr GhcPs -> ([LHsExpr GhcPs], [LHsExpr GhcPs] -> LHsExpr GhcPs) -replaceBranches (L l (HsIf _ a b c)) = ([b, c], \[b, c] -> L l (HsIf EpAnnNotUsed a b c)) +replaceBranches (L l (HsIf _ a b c)) = ([b, c], \[b, c] -> L l (HsIf noAnn a b c)) replaceBranches (L s (HsCase _ a (MG FromSource (L l bs)))) = - (concatMap f bs, L s . HsCase EpAnnNotUsed a . MG (Generated DoPmc). L l . g bs) + (concatMap f bs, L s . HsCase noAnn a . MG (Generated OtherExpansion SkipPmc). L l . g bs) where f :: LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs] f (L _ (Match _ CaseAlt _ (GRHSs _ xs _))) = [x | (L _ (GRHS _ _ x)) <- xs] @@ -260,7 +260,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 EpAnnNotUsed CaseAlt a (GRHSs emptyComments [L a (GRHS EpAnnNotUsed gs x) | (L a (GRHS _ gs _), x) <- zip ns as] b)) : g rest bs + 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 where (as, bs) = splitAt (length ns) xs g [] [] = [] g _ _ = error "GHC.Util.HsExpr.replaceBranches': internal invariant failed, lists are of differing lengths" @@ -298,7 +298,7 @@ descendBracketOld op x = (descendIndex g1 x, descendIndex' g2 x) g1 a b = fst (g a b) g2 a b = writer $ snd (g a b) - f i (L _ (HsPar _ _ y _)) z w + f i (L _ (HsPar _ y)) z w | not $ needBracketOld i x y = (y, removeBracket z) where -- If the template expr is a Var, record it so that we can remove the brackets diff --git a/src/GHC/Util/Scope.hs b/src/GHC/Util/Scope.hs index 93ff8982..8fe17c5d 100644 --- a/src/GHC/Util/Scope.hs +++ b/src/GHC/Util/Scope.hs @@ -131,10 +131,10 @@ possImport (L _ i) (L _ (Unqual x)) = tag = occNameString x g :: LIE GhcPs -> Maybe Bool -- Does this import cover the name 'x'? - g (L _ (IEVar _ y)) = Just $ tag == unwrapName y - g (L _ (IEThingAbs _ y)) = Just $ tag == unwrapName y - g (L _ (IEThingAll _ y)) = if tag == unwrapName y then Just True else Nothing - g (L _ (IEThingWith _ y _wildcard ys)) = Just $ tag `elem` unwrapName y : map unwrapName ys + g (L _ (IEVar _ y _)) = Just $ tag == unwrapName y + g (L _ (IEThingAbs _ y _)) = Just $ tag == unwrapName y + g (L _ (IEThingAll _ y _)) = if tag == unwrapName y then Just True else Nothing + g (L _ (IEThingWith _ y _ ys _)) = Just $ tag `elem` unwrapName y : map unwrapName ys g _ = Just False unwrapName :: LIEWrappedName GhcPs -> String diff --git a/src/GHC/Util/SrcLoc.hs b/src/GHC/Util/SrcLoc.hs index d4750b59..de3942d6 100644 --- a/src/GHC/Util/SrcLoc.hs +++ b/src/GHC/Util/SrcLoc.hs @@ -17,10 +17,10 @@ import Data.Default import Data.Data import Data.Generics.Uniplate.DataOnly --- Get the 'SrcSpan' out of a value located by an 'Anchor' (e.g. --- comments). -getAncLoc :: GenLocated Anchor a -> SrcSpan -getAncLoc o = RealSrcSpan (anchor (getLoc o)) GHC.Data.Strict.Nothing +-- 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 -- '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 434a9589..08616410 100644 --- a/src/GHC/Util/Unify.hs +++ b/src/GHC/Util/Unify.hs @@ -1,5 +1,6 @@ {-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables, TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-} +{-# LANGUAGE DataKinds #-} module GHC.Util.Unify( Subst(..), fromSubst, @@ -77,13 +78,13 @@ 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 EpAnnNotUsed lhs y rhs)) + | Just y <- lookup (rdrNameStr x) bind = Just (L loc (OpApp noAnn lhs y rhs)) -- Left sections. exp (L loc (SectionL _ exp (L _ (HsVar _ x)))) - | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionL EpAnnNotUsed exp y)) + | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionL noExtField exp y)) -- Right sections. exp (L loc (SectionR _ (L _ (HsVar _ x)) exp)) - | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionR EpAnnNotUsed y exp)) + | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionR noExtField y exp)) exp _ = Nothing pat :: LPat GhcPs -> LPat GhcPs @@ -95,7 +96,7 @@ substitute (Subst bind) = transformBracketOld exp . transformBi pat . transformB typ :: LHsType GhcPs -> LHsType GhcPs -- Type variables. typ (L _ (HsTyVar _ _ x)) - | Just (L _ (HsAppType _ _ _ (HsWC _ y))) <- lookup (rdrNameStr x) bind = y + | Just (L _ (HsAppType _ _ (HsWC _ y))) <- lookup (rdrNameStr x) bind = y typ x = x :: LHsType GhcPs @@ -126,7 +127,6 @@ unify' nm root x y | Just (x :: EpAnn AnnsIf) <- cast x = Just mempty | Just (x :: EpAnn AnnSig) <- cast x = Just mempty | Just (x :: EpAnn AnnsModule) <- cast x = Just mempty - | Just (x :: EpAnn EpaLocation) <- cast x = Just mempty | Just (x :: EpAnn EpAnnHsCase) <- cast x = Just mempty | Just (x :: EpAnn EpAnnImportDecl) <- cast x = Just mempty | Just (x :: EpAnn EpAnnSumPat) <- cast x = Just mempty @@ -137,6 +137,16 @@ unify' nm root x y | 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 + | Just (x :: EpToken "(") <- cast x = Just mempty + | Just (x :: EpToken ")") <- cast x = Just mempty + | Just (x :: EpToken "type") <- cast x = Just mempty + | Just (x :: EpToken "%") <- cast x = Just mempty + | Just (x :: EpToken "%1") <- cast x = Just mempty + | Just (x :: EpToken "⊸") <- cast x = Just mempty + | Just (x :: EpUniToken "->" "→") <- cast x = Just mempty | Just (x :: TokenLocation) <- cast y = Just mempty | Just (y :: SrcSpan) <- cast y = Just mempty @@ -154,7 +164,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 EpAnnNotUsed y11 dot y121)) dot' y122 + unifyComposed' nm x1 (noLocA (OpApp noAnn y11 dot y121)) dot' y122 _ -> Nothing -- unifyExp handles the cases where both x and y are HsApp, or y is OpApp. Otherwise, @@ -188,7 +198,7 @@ unifyExp nm root x@(L _ (HsApp _ x1 x2)) (L _ (HsApp _ y1 y2)) = -- Attempt #1: rewrite '(fun1 . fun2) arg' as 'fun1 (fun2 arg)', and unify it with 'x'. -- The guard ensures that you don't get duplicate matches because the matching engine -- auto-generates hints in dot-form. - (, Nothing) <$> unifyExp' nm root x (noLocA (HsApp EpAnnNotUsed y11 (noLocA (HsApp EpAnnNotUsed y12 y2)))) + (, Nothing) <$> unifyExp' nm root x (noLocA (HsApp noExtField y11 (noLocA (HsApp noExtField y12 y2)))) else do -- Attempt #2: rewrite '(fun1 . fun2 ... funn) arg' as 'fun1 $ (fun2 ... funn) arg', -- 'fun1 . fun2 $ (fun3 ... funn) arg', 'fun1 . fun2 . fun3 $ (fun4 ... funn) arg', @@ -203,9 +213,9 @@ unifyExp nm root x@(L _ (HsApp _ x1 x2)) (L _ (HsApp _ y1 y2)) = unifyExp nm root x (L _ (OpApp _ lhs2 op2@(L _ (HsVar _ op2')) rhs2)) | (L _ (OpApp _ lhs1 op1@(L _ (HsVar _ op1')) rhs1)) <- x = guard (nm op1' op2') >> (, Nothing) <$> liftA2 (<>) (unifyExp' nm False lhs1 lhs2) (unifyExp' nm False rhs1 rhs2) - | isDol op2 = unifyExp nm root x $ noLocA (HsApp EpAnnNotUsed lhs2 rhs2) - | isAmp op2 = unifyExp nm root x $ noLocA (HsApp EpAnnNotUsed rhs2 lhs2) - | otherwise = unifyExp nm root x $ noLocA (HsApp EpAnnNotUsed (noLocA (HsApp EpAnnNotUsed op2 (addPar lhs2))) (addPar rhs2)) + | isDol op2 = unifyExp nm root x $ noLocA (HsApp noExtField lhs2 rhs2) + | isAmp op2 = unifyExp nm root x $ noLocA (HsApp noExtField rhs2 lhs2) + | otherwise = unifyExp nm root x $ noLocA (HsApp noExtField (noLocA (HsApp noExtField op2 (addPar lhs2))) (addPar rhs2)) where -- add parens around when desugaring the expression, if necessary addPar :: LHsExpr GhcPs -> LHsExpr GhcPs @@ -288,6 +298,6 @@ unifyType' :: NameMatch -> LHsType GhcPs -> LHsType GhcPs -> Maybe (Subst (LHsEx unifyType' nm (L loc (HsTyVar _ _ x)) y = let wc = HsWC noExtField y :: LHsWcType (NoGhcTc GhcPs) unused = strToVar "__unused__" - appType = L loc (HsAppType noExtField unused noHsTok wc) + appType = L loc (HsAppType noAnn unused wc) in Just $ Subst [(rdrNameStr x, appType)] unifyType' nm x y = unifyDef' nm x y diff --git a/src/GHC/Util/View.hs b/src/GHC/Util/View.hs index 0481de3d..fd392dba 100644 --- a/src/GHC/Util/View.hs +++ b/src/GHC/Util/View.hs @@ -18,7 +18,7 @@ fromParen :: LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs) fromParen x = maybe x fromParen $ remParen x fromPParen :: LocatedA (Pat GhcPs) -> LocatedA (Pat GhcPs) -fromPParen (L _ (ParPat _ _ x _ )) = fromPParen x +fromPParen (L _ (ParPat _ x)) = fromPParen x fromPParen x = x class View a b where @@ -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 _ LambdaExpr [L _ WildPat {}] + view (fromParen -> (L _ (HsLam _ _ (MG FromSource (L _ [L _ (Match _ (LamAlt _) [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 _ (MG _ (L _ [L _ (Match _ _ vs (GRHSs _ [L _ (GRHS _ [] body)] ((EmptyLocalBinds _))))]))) +pattern SimpleLambda vs body <- L _ (HsLam _ LamSingle (MG _ (L _ [L _ (Match _ _ vs (GRHSs _ [L _ (GRHS _ [] body)] ((EmptyLocalBinds _))))]))) diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs index 3efc65ea..57a214c9 100644 --- a/src/Hint/Bracket.hs +++ b/src/Hint/Bracket.hs @@ -160,13 +160,13 @@ bracketHint _ _ x = -- Brackets the roots of annotations are fine, so we strip them. annotations :: AnnDecl GhcPs -> AnnDecl GhcPs annotations= descendBi $ \x -> case (x :: LHsExpr GhcPs) of - L _ (HsPar _ _ x _) -> x + L _ (HsPar _ x) -> x x -> x -- Brackets at the root of splices used to be required, but now they aren't splices :: HsDecl GhcPs -> HsDecl GhcPs splices (SpliceD a x) = SpliceD a $ flip descendBi x $ \x -> case (x :: LHsExpr GhcPs) of - L _ (HsPar _ _ x _) -> x + L _ (HsPar _ x) -> x x -> x splices x = x @@ -271,32 +271,32 @@ dollar :: LHsExpr GhcPs -> [Idea] dollar = concatMap f . universe where f x = [ (suggest "Redundant $" (reLoc x) (reLoc y) [r]){ideaSpan = locA (getLoc d)} | L _ (OpApp _ a d b) <- [x], isDol d - , let y = noLocA (HsApp EpAnnNotUsed a b) :: LHsExpr GhcPs + , let y = noLocA (HsApp noExtField a b) :: LHsExpr GhcPs , not $ needBracket 0 y a , not $ needBracket 1 y b , not $ isPartialAtom (Just x) b , let r = Replace Expr (toSSA x) [("a", toSSA a), ("b", toSSA b)] "a b"] ++ [ suggest "Move brackets to avoid $" (reLoc x) (reLoc (t y)) [r] - |(t, e@(L _ (HsPar _ _ (L _ (OpApp _ a1 op1 a2)) _))) <- splitInfix x + |(t, e@(L _ (HsPar _ (L _ (OpApp _ a1 op1 a2))))) <- splitInfix x , isDol op1 , isVar a1 || isApp a1 || isPar a1, not $ isAtom a2 , varToStr a1 /= "select" -- special case for esqueleto, see #224 - , let y = noLocA $ HsApp EpAnnNotUsed a1 (nlHsPar a2) + , let y = noLocA $ HsApp noExtField a1 (nlHsPar a2) , let r = Replace Expr (toSSA e) [("a", toSSA a1), ("b", toSSA a2)] "a (b)" ] ++ -- 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 EpAnnNotUsed o1 o2 v3) :: LHsExpr GhcPs + | 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 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] + | L _ (HsApp _ (L _ (HsPar _ (L _ (SectionL _ a b)))) c) <- [x] -- , error $ show (unsafePrettyPrint a, gshow b, unsafePrettyPrint c) - , let y = noLocA $ OpApp EpAnnNotUsed a b c :: LHsExpr GhcPs + , let y = noLocA $ OpApp noAnn 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 EpAnnNotUsed lhs op, rhs), (\lhs -> L l (OpApp EpAnnNotUsed lhs op rhs), lhs)] + [(L l . OpApp noAnn lhs op, rhs), (\lhs -> L l (OpApp noAnn lhs op rhs), lhs)] splitInfix _ = [] diff --git a/src/Hint/Export.hs b/src/Hint/Export.hs index bc029cba..369d6bd9 100644 --- a/src/Hint/Export.hs +++ b/src/Hint/Export.hs @@ -23,7 +23,7 @@ import GHC.Types.Name.Reader exportHint :: ModuHint exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) ) | Nothing <- exports = - let r = o{ hsmodExports = Just (noLocA [noLocA (IEModuleContents (Nothing, EpAnnNotUsed) name)] )} in + let r = o{ hsmodExports = Just (noLocA [noLocA (IEModuleContents (Nothing, noAnn) name)] )} in [(ignore "Use module export list" (L s o) (noLoc r) []){ideaNote = [Note "an explicit list is usually better"]}] | Just (L _ xs) <- exports , mods <- [x | x <- xs, isMod x] @@ -32,7 +32,7 @@ exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = ex , exports' <- [x | x <- xs, not (matchesModName modName x)] , modName `elem` names = let dots = mkRdrUnqual (mkVarOcc " ... ") - r = o{ hsmodExports = Just (noLocA (noLocA (IEVar Nothing (noLocA (IEName noExtField (noLocA dots)))) : exports') )} + r = o{ hsmodExports = Just (noLocA (noLocA (IEVar Nothing (noLocA (IEName noExtField (noLocA dots))) Nothing) : exports') )} in [ignore "Use explicit module export list" (L s o) (noLoc r) []] where diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs index 57cae8e6..a8577ec0 100644 --- a/src/Hint/Extensions.hs +++ b/src/Hint/Extensions.hs @@ -424,14 +424,10 @@ used EmptyCase = hasS f where f :: HsExpr GhcPs -> Bool f (HsCase _ _ (MG _ (L _ []))) = True - f (HsLamCase _ _ (MG _ (L _ []))) = True + f (HsLam _ LamCase (MG _ (L _ []))) = True f _ = False used KindSignatures = hasT (un :: HsKind GhcPs) used BangPatterns = hasS isPBangPat ||^ hasS isStrictMatch - where - -- Todo: Fix typing bug in ghc-lib-parser-ex. - isStrictMatch :: HsMatchContext GhcPs -> Bool - isStrictMatch = \case FunRhs{mc_strictness=SrcStrict} -> True; _ -> False used TemplateHaskell = hasS (not . isQuasiQuoteSplice) ||^ hasS isTypedSplice used TemplateHaskellQuotes = hasS f where diff --git a/src/Hint/Fixities.hs b/src/Hint/Fixities.hs index 165afb77..4d723bf9 100644 --- a/src/Hint/Fixities.hs +++ b/src/Hint/Fixities.hs @@ -73,7 +73,6 @@ needParenAsChild :: HsExpr p -> Bool needParenAsChild HsLet{} = True needParenAsChild HsDo{} = True needParenAsChild HsLam{} = True -needParenAsChild HsLamCase{} = True needParenAsChild HsCase{} = True needParenAsChild HsIf{} = True needParenAsChild _ = False diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs index 6fe25560..ce27bf19 100644 --- a/src/Hint/Lambda.hs +++ b/src/Hint/Lambda.hs @@ -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 DoPmc) (noLocA [noLocA $ Match EpAnnNotUsed ctxt ps $ GRHSs emptyComments [noLocA $ GRHS EpAnnNotUsed [] b] $ EmptyLocalBinds noExtField])} + origBind {fun_matches = MG (Generated OtherExpansion SkipPmc) (noLocA [noLocA $ Match noAnn ctxt ps $ GRHSs emptyComments [noLocA $ GRHS noAnn [] b] $ EmptyLocalBinds noExtField])} mkSubtsAndTpl newPats newBody = (sub, tpl) where @@ -188,11 +188,11 @@ etaReduce (unsnoc -> Just (ps, view -> PVar_ p)) (L _ (HsApp _ x (view -> Var_ y , y `notElem` vars x , not $ any isQuasiQuoteExpr $ universe x = etaReduce ps x -etaReduce ps (L loc (OpApp _ x (isDol -> True) y)) = etaReduce ps (L loc (HsApp EpAnnNotUsed x y)) +etaReduce ps (L loc (OpApp _ x (isDol -> True) y)) = etaReduce ps (L loc (HsApp noExtField x y)) etaReduce ps x = (ps, x) lambdaExp :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea] -lambdaExp _ o@(L _ (HsPar _ _ (L _ (HsApp _ oper@(L _ (HsVar _ origf@(L _ (rdrNameOcc -> f)))) y)) _)) +lambdaExp _ o@(L _ (HsPar _ (L _ (HsApp _ oper@(L _ (HsVar _ origf@(L _ (rdrNameOcc -> f)))) y)))) | isSymOcc f -- is this an operator? , isAtom y , allowLeftSection $ occNameString f @@ -200,22 +200,22 @@ lambdaExp _ o@(L _ (HsPar _ _ (L _ (HsApp _ oper@(L _ (HsVar _ origf@(L _ (rdrNa = [suggest "Use section" (reLoc o) (reLoc to) [r]] where to :: LHsExpr GhcPs - to = nlHsPar $ noLocA $ SectionL EpAnnNotUsed y oper + to = nlHsPar $ noLocA $ SectionL noExtField y oper r = Replace Expr (toSSA o) [("x", toSSA y)] ("(x " ++ unsafePrettyPrint origf ++ ")") -lambdaExp _ o@(L _ (HsPar _ _ (view -> App2 (view -> Var_ "flip") origf@(view -> RdrName_ f) y) _)) +lambdaExp _ o@(L _ (HsPar _ (view -> App2 (view -> Var_ "flip") origf@(view -> RdrName_ f) y))) | allowRightSection (rdrNameStr f), not $ "(" `isPrefixOf` rdrNameStr f = [suggest "Use section" (reLoc o) (reLoc to) [r]] where to :: LHsExpr GhcPs - to = nlHsPar $ noLocA $ SectionR EpAnnNotUsed origf y + to = nlHsPar $ noLocA $ SectionR noExtField origf y op = if isSymbolRdrName (unLoc f) then unsafePrettyPrint f else "`" ++ unsafePrettyPrint f ++ "`" var = if rdrNameStr f == "x" then "y" else "x" r = Replace Expr (toSSA o) [(var, toSSA y)] ("(" ++ op ++ " " ++ var ++ ")") -lambdaExp p o@(L _ HsLam{}) +lambdaExp p o@(L _ (HsLam _ LamSingle _)) | not $ any isOpApp p , (res, refact) <- niceLambdaR [] o , not $ isLambda res @@ -225,7 +225,7 @@ lambdaExp p o@(L _ HsLam{}) -- If the lambda's parent is an HsPar, and the result is also an HsPar, the span should include the parentheses. , let from = case p of -- Avoid creating redundant bracket. - Just p@(L _ (HsPar _ _ (L _ HsLam{}) _)) + Just p@(L _ (HsPar _ (L _ HsLam{}))) | L _ HsPar{} <- res -> p | L _ (HsVar _ (L _ name)) <- res, not (isSymbolRdrName name) -> p _ -> o @@ -254,7 +254,7 @@ lambdaExp _ o@(SimpleLambda [view -> PVar_ x] (L _ expr)) = | ([_x], ys) <- partition ((==Just x) . tupArgVar) args -- the other arguments must not have a nested x somewhere in them , Set.notMember x $ Set.map occNameString $ freeVars ys - -> [(suggestN "Use tuple-section" (reLoc o) $ noLoc $ ExplicitTuple EpAnnNotUsed (map removeX args) boxity) + -> [(suggestN "Use tuple-section" (reLoc o) $ noLoc $ ExplicitTuple noAnn (map removeX args) boxity) {ideaNote = [RequiresExtension "TupleSections"]}] -- suggest @LambdaCase@/directly matching in a lambda instead of doing @\x -> case x of ...@ HsCase _ (view -> Var_ x') matchGroup @@ -282,11 +282,11 @@ lambdaExp _ o@(SimpleLambda [view -> PVar_ x] (L _ expr)) = | otherwise = [] needParens = any (patNeedsParens appPrec . unLoc) (m_pats oldmatch) in [ suggest "Use lambda" (reLoc o) - ( noLoc $ HsLam noExtField oldMG + ( noLoc $ HsLam noAnn LamSingle oldMG { mg_alts = noLocA [ noLocA oldmatch { m_pats = map mkParPat $ m_pats oldmatch - , m_ctxt = LambdaExpr + , m_ctxt = LamAlt LamSingle } ] } @@ -297,7 +297,7 @@ lambdaExp _ o@(SimpleLambda [view -> PVar_ x] (L _ expr)) = -- otherwise we should use @LambdaCase@ MG _ (L _ _) -> - [(suggestN "Use lambda-case" (reLoc o) $ noLoc $ HsLamCase EpAnnNotUsed LamCase matchGroup) + [(suggestN "Use lambda-case" (reLoc o) $ noLoc $ HsLam noAnn LamCase matchGroup) {ideaNote=[RequiresExtension "LambdaCase"]}] _ -> [] where @@ -305,7 +305,7 @@ lambdaExp _ o@(SimpleLambda [view -> PVar_ x] (L _ expr)) = -- to a missing argument, so that we get the proper section. removeX :: HsTupArg GhcPs -> HsTupArg GhcPs removeX (Present _ (view -> Var_ x')) - | x == x' = Missing EpAnnNotUsed + | x == x' = Missing noAnn removeX y = y -- | Extract the name of an argument of a tuple if it's present and a variable. tupArgVar :: HsTupArg GhcPs -> Maybe String diff --git a/src/Hint/List.hs b/src/Hint/List.hs index fd213e3d..f78e4128 100644 --- a/src/Hint/List.hs +++ b/src/Hint/List.hs @@ -116,9 +116,9 @@ listCompCheckGuards o ctx stmts = | otherwise = [] where ys = moveGuardsForward xs - o' = noLocA $ ExplicitList EpAnnNotUsed [] - o2 = noLocA $ HsDo EpAnnNotUsed ctx (noLocA (filter ((/= Just "True") . qualCon) xs ++ [e])) - o3 = noLocA $ HsDo EpAnnNotUsed ctx (noLocA $ ys ++ [e]) + o' = noLocA $ ExplicitList noAnn [] + o2 = noLocA $ HsDo noAnn ctx (noLocA (filter ((/= Just "True") . qualCon) xs ++ [e])) + o3 = noLocA $ HsDo noAnn ctx (noLocA $ ys ++ [e]) cons = mapMaybe qualCon xs qualCon :: ExprLStmt GhcPs -> Maybe String qualCon (L _ (BodyStmt _ (L _ (HsVar _ (L _ x))) _ _)) = Just (occNameStr x) @@ -131,8 +131,9 @@ listCompCheckMap o mp f ctx stmts | varToStr mp == "map" = where revs = NE.reverse $ NE.fromList stmts L _ (LastStmt _ body b s) = NE.head revs -- In a ListComp, this is always last. - last = noLocA $ LastStmt noExtField (noLocA $ HsApp EpAnnNotUsed (paren f) (paren body)) b s - o2 =noLocA $ HsDo EpAnnNotUsed ctx (noLocA $ reverse (NE.tail revs) ++ [last]) + last = noLocA $ LastStmt noExtField (noLocA $ HsApp noExtField (paren f) (paren body)) b s + o2 =noLocA $ HsDo noAnn ctx (noLocA $ reverse (NE.tail revs) ++ [last]) + listCompCheckMap _ _ _ _ _ = [] suggestExpr :: LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring R.SrcSpan] @@ -203,9 +204,9 @@ usePString _ = Nothing usePList :: LPat GhcPs -> Maybe (LPat GhcPs, [(String, R.SrcSpan)], String) usePList = fmap ( (\(e, s) -> - (noLocA (ListPat EpAnnNotUsed e) + (noLocA (ListPat noAnn e) , map (fmap toRefactSrcSpan . fst) s - , unsafePrettyPrint (noLocA $ ListPat EpAnnNotUsed (map snd s) :: LPat GhcPs)) + , unsafePrettyPrint (noLocA $ ListPat noAnn (map snd s) :: LPat GhcPs)) ) . unzip ) @@ -220,16 +221,16 @@ usePList = useString :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [a], String) useString b (L _ (ExplicitList _ xs)) | not $ null xs, Just s <- mapM fromChar xs = - let literal = noLocA (HsLit EpAnnNotUsed (HsString NoSourceText (fsLit (show s)))) :: LHsExpr GhcPs + let literal = noLocA (HsLit noExtField (HsString NoSourceText (fsLit (show s)))) :: LHsExpr GhcPs in Just (literal, [], unsafePrettyPrint literal) useString _ _ = Nothing useList :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String) useList b = fmap ( (\(e, s) -> - (noLocA (ExplicitList EpAnnNotUsed e) + (noLocA (ExplicitList noAnn e) , map (fmap toSSA) s - , unsafePrettyPrint (noLocA $ ExplicitList EpAnnNotUsed (map snd s) :: LHsExpr GhcPs)) + , unsafePrettyPrint (noLocA $ ExplicitList noAnn (map snd s) :: LHsExpr GhcPs)) ) . unzip ) @@ -259,17 +260,17 @@ useCons False (view -> App2 op x y) | varToStr op == "++" f _ = Nothing gen :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs - gen x = noLocA . OpApp EpAnnNotUsed x (noLocA (HsVar noExtField (noLocA consDataCon_RDR))) + gen x = noLocA . OpApp noAnn x (noLocA (HsVar noExtField (noLocA consDataCon_RDR))) useCons _ _ = Nothing typeListChar :: LHsType GhcPs typeListChar = - noLocA $ HsListTy EpAnnNotUsed - (noLocA (HsTyVar EpAnnNotUsed NotPromoted (noLocA (mkVarUnqual (fsLit "Char"))))) + noLocA $ HsListTy noAnn + (noLocA (HsTyVar noAnn NotPromoted (noLocA (mkVarUnqual (fsLit "Char"))))) typeString :: LHsType GhcPs typeString = - noLocA $ HsTyVar EpAnnNotUsed NotPromoted (noLocA (mkVarUnqual (fsLit "String"))) + noLocA $ HsTyVar noAnn NotPromoted (noLocA (mkVarUnqual (fsLit "String"))) stringType :: LHsDecl GhcPs -> [Idea] stringType (L _ x) = case x of diff --git a/src/Hint/ListRec.hs b/src/Hint/ListRec.hs index dd499921..f609849e 100644 --- a/src/Hint/ListRec.hs +++ b/src/Hint/ListRec.hs @@ -134,16 +134,16 @@ matchListRec o@(ListCase vs nil (x, xs, cons)) asDo :: LHsExpr GhcPs -> [LStmt GhcPs (LHsExpr GhcPs)] asDo (view -> App2 bind lhs - (L _ (HsLam _ MG { + (L _ (HsLam _ LamSingle MG { mg_ext=FromSource , mg_alts=L _ [ - L _ Match { m_ctxt=LambdaExpr + L _ Match { m_ctxt=(LamAlt LamSingle) , m_pats=[v@(L _ VarPat{})] , m_grhss=GRHSs _ [L _ (GRHS _ [] rhs)] (EmptyLocalBinds _)}]})) ) = - [ noLocA $ BindStmt EpAnnNotUsed v lhs + [ noLocA $ BindStmt noAnn v lhs , noLocA $ BodyStmt noExtField rhs noSyntaxExpr noSyntaxExpr ] asDo (L _ (HsDo _ (DoExpr _) (L _ stmts))) = stmts asDo x = [noLocA $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr] @@ -173,10 +173,10 @@ findCase x = do let ps12 = let (a, b) = splitAt p1 ps1 in map strToPat (a ++ xs : b) -- Function arguments. emptyLocalBinds = EmptyLocalBinds noExtField :: HsLocalBindsLR GhcPs GhcPs -- Empty where clause. - gRHS e = noLocA $ GRHS EpAnnNotUsed [] e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs. + 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=EpAnnNotUsed,m_pats=ps12, m_grhss=gRHSSs e, ..} -- Match. - matchGroup e = MG{mg_alts=noLocA [noLocA $ match e], mg_ext=Generated DoPmc, ..} -- Match group. + match e = Match{m_ext=noAnn,m_pats=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. pure (ListCase ps b1 (x, xs, b2), noLocA . ValD noExtField . funBind) @@ -225,7 +225,7 @@ findPat ps = do readPat :: LPat GhcPs -> Maybe (Either String BList) readPat (view -> PVar_ x) = Just $ Left x -readPat (L _ (ParPat _ _ (L _ (ConPat _ (L _ n) (InfixCon (view -> PVar_ x) (view -> PVar_ xs)))) _)) +readPat (L _ (ParPat _ (L _ (ConPat _ (L _ n) (InfixCon (view -> PVar_ x) (view -> PVar_ xs)))))) | n == consDataCon_RDR = Just $ Right $ BCons x xs readPat (L _ (ConPat _ (L _ n) (PrefixCon [] []))) | n == nameRdrName nilDataConName = Just $ Right BNil diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs index 497ae95e..e6568dbc 100644 --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -101,8 +101,8 @@ dotVersion (L l (OpApp _ x op y)) = -- If a == b then -- x is 'a', op is '==' and y is 'b' and, - let lSec = addParen (L l (SectionL EpAnnNotUsed x op)) -- (a == ) - rSec = addParen (L l (SectionR EpAnnNotUsed op y)) -- ( == b) + let lSec = addParen (L l (SectionL noExtField x op)) -- (a == ) + rSec = addParen (L l (SectionR noExtField op y)) -- ( == b) in (first (lSec :) <$> dotVersion y) ++ (first (rSec :) <$> dotVersion x) -- [([(a ==)], b), ([(b == )], a])]. dotVersion _ = [] @@ -142,7 +142,7 @@ matchIdea sb declName HintRule{..} parent x = do -- Need to check free vars before unqualification, but after subst -- (with 'e') need to unqualify before substitution (with 'res'). - let rhs' | Just fun <- extra = rebracket1 $ noLocA (HsApp EpAnnNotUsed fun rhs) + let rhs' | Just fun <- extra = rebracket1 $ noLocA (HsApp noExtField fun rhs) | otherwise = rhs (e, (tpl, substNoParens)) = substitute u rhs' noParens = [varToStr $ fromParen x | L _ (HsApp _ (varToStr -> "_noParen_") x) <- universe tpl] @@ -183,7 +183,7 @@ checkSide x bind = maybe True bool x | varToStr op == "||" = bool x || bool y | varToStr op == "==" = expr (fromParen1 x) `astEq` expr (fromParen1 y) bool (L _ (HsApp _ x y)) | varToStr x == "not" = not $ bool y - bool (L _ (HsPar _ _ x _)) = bool x + bool (L _ (HsPar _ x)) = bool x bool (L _ (HsApp _ cond (sub -> y))) | 'i' : 's' : typ <- varToStr cond = isType typ y @@ -220,7 +220,7 @@ checkSide x bind = maybe True bool x typ == top asInt :: LHsExpr GhcPs -> Maybe Integer - asInt (L _ (HsPar _ _ x _)) = asInt x + asInt (L _ (HsPar _ x)) = asInt x asInt (L _ (NegApp _ x _)) = negate <$> asInt x asInt (L _ (HsLit _ (HsInt _ (IL _ _ x)) )) = Just x asInt (L _ (HsOverLit _ (OverLit _ (HsIntegral (IL _ _ x))))) = Just x @@ -276,5 +276,5 @@ addBracketTy= transformBi f where f :: LHsType GhcPs -> LHsType GhcPs f (L _ (HsAppTy _ t x@(L _ HsAppTy{}))) = - noLocA (HsAppTy noExtField t (noLocA (HsParTy EpAnnNotUsed x))) + noLocA (HsAppTy noExtField t (noLocA (HsParTy noAnn x))) f x = x diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs index 14674d65..49fd016b 100644 --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -120,8 +120,8 @@ monadExp decl parentDo parentExpr x = case x of (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 EpAnnNotUsed op) x - (L l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (L l . OpApp EpAnnNotUsed op dol) x + (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 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"] @@ -129,14 +129,14 @@ monadExp decl parentDo parentExpr x = , not $ doAsAvoidingIndentation parentDo x ] (L loc (HsDo _ (DoExpr mm) (L _ xs))) -> - monadSteps (L loc . HsDo EpAnnNotUsed (DoExpr mm) . noLocA) xs ++ + monadSteps (L loc . HsDo noAnn (DoExpr mm) . noLocA) xs ++ [suggest "Use let" (reLoc from) (reLoc to) [r] | (from, to, r) <- monadLet xs] ++ concat [f x | (L _ (BodyStmt _ x _ _)) <- dropEnd1 xs] ++ concat [f x | (L _ (BindStmt _ (L _ WildPat{}) x)) <- dropEnd1 xs] _ -> [] where f = monadNoResult (fromMaybe "" decl) id - seenVoid wrap (L l (HsPar x p y q)) = seenVoid (wrap . L l . \y -> HsPar x p y q) y + seenVoid wrap (L l (HsPar x y)) = seenVoid (wrap . L l . \y -> HsPar x y) y seenVoid wrap x = -- Suggest `traverse_ f x` given `void $ traverse_ f x` [warn "Redundant void" (reLoc (wrap x)) (reLoc x) [Replace Expr (toSSA (wrap x)) [("a", toSSA x)] "a"] | returnsUnit x] @@ -179,9 +179,9 @@ doAsBrackets Nothing x = False -- Return True if they are using do as avoiding indentation doAsAvoidingIndentation :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool doAsAvoidingIndentation (Just (L _ (HsDo _ _ (L anna _)))) (L _ (HsDo _ _ (L annb _))) - | SrcSpanAnn _ (RealSrcSpan a _) <- anna - , SrcSpanAnn _ (RealSrcSpan b _) <- annb - = srcSpanStartCol a == srcSpanStartCol b + | EpAnn (EpaSpan (RealSrcSpan a _)) _ _ <- anna + , EpAnn (EpaSpan (RealSrcSpan b _)) _ _ <- annb + = srcSpanStartCol a == srcSpanStartCol b doAsAvoidingIndentation parent self = False -- Apply a function to the application head, including `head arg` and `head $ arg`, which modifies @@ -190,9 +190,9 @@ modifyAppHead :: forall a. (LIdP GhcPs -> (LIdP GhcPs, a)) -> LHsExpr GhcPs -> ( modifyAppHead f = go id where go :: (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> (LHsExpr GhcPs, Maybe a) - go wrap (L l (HsPar _ p x q)) = go (wrap . L l . \y -> HsPar EpAnnNotUsed p y q) x - go wrap (L l (HsApp _ x y)) = go (\x -> wrap $ L l (HsApp EpAnnNotUsed x y)) x - go wrap (L l (OpApp _ x op y)) | isDol op = go (\x -> wrap $ L l (OpApp EpAnnNotUsed x op y)) x + 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 (HsVar _ x)) = (wrap (L l (HsVar NoExtField x')), Just a) where (x', a) = f x go _ expr = (expr, Nothing) @@ -205,11 +205,11 @@ returnsUnit = fromMaybe False -- See through HsPar, and down HsIf/HsCase, return the name to use in -- the hint, and the revised expression. monadNoResult :: String -> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea] -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 EpAnnNotUsed x y)) x +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 EpAnnNotUsed x tag y)) x - | occNameStr op == ">>=" = monadNoResult inside (wrap . L l . OpApp EpAnnNotUsed x tag) 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 monadNoResult inside wrap x | x2 : _ <- filter (`isTag` x) badFuncs , let x3 = x2 ++ "_" @@ -235,7 +235,7 @@ monadStep wrap o@[ g@(L _ (BindStmt _ (L _ (VarPat _ (L _ p))) x)) -- Suggest to use join. Rewrite 'do x <- $1; x; $2' as 'do join $1; $2'. monadStep wrap o@(g@(L _ (BindStmt _ (view -> PVar_ p) x)):q@(L _ (BodyStmt _ (view -> Var_ v) _ _)):xs) | p == v && v `notElem` varss xs - = let app = noLocA $ HsApp EpAnnNotUsed (strToVar "join") x + = let app = noLocA $ HsApp noExtField (strToVar "join") x body = noLocA $ BodyStmt noExtField (rebracket1 app) noSyntaxExpr noSyntaxExpr stmts = body : xs in [warn "Use join" (reLoc (wrap o)) (reLoc (wrap stmts)) r] @@ -261,7 +261,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 EpAnnNotUsed (foldl' (\acc e -> noLocA $ OpApp EpAnnNotUsed acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr])) + [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])) [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) @@ -295,14 +295,14 @@ monadLet xs = mapMaybe mkLet xs template :: String -> LHsExpr GhcPs -> ExprLStmt GhcPs template lhs rhs = let p = noLocA $ mkRdrUnqual (mkVarOcc lhs) - grhs = noLocA (GRHS EpAnnNotUsed [] rhs) + grhs = noLocA (GRHS noAnn [] rhs) grhss = GRHSs emptyComments [grhs] (EmptyLocalBinds noExtField) - match = noLocA $ Match EpAnnNotUsed (FunRhs p Prefix NoSrcStrict) [] grhss - fb = noLocA $ FunBind noExtField p (MG (Generated DoPmc) (noLocA [match])) + match = noLocA $ Match noAnn (FunRhs p Prefix NoSrcStrict) [] grhss + fb = noLocA $ FunBind noExtField p (MG (Generated OtherExpansion SkipPmc) (noLocA [match])) binds = unitBag fb valBinds = ValBinds NoAnnSortKey binds [] - localBinds = HsValBinds EpAnnNotUsed valBinds - in noLocA $ LetStmt EpAnnNotUsed localBinds + localBinds = HsValBinds noAnn valBinds + in noLocA $ LetStmt noAnn localBinds fromApplies :: LHsExpr GhcPs -> ([LHsExpr GhcPs], LHsExpr GhcPs) fromApplies (L _ (HsApp _ f x)) = first (f:) $ fromApplies (fromParen x) @@ -310,7 +310,7 @@ fromApplies (L _ (OpApp _ f (isDol -> True) x)) = first (f:) $ fromApplies x fromApplies x = ([], x) fromRet :: LHsExpr GhcPs -> Maybe (String, LHsExpr GhcPs) -fromRet (L _ (HsPar _ _ x _)) = fromRet x -fromRet (L _ (OpApp _ x (L _ (HsVar _ (L _ y))) z)) | occNameStr y == "$" = fromRet $ noLocA (HsApp EpAnnNotUsed x z) +fromRet (L _ (HsPar _ x)) = fromRet x +fromRet (L _ (OpApp _ x (L _ (HsVar _ (L _ y))) z)) | occNameStr y == "$" = fromRet $ noLocA (HsApp noExtField x z) fromRet (L _ (HsApp _ x y)) | isReturn x = Just (unsafePrettyPrint x, y) fromRet _ = Nothing diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs index 0d4f313a..78d0d7e6 100644 --- a/src/Hint/Naming.hs +++ b/src/Hint/Naming.hs @@ -89,7 +89,7 @@ naming seen originalDecl = shorten :: LHsDecl GhcPs -> LHsDecl GhcPs shorten (L locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG FromSource (L locMatches matches))))) = L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ map shortenMatch matches}}) -shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ grhss@(GRHSs _ rhss _)))) = +shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ _ grhss@(GRHSs _ rhss _)))) = L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = map shortenLGRHS rhss}}) shorten x = x @@ -102,7 +102,7 @@ shortenLGRHS (L locGRHS (GRHS ttg0 guards (L locExpr _))) = L locGRHS (GRHS ttg0 guards (L locExpr dots)) where dots :: HsExpr GhcPs - dots = HsLit EpAnnNotUsed (HsString (SourceText (fsLit "...")) (fsLit "...")) + dots = HsLit noExtField (HsString (SourceText (fsLit "...")) (fsLit "...")) getNames :: LHsDecl GhcPs -> [String] getNames decl = maybeToList (declName decl) ++ getConstructorNames (unLoc decl) diff --git a/src/Hint/NumLiteral.hs b/src/Hint/NumLiteral.hs index 05bc0e0d..a20bc293 100644 --- a/src/Hint/NumLiteral.hs +++ b/src/Hint/NumLiteral.hs @@ -50,20 +50,18 @@ numLiteralHint _ modu = suggestUnderscore :: LHsExpr GhcPs -> [Idea] suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsIntegral intLit@(IL (SourceText srcTxt) _ _))))) = - [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` srcTxt', srcTxt' /= underscoredSrcTxt ] + [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` unpackFS srcTxt, unpackFS srcTxt /= underscoredSrcTxt ] where - srcTxt' = unpackFS srcTxt - underscoredSrcTxt = addUnderscore srcTxt' - y :: LocatedAn an (HsExpr GhcPs) - y = noLocA $ HsOverLit EpAnnNotUsed $ ol{ol_val = HsIntegral intLit{il_text = SourceText (fsLit underscoredSrcTxt)}} + underscoredSrcTxt = addUnderscore (unpackFS srcTxt) + y :: LocatedAn NoEpAnns (HsExpr GhcPs) + y = noLocA $ HsOverLit noExtField $ ol{ol_val = HsIntegral intLit{il_text = SourceText (fsLit underscoredSrcTxt)}} r = Replace Expr (toSSA x) [("a", toSSA y)] "a" suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsFractional fracLit@(FL (SourceText srcTxt) _ _ _ _))))) = - [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` srcTxt', srcTxt' /= underscoredSrcTxt ] + [ suggest "Use underscore" (reLoc x) (reLoc y) [r] | '_' `notElem` unpackFS srcTxt, unpackFS srcTxt /= underscoredSrcTxt ] where - srcTxt' = unpackFS srcTxt - underscoredSrcTxt = addUnderscore srcTxt' - y :: LocatedAn an (HsExpr GhcPs) - y = noLocA $ HsOverLit EpAnnNotUsed $ ol{ol_val = HsFractional fracLit{fl_text = SourceText (fsLit underscoredSrcTxt)}} + underscoredSrcTxt = addUnderscore (unpackFS srcTxt) + y :: LocatedAn NoEpAnns (HsExpr GhcPs) + y = noLocA $ HsOverLit noExtField $ ol{ol_val = HsFractional fracLit{fl_text = SourceText (fsLit underscoredSrcTxt)}} r = Replace Expr (toSSA x) [("a", toSSA y)] "a" suggestUnderscore _ = mempty diff --git a/src/Hint/Pattern.hs b/src/Hint/Pattern.hs index f68d5c67..212e9c08 100644 --- a/src/Hint/Pattern.hs +++ b/src/Hint/Pattern.hs @@ -88,7 +88,7 @@ patternHint _scope modu x = concatMap (uncurry hints . swap) (asPattern x) ++ -- PatBind (used in 'let' and 'where') contains lazy-by-default -- patterns, everything else is strict. - concatMap (patHint strict False) [p | PatBind _ p _ <- universeBi x :: [HsBind GhcPs]] ++ + concatMap (patHint strict False) [p | PatBind _ p _ _ <- universeBi x :: [HsBind GhcPs]] ++ concatMap (patHint strict True) (universeBi $ transformBi noPatBind x) ++ concatMap expHint (universeBi x) where @@ -124,7 +124,7 @@ hints gen (Pattern l rtype pat (GRHSs _ [L _ (GRHS _ [] bod)] bind)) rawGuards = asGuards bod mkGuard :: LHsExpr GhcPs -> (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs)) - mkGuard a = GRHS EpAnnNotUsed [noLocA $ BodyStmt noExtField a noSyntaxExpr noSyntaxExpr] + mkGuard a = GRHS noAnn [noLocA $ BodyStmt noExtField a noSyntaxExpr noSyntaxExpr] guards :: [LGRHS GhcPs (LHsExpr GhcPs)] guards = map (noLocA . uncurry mkGuard) rawGuards @@ -158,7 +158,7 @@ hints gen (Pattern l rtype pat (GRHSs _ [L _ (GRHS _ [] bod)] bind)) refactoring = Replace rtype (toRefactSrcSpan l) (f patSubts ++ f guardSubts ++ f exprSubts) template hints gen (Pattern l t pats o@(GRHSs _ [L _ (GRHS _ [test] bod)] bind)) | unsafePrettyPrint test `elem` ["otherwise", "True"] - = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLocA (GRHS EpAnnNotUsed [] bod)]}) [Delete Stmt (toSSA test)]] + = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLocA (GRHS noAnn [] bod)]}) [Delete Stmt (toSSA test)]] hints _ (Pattern l t pats bod@(GRHSs _ _ binds)) | f binds = [suggestRemove "Redundant where" whereSpan "where" [ {- TODO refactoring for redundant where -} ]] where @@ -175,11 +175,11 @@ hints _ (Pattern l t pats bod@(GRHSs _ _ binds)) | f binds hints gen (Pattern l t pats o@(GRHSs _ (unsnoc -> Just (gs, L _ (GRHS _ [test] bod))) binds)) | unsafePrettyPrint test == "True" = let otherwise_ = noLocA $ BodyStmt noExtField (strToVar "otherwise") noSyntaxExpr noSyntaxExpr in - [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLocA (GRHS EpAnnNotUsed [otherwise_] bod)]}) [Replace Expr (toSSA test) [] "otherwise"]] + [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLocA (GRHS noAnn [otherwise_] bod)]}) [Replace Expr (toSSA test) [] "otherwise"]] hints _ _ = [] asGuards :: LHsExpr GhcPs -> [(LHsExpr GhcPs, LHsExpr GhcPs)] -asGuards (L _ (HsPar _ _ x _)) = asGuards x +asGuards (L _ (HsPar _ x)) = asGuards x asGuards (L _ (HsIf _ a b c)) = (a, b) : asGuards c asGuards x = [(strToVar "otherwise", x)] @@ -190,12 +190,12 @@ asPattern :: LHsDecl GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.Sr asPattern (L loc x) = concatMap decl (universeBi x) where decl :: HsBind GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)] - decl o@(PatBind _ pat rhs) = [(Pattern (locA loc) Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest msg (noLoc o :: Located (HsBind GhcPs)) (noLoc (PatBind EpAnnNotUsed pat rhs) :: Located (HsBind GhcPs)) rs)] + decl o@(PatBind _ pat mult rhs) = [(Pattern (locA loc) Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest msg (noLoc o :: Located (HsBind GhcPs)) (noLoc (PatBind noExtField pat mult rhs) :: Located (HsBind GhcPs)) rs)] decl (FunBind _ _ (MG _ (L _ xs))) = map match xs 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 EpAnnNotUsed ctx pats grhss) :: Located (Match GhcPs (LHsExpr GhcPs))) rs) + 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) -- First Bool is if 'Strict' is a language extension. Second Bool is -- if this pattern in this context is going to be evaluated strictly. @@ -203,7 +203,7 @@ 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) - new = noLocA $ ConPat EpAnnNotUsed name (RecCon rec_fields) :: 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)]] patHint _ _ o@(L _ (VarPat _ (L _ name))) @@ -213,8 +213,8 @@ patHint lang strict o@(L _ (BangPat _ pat@(L _ x))) | strict, f x = [warn "Redundant bang pattern" (reLoc o) (noLoc x :: Located (Pat GhcPs)) [r]] where f :: Pat GhcPs -> Bool - f (ParPat _ _ (L _ x) _) = f x - f (AsPat _ _ _ (L _ x)) = f x + f (ParPat _ (L _ x)) = f x + f (AsPat _ _ (L _ x)) = f x f LitPat {} = True f NPat {} = True f ConPat {} = True @@ -227,13 +227,13 @@ patHint False _ o@(L _ (LazyPat _ pat@(L _ x))) | f x = [warn "Redundant irrefutable pattern" (reLoc o) (noLoc x :: Located (Pat GhcPs)) [r]] where f :: Pat GhcPs -> Bool - f (ParPat _ _ (L _ x) _) = f x - f (AsPat _ _ _ (L _ x)) = f x + f (ParPat _ (L _ x)) = f x + f (AsPat _ _ (L _ x)) = f x f WildPat{} = True f VarPat{} = True f _ = False r = Replace R.Pattern (toSSA o) [("x", toSSA pat)] "x" -patHint _ _ o@(L _ (AsPat _ v _ (L _ (WildPat _)))) = +patHint _ _ o@(L _ (AsPat _ v (L _ (WildPat _)))) = [warn "Redundant as-pattern" (reLoc o) (reLoc v) [Replace R.Pattern (toSSA o) [] (rdrNameStr v)]] patHint _ _ _ = [] diff --git a/src/Hint/Restrict.hs b/src/Hint/Restrict.hs index f6fcd53b..143cec63 100644 --- a/src/Hint/Restrict.hs +++ b/src/Hint/Restrict.hs @@ -250,10 +250,10 @@ lookupRestrictItem ideclName mp = importListToIdents :: IE GhcPs -> [String] importListToIdents = catMaybes . - \case (IEVar _ n) -> [fromName n] - (IEThingAbs _ n) -> [fromName n] - (IEThingAll _ n) -> [fromName n] - (IEThingWith _ n _ ns) -> fromName n : map fromName ns + \case (IEVar _ n _) -> [fromName n] + (IEThingAbs _ n _) -> [fromName n] + (IEThingAll _ n _) -> [fromName n] + (IEThingWith _ n _ ns _) -> fromName n : map fromName ns _ -> [] where fromName :: LIEWrappedName GhcPs -> Maybe String @@ -271,7 +271,7 @@ importListToIdents = checkFunctions :: Scope -> String -> [LHsDecl GhcPs] -> RestrictFunctions -> [Idea] checkFunctions scope modu decls (def, mp) = - [ (ideaMessage message $ ideaNoTo $ warn "Avoid restricted function" (reLocN x) (reLocN x) []){ideaDecl = [dname]} + [ (ideaMessage message $ ideaNoTo $ warn "Avoid restricted function" (reLoc x) (reLoc x) []){ideaDecl = [dname]} | d <- decls , let dname = fromMaybe "" (declName d) , x <- universeBi d :: [LocatedN RdrName] diff --git a/src/Hint/Smell.hs b/src/Hint/Smell.hs index 66f6b0d2..f14798fc 100644 --- a/src/Hint/Smell.hs +++ b/src/Hint/Smell.hs @@ -88,6 +88,7 @@ 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 smellModuleHint :: [Setting] -> ModuHint @@ -142,7 +143,7 @@ declSpans f@(L l (ValD _ FunBind {})) = [(locA l, warn "Long function" (reLoc f) declSpans _ = [] -- The span of a guarded right hand side. -rhsSpans :: HsMatchContext GhcPs -> LGRHS GhcPs (LHsExpr GhcPs) -> [(SrcSpan, Idea)] +rhsSpans :: HsMatchContext (GenLocated SrcSpanAnnN RdrName) -> LGRHS GhcPs (LHsExpr GhcPs) -> [(SrcSpan, Idea)] rhsSpans _ (L _ (GRHS _ _ (L _ RecordCon {}))) = [] -- record constructors get a pass rhsSpans ctx (L _ r@(GRHS _ _ (L l _))) = [(locA l, rawIdea Config.Type.Warning "Long function" (locA l) (showSDocUnsafe (pprGRHS ctx r)) Nothing [] [])] diff --git a/src/Hint/Unsafe.hs b/src/Hint/Unsafe.hs index 9e0ccd80..f7370dea 100644 --- a/src/Hint/Unsafe.hs +++ b/src/Hint/Unsafe.hs @@ -61,10 +61,11 @@ unsafeHint _ (ModuleEx (L _ m)) = \ld@(L loc d) -> , x `notElem` noinline] where noInline :: FastString - noInline = fsLit "{-# NOINLINE" + noInline = fsLit $ '{' : '-' : '#' : " NOINLINE" + gen :: OccName -> LHsDecl GhcPs gen x = noLocA $ - SigD noExtField (InlineSig EpAnnNotUsed (noLocA (mkRdrUnqual x)) + SigD noExtField (InlineSig noAnn (noLocA (mkRdrUnqual x)) (InlinePragma (SourceText noInline) (NoInline (SourceText noInline)) Nothing NeverActive FunLike)) noinline :: [OccName] noinline = [q | L _(SigD _ (InlineSig _ (L _ (Unqual q)) diff --git a/src/Refact.hs b/src/Refact.hs index 99829148..c1b4c365 100644 --- a/src/Refact.hs +++ b/src/Refact.hs @@ -44,10 +44,10 @@ toRefactSrcSpan = \case toSS :: GHC.Located a -> R.SrcSpan toSS = toRefactSrcSpan . GHC.getLoc -toSSA :: GHC.GenLocated (GHC.SrcSpanAnn' a) e -> R.SrcSpan +toSSA :: GHC.GenLocated (GHC.EpAnn a) e -> R.SrcSpan toSSA = toRefactSrcSpan . GHC.getLocA -toSSAnc :: GHC.GenLocated GHC.Anchor e -> R.SrcSpan +toSSAnc :: GHC.GenLocated GHC.NoCommentsLocation e -> R.SrcSpan toSSAnc = toRefactSrcSpan . getAncLoc checkRefactor :: Maybe FilePath -> IO FilePath diff --git a/stack.yaml b/stack.yaml index 708b7a1a..9edbb9d8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,24 +1,11 @@ -# For hlint/ghc-9.8.*, the minimum build compiler is ghc-9.4.1. -resolver: lts-21.6 # ghc-9.4.5 - +# For hlint/ghc-9.10.*, the minimum build compiler is ghc-9.6.1. +resolver: lts-22.21 # ghc-9.6.5 +allow-newer: True packages: - . - extra-deps: - - ghc-lib-parser-9.8.2.20240223 - - ghc-lib-parser-ex-9.8.0.2 -# To test hlint against experimental builds of ghc-lib-parser-ex, -# modify extra-deps like this: -# - archive: /users/shayne/project/ghc-lib-parser-ex/ghc-lib-parser-ex-8.10.0.18.tar.gz -# sha256: "0000000000000000000000000000000000000000000000000000000000000000" - + - github: shayne-fletcher/text-short + commit: "qualify-foldl" + - ghc-lib-parser-9.10.1.20240511 + - ghc-lib-parser-ex-9.10.0.0 ghc-options: {"$locals": -ddump-to-file -ddump-hi -Werror=unused-imports -Werror=unused-local-binds -Werror=unused-top-binds -Werror=orphans -Werror=prepositive-qualified-module} - -# Enabling this stanza forces both hlint and ghc-lib-parser-ex to -# depend on ghc-lib-parser. -# flags: -# hlint: -# ghc-lib: true -# ghc-lib-parser-ex: -# auto: false -# no-ghc-lib: false