hlint 2.2.9 → 2.2.10
raw patch · 21 files changed
+184/−317 lines, 21 filesdep ~ghc-lib-parser-exPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghc-lib-parser-ex
API changes (from Hackage documentation)
Files
- CHANGES.txt +3/−0
- data/hlint.yaml +8/−1
- hlint.cabal +2/−3
- src/Config/Haskell.hs +3/−1
- src/Config/Type.hs +1/−0
- src/Config/Yaml.hs +9/−9
- src/GHC/Util.hs +0/−2
- src/GHC/Util/Brackets.hs +6/−11
- src/GHC/Util/HsExpr.hs +17/−137
- src/GHC/Util/HsExtendInstances.hs +0/−36
- src/GHC/Util/Unify.hs +11/−10
- src/Grep.hs +2/−2
- src/Hint/Bracket.hs +8/−7
- src/Hint/Duplicate.hs +2/−1
- src/Hint/Extensions.hs +13/−12
- src/Hint/List.hs +14/−12
- src/Hint/ListRec.hs +19/−17
- src/Hint/Match.hs +39/−32
- src/Hint/Monad.hs +20/−19
- src/Hint/Pattern.hs +4/−3
- src/Hint/Unsafe.hs +3/−2
CHANGES.txt view
@@ -1,5 +1,8 @@ Changelog for HLint (* = breaking change) +2.2.10, released 2020-02-02+ #846, add splitAt warnings+ #774, don't warn about 'Redundant compare' in == and /= 2.2.9, released 2020-01-27 Add any/map and all/map fusion hints #837, don't warn about redundant do for BlockArguments
data/hlint.yaml view
@@ -144,11 +144,14 @@ - warn: {lhs: "foldr (\\c a -> x : a) []", rhs: "map (\\c -> x)"} - warn: {lhs: span (not . p), rhs: break p} - warn: {lhs: break (not . p), rhs: span p}- - warn: {lhs: "(takeWhile p x, dropWhile p x)", rhs: span p x}+ - warn: {lhs: "(takeWhile p x, dropWhile p x)", rhs: span p x, note: DecreasesLaziness} - warn: {lhs: fst (span p x), rhs: takeWhile p x} - warn: {lhs: snd (span p x), rhs: dropWhile p x} - warn: {lhs: fst (break p x), rhs: takeWhile (not . p) x} - warn: {lhs: snd (break p x), rhs: dropWhile (not . p) x}+ - warn: {lhs: "(take n x, drop n x)", rhs: splitAt n x, note: DecreasesLaziness}+ - warn: {lhs: fst (splitAt p x), rhs: take p x}+ - warn: {lhs: snd (splitAt p x), rhs: drop p x} - warn: {lhs: concatMap (++ "\n"), rhs: unlines} - warn: {lhs: map id, rhs: id} - warn: {lhs: concatMap id, rhs: concat}@@ -942,6 +945,9 @@ # main = take (-y) x # main = take 4 x # main = let (first, rest) = (takeWhile p l, dropWhile p l) in rest -- span p l+# main = let (first, rest) = (take n l, drop n l) in rest -- splitAt n l+# main = fst (splitAt n l) -- take n l+# main = snd $ splitAt n l -- drop n l # main = map $ \ d -> ([| $d |], [| $d |]) # pairs (x:xs) = map (x,) xs ++ pairs xs # {-# ANN foo "HLint: ignore" #-};foo = map f (map g x) -- @Ignore ???@@ -991,6 +997,7 @@ # {-# LANGUAGE QuasiQuotes #-}; no = f (\url -> [hamlet|foo @{url}|]) # yes = f ((,) x) -- (x,) # instance Class X where method = map f (map g x) -- map (f . g) x+# instance Eq X where x == y = compare x y == EQ # import Prelude \ # yes = flip mapM -- Control.Monad.forM
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: hlint-version: 2.2.9+version: 2.2.10 license: BSD3 license-file: LICENSE category: Development@@ -68,7 +68,7 @@ refact >= 0.3, aeson >= 1.1.2.0, filepattern >= 0.1.1,- ghc-lib-parser-ex == 8.8.3.*+ ghc-lib-parser-ex == 8.8.4.* if !flag(ghc-lib) && impl(ghc >= 8.8.0) && impl(ghc < 8.9.0) build-depends: ghc == 8.8.*,@@ -121,7 +121,6 @@ GHC.Util.Module GHC.Util.Outputable GHC.Util.SrcLoc- GHC.Util.HsExtendInstances GHC.Util.DynFlags GHC.Util.RdrName GHC.Util.Scope
src/Config/Haskell.hs view
@@ -19,6 +19,8 @@ import qualified HsSyn as GHC import qualified BasicTypes as GHC import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances+ import SrcLoc as GHC import ApiAnnotation @@ -55,7 +57,7 @@ [SettingMatchExp $ HintRule severity (head $ snoc names defaultHintName) s (fromParen lhs) (fromParen rhs) a b -- Todo : Replace these with "proper" GHC expressions.- (extendInstances' mempty) (extendInstances' unit) (extendInstances' unit) Nothing]+ (extendInstances mempty) (extendInstances unit) (extendInstances unit) Nothing] | otherwise = [SettingClassify $ Classify severity n a b | n <- names2, (a,b) <- readFuncs bod] where names = filter (not . null) $ getNames pats bod
src/Config/Type.hs view
@@ -12,6 +12,7 @@ import qualified HsSyn import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances getSeverity :: String -> Maybe Severity getSeverity "ignore" = Just Ignore
src/Config/Yaml.hs view
@@ -30,7 +30,7 @@ import qualified Outputable import qualified HsSyn import GHC.Util (baseDynFlags, Scope',scopeCreate')-import GHC.Util.HsExtendInstances+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances -- | Read a config file in YAML format. Takes a filename, and optionally the contents. -- Fails if the YAML doesn't parse or isn't valid HLint YAML@@ -198,7 +198,7 @@ parsePackage v = do packageName <- parseField "name" v >>= parseString packageModules <- parseField "modules" v >>= parseArray >>= mapM (parseHSE parseImportDeclWithMode)- packageGhcModules <- parseField "modules" v >>= parseArray >>= mapM (fmap extendInstances' <$> parseGHC parseImportDeclGhcWithMode)+ packageGhcModules <- parseField "modules" v >>= parseArray >>= mapM (fmap extendInstances <$> parseGHC parseImportDeclGhcWithMode) allowFields v ["name","modules"] return Package{..} @@ -238,7 +238,7 @@ x <- parseString v case word1 x of ("package", x) -> return $ Left x- _ -> Right . extendInstances' <$> parseGHC parseImportDeclGhcWithMode v+ _ -> Right . extendInstances <$> parseGHC parseImportDeclGhcWithMode v ruleToGroup :: [Either HintRule Classify] -> Group ruleToGroup = Group "" True [] []@@ -254,13 +254,13 @@ hintRuleName <- parseFieldOpt "name" v >>= maybe (return $ guessName hintRuleLHS hintRuleRHS) parseString hintRuleSide <- parseFieldOpt "side" v >>= maybe (return Nothing) (fmap Just . parseHSE parseExpWithMode) - hintRuleGhcLHS <- parseField "lhs" v >>= fmap extendInstances' . parseGHC parseExpGhcWithMode- hintRuleGhcRHS <- parseField "rhs" v >>= fmap extendInstances' . parseGHC parseExpGhcWithMode- hintRuleGhcSide <- parseFieldOpt "side" v >>= maybe (return Nothing) (fmap (Just . extendInstances') . parseGHC parseExpGhcWithMode)+ hintRuleGhcLHS <- parseField "lhs" v >>= fmap extendInstances . parseGHC parseExpGhcWithMode+ hintRuleGhcRHS <- parseField "rhs" v >>= fmap extendInstances . parseGHC parseExpGhcWithMode+ hintRuleGhcSide <- parseFieldOpt "side" v >>= maybe (return Nothing) (fmap (Just . extendInstances) . parseGHC parseExpGhcWithMode) allowFields v ["lhs","rhs","note","name","side"] let hintRuleScope = mempty :: Scope- let hintRuleGhcScope = extendInstances' mempty :: HsExtendInstances Scope'+ let hintRuleGhcScope = extendInstances mempty :: HsExtendInstances Scope' return [Left HintRule{hintRuleSeverity=severity, ..}] else do names <- parseFieldOpt "name" v >>= maybe (return []) parseArrayString@@ -331,7 +331,7 @@ groups = [x | ConfigGroup x <- configs] settings = concat [x | ConfigSetting x <- configs] packageMap = Map.fromListWith (++) [(packageName, packageModules) | Package{..} <- packages]- packageMap' = Map.fromListWith (++) [(packageName, fmap unExtendInstances' packageGhcModules) | Package{..} <- packages]+ packageMap' = Map.fromListWith (++) [(packageName, fmap unextendInstances packageGhcModules) | Package{..} <- packages] groupMap = Map.fromListWith (\new old -> new) [(groupName, groupEnabled) | Group{..} <- groups] f Group{..}@@ -339,7 +339,7 @@ | otherwise = map (either (\r -> SettingMatchExp r{hintRuleScope=scope,hintRuleGhcScope=scope'}) SettingClassify) groupRules where scope = asScope packageMap groupImports- scope'= asScope' packageMap' (map (fmap unExtendInstances') groupGhcImports)+ scope'= asScope' packageMap' (map (fmap unextendInstances) groupGhcImports) asScope :: Map.HashMap String [ImportDecl S] -> [Either String (ImportDecl S)] -> Scope asScope packages xs = scopeCreate $ Module an Nothing [] (concatMap f xs) []
src/GHC/Util.hs view
@@ -11,7 +11,6 @@ , module GHC.Util.Module , module GHC.Util.Outputable , module GHC.Util.SrcLoc- , module GHC.Util.HsExtendInstances , module GHC.Util.DynFlags , module GHC.Util.Scope , module GHC.Util.RdrName@@ -32,7 +31,6 @@ import GHC.Util.Module import GHC.Util.Outputable import GHC.Util.SrcLoc-import GHC.Util.HsExtendInstances import GHC.Util.DynFlags import GHC.Util.RdrName import GHC.Util.Scope
src/GHC/Util/Brackets.hs view
@@ -1,9 +1,10 @@ {-# LANGUAGE MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-}-module GHC.Util.Brackets (Brackets'(..), isApp',isOpApp',isAnyApp',isSection') where+module GHC.Util.Brackets (Brackets'(..), isApp,isOpApp,isAnyApp) where import HsSyn import SrcLoc import BasicTypes+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr class Brackets' a where remParen' :: a -> Maybe a -- Remove one paren or nothing if there is no paren.@@ -15,12 +16,6 @@ -- position. Err on the side of caution, True = don't know. needBracket' :: Int -> a -> a -> Bool -isOpApp', isApp', isSection' :: LHsExpr GhcPs -> Bool-isApp' (LL _ HsApp{}) = True; isApp' _ = False-isOpApp' (LL _ OpApp{}) = True; isOpApp' _ = False-isAnyApp' x = isApp' x || isOpApp' x-isSection' (LL _ SectionL{}) = True; isSection' (LL _ SectionR{}) = True; isSection' _ = False- instance Brackets' (LHsExpr GhcPs) where -- When GHC parses a section in concrete syntax, it will produce an -- 'HsPar (Section[L|R])'. There is no concrete syntax that will@@ -69,18 +64,18 @@ needBracket' i parent child -- Note: i is the index in children, not in the AST. | isAtom' child = False- | isSection' parent, LL _ HsApp{} <- child = False+ | isSection parent, LL _ HsApp{} <- child = False | LL _ OpApp{} <- parent, LL _ HsApp{} <- child = False | LL _ HsLet{} <- parent, LL _ HsApp{} <- child = False | LL _ HsDo{} <- parent = False | LL _ ExplicitList{} <- parent = False | LL _ ExplicitTuple{} <- parent = False- | LL _ HsIf{} <- parent, isAnyApp' child = False+ | LL _ HsIf{} <- parent, isAnyApp child = False | LL _ HsApp{} <- parent, i == 0, LL _ HsApp{} <- child = False- | LL _ ExprWithTySig{} <- parent, i == 0, isApp' child = False+ | LL _ ExprWithTySig{} <- parent, i == 0, isApp child = False | LL _ RecordCon{} <- parent = False | LL _ RecordUpd{} <- parent, i /= 0 = False- | LL _ HsCase{} <- parent, i /= 0 || isAnyApp' child = False+ | LL _ HsCase{} <- parent, i /= 0 || isAnyApp child = False | LL _ HsLam{} <- parent = False -- might be either the RHS of a PViewPat, or the lambda body (neither needs brackets) | LL _ HsPar{} <- parent = False | LL _ HsDo {} <- parent = False
src/GHC/Util/HsExpr.hs view
@@ -7,18 +7,13 @@ {-# OPTIONS_GHC -Wno-unused-top-binds #-} module GHC.Util.HsExpr (- noSyntaxExpr'- , isTag', isDol', isDot', isSection', isRecConstr', isRecUpdate', isVar', isPar', isApp', isAnyApp', isLexeme', isLambda', isQuasiQuote', isTypeApp', isWHNF',isReturn'- , dotApp', dotApps'+ dotApp', dotApps' , simplifyExp', niceLambda', niceDotApp' , Brackets'(..) , rebracket1', appsBracket', transformAppsM', fromApps', apps', universeApps', universeParentExp'- , varToStr', strToVar'- , paren', fromChar'+ , paren' , replaceBranches' , needBracketOld', transformBracketOld', descendBracketOld', reduce', reduce1', fromParen1'- , hasFieldsDotDot', isFieldPun'- , isParComp', isMDo', isRecStmt', isLCase', isTupleSection', isString', isPrimLiteral', isSpliceDecl', isFieldWildcard', isUnboxed' ) where import HsSyn@@ -28,14 +23,10 @@ import RdrName import OccName import Bag(bagToList)-import TysWiredIn-import TcEvidence-import Name import GHC.Util.Brackets import GHC.Util.View import GHC.Util.FreeVars-import GHC.Util.HsExtendInstances import GHC.Util.Pat import Control.Applicative@@ -48,13 +39,8 @@ import Refact.Types hiding (Match) import qualified Refact.Types as R (SrcSpan) --noSyntaxExpr' :: SyntaxExpr GhcPs-noSyntaxExpr' =- SyntaxExpr- (HsLit noExt- (HsString NoSourceText (fsLit "noSyntaxExpr")))- [] WpHole+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances -- | 'dotApp a b' makes 'a . b'. dotApp' :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs@@ -71,50 +57,6 @@ | isAtom' x = x | otherwise = addParen' x --- 'True' if the provided expression is a variable with name 'tag'.-isTag' :: LHsExpr GhcPs -> String -> Bool-isTag' (LL _ (HsVar _ (L _ s))) tag = occNameString (rdrNameOcc s) == tag-isTag' _ _ = False--isVar',isReturn',isLexeme',isLambda',isQuasiQuote',isTypeApp',isDotApp',isRecUpdate',isRecConstr',isDol',isDot' :: LHsExpr GhcPs -> Bool-isPar' (LL _ HsPar{}) = True; isPar' _ = False-isVar' (LL _ HsVar{}) = True; isVar' _ = False-isDot' x = isTag' x "."-isDol' x = isTag' x "$"-isReturn' x = isTag' x "return" || isTag' x "pure" -- Allow both 'pure' and 'return' as they have the same semantics.-isRecConstr' (LL _ RecordCon{}) = True; isRecConstr' _ = False-isRecUpdate' (LL _ RecordUpd{}) = True; isRecUpdate' _ = False-isDotApp' (LL _ (OpApp _ _ op _)) = isDot' op; isDotApp' _ = False-isLexeme' (LL _ HsVar{}) = True;isLexeme' (LL _ HsOverLit{}) = True;isLexeme' (LL _ HsLit{}) = True;isLexeme' _ = False-isTypeApp' (LL _ HsAppType{}) = True; isTypeApp' _ = False-isLambda' (LL _ HsLam{}) = True; isLambda' _ = False-isQuasiQuote' (LL _ (HsSpliceE _ HsQuasiQuote{})) = True; isQuasiQuote' _ = False--isWHNF' :: LHsExpr GhcPs -> Bool-isWHNF' (LL _ (HsVar _ (L _ x))) = isRdrDataCon x-isWHNF' (LL _ (HsLit _ x)) = case x of HsString{} -> False; HsInt{} -> False; HsRat{} -> False; _ -> True-isWHNF' (LL _ HsLam{}) = True-isWHNF' (LL _ ExplicitTuple{}) = True-isWHNF' (LL _ ExplicitList{}) = True-isWHNF' (LL _ (HsPar _ x)) = isWHNF' x-isWHNF' (LL _ (ExprWithTySig _ x _)) = isWHNF' x--- Other (unknown) constructors may have bang patterns in them, so--- approximate.-isWHNF' (LL _ (HsApp _ (LL _ (HsVar _ (L _ x))) _))| occNameString (rdrNameOcc x) `elem` ["Just", "Left", "Right"] = True-isWHNF' _ = False----- Contains a '..' as in 'Foo{..}'-hasFieldsDotDot' :: HsRecFields GhcPs (LHsExpr GhcPs) -> Bool-hasFieldsDotDot' HsRecFields {rec_dotdot=Just _} = True-hasFieldsDotDot' _ = False---- Field is punned e.g. '{foo}'.-isFieldPun' :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool-isFieldPun' (LL _ HsRecField {hsRecPun=True}) = True-isFieldPun' _ = False-- universeParentExp' :: Data a => a -> [(Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)] universeParentExp' xs = concat [(Nothing, x) : f x | x <- childrenBi xs] where f p = concat [(Just (i,p), c) : f c | (i,c) <- zip [0..] $ children p]@@ -174,21 +116,9 @@ where mkApp x y = rebracket1' (noLoc $ HsApp noExt x y) -varToStr' :: LHsExpr GhcPs -> String-varToStr' (LL _ (HsVar _ (L _ n)))- | n == consDataCon_RDR = ":"- | n == nameRdrName nilDataConName = "[]"- | n == nameRdrName (getName (tupleDataCon Boxed 0)) = "()"- | otherwise = occNameString (rdrNameOcc n)-varToStr' _ = ""--strToVar' :: String -> LHsExpr GhcPs-strToVar' x = noLoc $ HsVar noExt (noLoc $ mkRdrUnqual (mkVarOcc x))-- simplifyExp' :: LHsExpr GhcPs -> LHsExpr GhcPs -- Replace appliciations 'f $ x' with 'f (x)'.-simplifyExp' (LL l (OpApp _ x op y)) | isDol' op = LL l (HsApp noExt x (noLoc (HsPar noExt y)))+simplifyExp' (LL l (OpApp _ x op y)) | isDol op = LL l (HsApp noExt x (noLoc (HsPar noExt y))) simplifyExp' e@(LL _ (HsLet _ (LL _ (HsValBinds _ (ValBinds _ binds []))) z)) = -- An expression of the form, 'let x = y in z'. case bagToList binds of@@ -226,7 +156,7 @@ -- Rewrite '\x -> x + a' as '(+ a)' (heuristic: 'a' must be a single -- lexeme, or it all gets too complex). niceLambdaR' [x] (view' -> App2' op@(LL _ (HsVar _ (L _ tag))) l r)- | isLexeme' r, view' l == Var_' x, x `notElem` vars' r, allowRightSection (occNameString $ rdrNameOcc tag) =+ | isLexeme r, view' l == Var_' x, x `notElem` vars' r, allowRightSection (occNameString $ rdrNameOcc tag) = let e = rebracket1' $ addParen' (noLoc $ SectionR noExt op r) in (e, const []) -- Rewrite (1) '\x -> f (b x)' as 'f . b', (2) '\x -> f $ b x' as 'f . b'.@@ -238,10 +168,10 @@ factor y@(LL _ (HsApp _ ini lst)) | view' lst == Var_' x = Just (ini, [ini]) factor y@(LL _ (HsApp _ ini lst)) | Just (z, ss) <- factor lst = let r = niceDotApp' ini z- in if astEq' r z then Just (r, ss) else Just (r, ini : ss)- factor (LL _ (OpApp _ y op (factor -> Just (z, ss))))| isDol' op+ in if astEq r z then Just (r, ss) else Just (r, ini : ss)+ factor (LL _ (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)+ in if astEq r z then Just (r, ss) else Just (r, y : ss) factor (LL _ (HsPar _ y@(LL _ HsApp{}))) = factor y factor _ = Nothing -- Rewrite '\x y -> x + y' as '(+)'.@@ -249,7 +179,7 @@ | x == x1, y == y1, vars' op `disjoint` [x, y] = (op, const []) -- Rewrite '\x y -> f y x' as 'flip f'. niceLambdaR' [x, y] (view' -> App2' op (view' -> Var_' y1) (view' -> Var_' x1))- | x == x1, y == y1, vars' op `disjoint` [x, y] = (noLoc $ HsApp noExt (strToVar' "flip") op, const [])+ | x == x1, y == y1, vars' op `disjoint` [x, y] = (noLoc $ HsApp noExt (strToVar "flip") op, const []) -- Base case. Just a good old fashioned lambda. niceLambdaR' ss e = let grhs = noLoc $ GRHS noExt [] e :: LGRHS GhcPs (LHsExpr GhcPs)@@ -259,11 +189,6 @@ in (noLoc $ HsLam noExt matchGroup, const []) -fromChar' :: LHsExpr GhcPs -> Maybe Char-fromChar' (LL _ (HsLit _ (HsChar _ x))) = Just x-fromChar' _ = Nothing-- -- '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)@@ -290,7 +215,7 @@ -- removed from haskell-src-exts-util-0.2.2. needBracketOld' :: Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool needBracketOld' i parent child- | isDotApp' parent, isDotApp' child, i == 2 = False+ | isDotApp parent, isDotApp child, i == 2 = False | otherwise = needBracket' i parent child transformBracketOld' :: (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)) -> LHsExpr GhcPs -> LHsExpr GhcPs@@ -316,16 +241,16 @@ reduce1' :: LHsExpr GhcPs -> LHsExpr GhcPs reduce1' (LL loc (HsApp _ len (LL _ (HsLit _ (HsString _ xs)))))- | varToStr' len == "length" = cL loc $ HsLit noExt (HsInt noExt (IL NoSourceText False n))+ | varToStr len == "length" = cL loc $ HsLit noExt (HsInt noExt (IL NoSourceText False n)) where n = fromIntegral $ length (unpackFS xs) reduce1' (LL loc (HsApp _ len (LL _ (ExplicitList _ _ xs))))- | varToStr' len == "length" = cL loc $ HsLit noExt (HsInt noExt (IL NoSourceText False n))+ | varToStr len == "length" = cL loc $ HsLit noExt (HsInt noExt (IL NoSourceText False n)) where n = fromIntegral $ length xs-reduce1' (view' -> App2' op (LL _ (HsLit _ x)) (LL _ (HsLit _ y))) | varToStr' op == "==" = strToVar' (show (astEq' x y))-reduce1' (view' -> App2' op (LL _ (HsLit _ (HsInt _ x))) (LL _ (HsLit _ (HsInt _ y)))) | varToStr' op == ">=" = strToVar' $ show (x >= y)+reduce1' (view' -> App2' op (LL _ (HsLit _ x)) (LL _ (HsLit _ y))) | varToStr op == "==" = strToVar (show (astEq x y))+reduce1' (view' -> App2' op (LL _ (HsLit _ (HsInt _ x))) (LL _ (HsLit _ (HsInt _ y)))) | varToStr op == ">=" = strToVar $ show (x >= y) reduce1' (view' -> App2' op x y)- | varToStr' op == "&&" && varToStr' x == "True" = y- | varToStr' op == "&&" && varToStr' x == "False" = x+ | varToStr op == "&&" && varToStr x == "True" = y+ | varToStr op == "&&" && varToStr x == "False" = x reduce1' (LL _ (HsPar _ x)) | isAtom' x = x reduce1' x = x @@ -333,48 +258,3 @@ fromParen1' :: LHsExpr GhcPs -> LHsExpr GhcPs fromParen1' (LL _ (HsPar _ x)) = x fromParen1' x = x------isMDo' :: HsStmtContext Name -> Bool-isMDo' MDoExpr = True; isMDo' _ = False--isRecStmt' :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool-isRecStmt' RecStmt{} = True; isRecStmt' _ = False--isParComp' :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool-isParComp' ParStmt{} = True; isParComp' _ = False---isLCase' :: LHsExpr GhcPs -> Bool-isLCase' (LL _ HsLamCase{}) = True; isLCase' _ = False--isTupleSection' :: HsTupArg GhcPs -> Bool-isTupleSection' Missing{} = True; isTupleSection' _ = False--isString' :: HsLit GhcPs -> Bool-isString' HsString{} = True; isString' _ = False--isPrimLiteral' :: HsLit GhcPs -> Bool-isPrimLiteral' HsCharPrim{} = True;-isPrimLiteral' HsStringPrim{} = True;-isPrimLiteral' HsIntPrim{} = True;-isPrimLiteral' HsWordPrim{} = True;-isPrimLiteral' HsInt64Prim{} = True;-isPrimLiteral' HsWord64Prim{} = True;-isPrimLiteral' HsFloatPrim{} = True;-isPrimLiteral' HsDoublePrim{} = True;-isPrimLiteral' _ = False--isSpliceDecl' :: HsExpr GhcPs -> Bool-isSpliceDecl' HsSpliceE{} = True; isSpliceDecl' _ = False---- Field has a '_' as in '{foo=_} or is punned e.g. '{foo}'.-isFieldWildcard' :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool-isFieldWildcard' (LL _ HsRecField {hsRecFieldArg=(LL _ (EWildPat _))}) = True-isFieldWildcard' (LL _ HsRecField {hsRecPun=True}) = True-isFieldWildcard' (LL _ HsRecField {}) = False-isFieldWildcard' _ = False -- {-# COMPLETE LL #-}--isUnboxed' :: Boxity -> Bool-isUnboxed' Unboxed = True; isUnboxed' _ = False
− src/GHC/Util/HsExtendInstances.hs
@@ -1,36 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module GHC.Util.HsExtendInstances (- HsExtendInstances(..)- , extendInstances', unExtendInstances'- , astEq', astListEq') where--import Outputable-import Data.Function--newtype HsExtendInstances a =- HsExtendInstances a deriving Outputable -- Wrapper of terms.--- The issue is that at times, terms we work with in this program are--- not in `Eq` and `Ord` and we need them to be. This work-around--- resorts to implementing `Eq` and `Ord` for the these types via--- lexicographical comparisons of string representations. As long as--- two different terms never map to the same string representation,--- basing `Eq` and `Ord` on their string representations rather than--- the term types themselves, leads to identical results.-toStr :: Outputable a => HsExtendInstances a -> String-toStr (HsExtendInstances e) = Outputable.showSDocUnsafe $ Outputable.ppr e-instance Outputable a => Eq (HsExtendInstances a) where (==) a b = toStr a == toStr b-instance Outputable a => Ord (HsExtendInstances a) where compare = compare `on` toStr-instance Outputable a => Show (HsExtendInstances a) where show = toStr--extendInstances' :: a -> HsExtendInstances a-extendInstances' = HsExtendInstances--unExtendInstances' :: HsExtendInstances a -> a-unExtendInstances' (HsExtendInstances x) = x--astEq' :: Outputable a => a -> a -> Bool-astEq' a b = extendInstances' a == extendInstances' b--astListEq' :: Outputable a => [a] -> [a] -> Bool-astListEq' as bs = length as == length bs && all (uncurry astEq') (zip as bs)
src/GHC/Util/Unify.hs view
@@ -21,6 +21,7 @@ import RdrName import OccName +import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import GHC.Util.Outputable import GHC.Util.HsExpr import GHC.Util.Pat@@ -77,7 +78,7 @@ pat :: LPat GhcPs -> LPat GhcPs -- Pattern variables. pat (LL _ (VarPat _ x))- | Just y@(LL _ HsVar{}) <- lookup (rdrNameStr' x) bind = strToPat' (varToStr' y)+ | Just y@(LL _ HsVar{}) <- lookup (rdrNameStr' x) bind = strToPat' (varToStr y) pat x = x :: LPat GhcPs typ :: LHsType GhcPs -> LHsType GhcPs@@ -112,24 +113,24 @@ unifyExp' :: NameMatch' -> Bool -> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst' (LHsExpr GhcPs) ) -- Brackets are not added when expanding '$' in user code, so tolerate -- them in the match even if they aren't in the user code.-unifyExp' nm root x y | not root, isPar' x, not $ isPar' y = unifyExp' nm root (fromParen' x) y+unifyExp' nm root x y | not root, isPar x, not $ isPar y = unifyExp' nm root (fromParen' x) y -- Don't subsitute for type apps, since no one writes rules imaginging -- they exist.-unifyExp' nm root (LL _ (HsVar _ (rdrNameStr' -> v))) y | isUnifyVar v, not $ isTypeApp' y = Just $ Subst' [(v, y)]+unifyExp' nm root (LL _ (HsVar _ (rdrNameStr' -> v))) y | isUnifyVar v, not $ isTypeApp y = Just $ Subst' [(v, y)] unifyExp' nm root (LL _ (HsVar _ x)) (LL _ (HsVar _ y)) | nm x y = Just mempty -- Match wildcard operators. unifyExp' nm root (LL _ (OpApp _ lhs1 (LL _ (HsVar _ (rdrNameStr' -> v))) rhs1)) (LL _ (OpApp _ lhs2 (LL _ (HsVar _ (rdrNameStr' -> op2))) rhs2)) | isUnifyVar v =- (Subst' [(v, strToVar' op2)] <>) <$>+ (Subst' [(v, strToVar op2)] <>) <$> liftM2 (<>) (unifyExp' nm False lhs1 lhs2) (unifyExp' nm False rhs1 rhs2) unifyExp' nm root (LL _ (SectionL _ exp1 (LL _ (HsVar _ (rdrNameStr' -> v))))) (LL _ (SectionL _ exp2 (LL _ (HsVar _ (rdrNameStr' -> op2)))))- | isUnifyVar v = (Subst' [(v, strToVar' op2)] <>) <$> unifyExp' nm False exp1 exp2+ | isUnifyVar v = (Subst' [(v, strToVar op2)] <>) <$> unifyExp' nm False exp1 exp2 unifyExp' nm root (LL _ (SectionR _ (LL _ (HsVar _ (rdrNameStr' -> v))) exp1)) (LL _ (SectionR _ (LL _ (HsVar _ (rdrNameStr' -> op2))) exp2))- | isUnifyVar v = (Subst' [(v, strToVar' op2)] <>) <$> unifyExp' nm False exp1 exp2+ | isUnifyVar v = (Subst' [(v, strToVar op2)] <>) <$> unifyExp' nm False exp1 exp2 -- Options: match directly, and expand through '.' unifyExp' nm root x@(LL _ (HsApp _ x1 x2)) (LL _ (HsApp _ y1 y2)) =@@ -139,14 +140,14 @@ -- duplicate matches because the matching engine -- auto-generates hints in dot-form. (LL _ (OpApp _ y11 dot y12)) <- return $ fromParen' y1- guard $ isDot' dot+ guard $ isDot dot unifyExp' nm root x (noLoc (HsApp noExt y11 (noLoc (HsApp noExt y12 y2)))) ) -- Options: match directly, then expand through '$', then desugar infix. unifyExp' nm root x (LL _ (OpApp _ lhs2 op2@(LL _ (HsVar _ op2')) rhs2)) | (LL _ (OpApp _ lhs1 op1@(LL _ (HsVar _ op1')) rhs1)) <- x = guard (nm op1' op2') >> liftM2 (<>) (unifyExp' nm False lhs1 lhs2) (unifyExp' nm False rhs1 rhs2)- | isDol' op2 = unifyExp' nm root x $ noLoc (HsApp noExt lhs2 rhs2)+ | isDol op2 = unifyExp' nm root x $ noLoc (HsApp noExt lhs2 rhs2) | otherwise = unifyExp' nm root x $ noLoc (HsApp noExt (noLoc (HsApp noExt op2 lhs2)) rhs2) unifyExp' nm root x y | isOther x, isOther y = unifyDef' nm x y@@ -164,9 +165,9 @@ unifyPat' :: NameMatch' -> LPat GhcPs -> LPat GhcPs -> Maybe (Subst' (LHsExpr GhcPs)) unifyPat' nm (LL _ (VarPat _ x)) (LL _ (VarPat _ y)) =- Just $ Subst' [(rdrNameStr' x, strToVar'(rdrNameStr' y))]+ Just $ Subst' [(rdrNameStr' x, strToVar(rdrNameStr' y))] unifyPat' nm (LL _ (VarPat _ x)) (LL _ (WildPat _)) =- let s = rdrNameStr' x in Just $ Subst' [(s, strToVar'("_" ++ s))]+ let s = rdrNameStr' x in Just $ Subst' [(s, strToVar("_" ++ s))] unifyPat' nm (LL _ (ConPatIn x _)) (LL _ (ConPatIn y _)) | rdrNameStr' x /= rdrNameStr' y = Nothing unifyPat' nm x y =
src/Grep.hs view
@@ -12,7 +12,7 @@ import qualified HsSyn as GHC import qualified BasicTypes as GHC-import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import SrcLoc as GHC hiding (mkSrcSpan) runGrep :: String -> ParseFlags -> [FilePath] -> IO ()@@ -27,7 +27,7 @@ let unit = GHC.noLoc $ GHC.ExplicitTuple GHC.noExt [] GHC.Boxed let rule = hintRules [HintRule Suggestion "grep" scope exp (Tuple an Boxed []) Nothing [] -- Todo : Replace these with "proper" GHC expressions.- (extendInstances' mempty) (extendInstances' unit) (extendInstances' unit) Nothing]+ (extendInstances mempty) (extendInstances unit) (extendInstances unit) Nothing] forM_ files $ \file -> do res <- parseModuleEx flags file Nothing case res of
src/Hint/Bracket.hs view
@@ -98,6 +98,7 @@ import Outputable import SrcLoc import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr bracketHint :: DeclHint' bracketHint _ _ x =@@ -145,7 +146,7 @@ -- Might be '$x', which was really '$ x', but TH enabled misparsed it. isPartialAtom (LL _ (HsSpliceE _ (HsTypedSplice _ HasDollar _ _) )) = True isPartialAtom (LL _ (HsSpliceE _ (HsUntypedSplice _ HasDollar _ _) )) = True-isPartialAtom x = isRecConstr' x || isRecUpdate' x+isPartialAtom x = isRecConstr x || isRecUpdate x bracket :: forall a . (Data a, Data (SrcSpanLess a), HasSrcSpan a, Outputable a, Brackets' a) => (a -> String) -> (a -> Bool) -> Bool -> a -> [Idea] bracket pretty isPartialAtom root = f Nothing@@ -215,11 +216,11 @@ fieldDecl _ = [] -- This function relies heavily on fixities having been applied to the--- raw parse tree (c.f. 'Util.Refact.Fixings').+-- raw parse tree. dollar :: LHsExpr GhcPs -> [Idea] dollar = concatMap f . universe where- f x = [ suggest' "Redundant $" x y [r]| o@(LL loc (OpApp _ a d b)) <- [x], isDol' d+ f x = [ suggest' "Redundant $" x y [r]| o@(LL loc (OpApp _ a d b)) <- [x], isDol d , let y = noLoc (HsApp noExt a b) :: LHsExpr GhcPs , not $ needBracket' 0 y a , not $ needBracket' 1 y b@@ -228,14 +229,14 @@ ++ [ suggest' "Move brackets to avoid $" x (t y) [r] |(t, e@(LL _ (HsPar _ (LL _ (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+ , isDol op1+ , isVar a1 || isApp a1 || isPar a1, not $ isAtom' a2+ , varToStr a1 /= "select" -- special case for esqueleto, see #224 , let y = noLoc $ HsApp noExt a1 (noLoc (HsPar noExt a2)) , let r = Replace Expr (toSS' e) [("a", toSS' a1), ("b", toSS' a2)] "a (b)" ] ++ -- Special case of (v1 . v2) <$> v3 [ suggest' "Redundant bracket" x y []- | LL _ (OpApp _ (LL _ (HsPar _ o1@(LL _ (OpApp _ v1 (isDot' -> True) v2)))) o2 v3) <- [x], varToStr' o2 == "<$>"+ | LL _ (OpApp _ (LL _ (HsPar _ o1@(LL _ (OpApp _ v1 (isDot -> True) v2)))) o2 v3) <- [x], varToStr o2 == "<$>" , let y = noLoc (OpApp noExt o1 o2 v3) :: LHsExpr GhcPs] splitInfix :: LHsExpr GhcPs -> [(LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)]
src/Hint/Duplicate.hs view
@@ -36,6 +36,7 @@ import Outputable import Bag import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances duplicateHint :: CrossHint duplicateHint ms =@@ -67,7 +68,7 @@ | ((m1, d1, SrcSpanD p1), (m2, d2, SrcSpanD p2), xs) <- duplicateOrdered 3 $ map f ys] where f (m, d, xs) =- [((m, d, SrcSpanD (getLoc x)), extendInstances' (stripLocs' x)) | x <- xs]+ [((m, d, SrcSpanD (getLoc x)), extendInstances (stripLocs' x)) | x <- xs] --------------------------------------------------------------------- -- DUPLICATE FINDING
src/Hint/Extensions.hs view
@@ -161,6 +161,7 @@ import OccName import ForeignCall import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr extensionsHint :: ModuHint extensionsHint _ x =@@ -244,11 +245,11 @@ usedExt _ = const True used :: KnownExtension -> Located (HsModule GhcPs) -> Bool-used RecursiveDo = hasS isMDo' ||^ hasS isRecStmt'-used ParallelListComp = hasS isParComp'+used RecursiveDo = hasS isMDo ||^ hasS isRecStmt+used ParallelListComp = hasS isParComp used FunctionalDependencies = hasT (un :: FunDep (Located RdrName)) used ImplicitParams = hasT (un :: HsIPName)-used TypeApplications = hasS isTypeApp'+used TypeApplications = hasS isTypeApp used EmptyDataDecls = hasS f where f :: HsDataDefn GhcPs -> Bool@@ -266,7 +267,7 @@ isStrictMatch :: HsMatchContext RdrName -> Bool isStrictMatch FunRhs{mc_strictness=SrcStrict} = True isStrictMatch _ = False-used TemplateHaskell = hasT2' (un :: (HsBracket GhcPs, HsSplice GhcPs)) ||^ hasS f ||^ hasS isSpliceDecl'+used TemplateHaskell = hasT2' (un :: (HsBracket GhcPs, HsSplice GhcPs)) ||^ hasS f ||^ hasS isSpliceDecl where f :: HsBracket GhcPs -> Bool f VarBr{} = True@@ -284,9 +285,9 @@ g _ = True used StandaloneDeriving = hasS isDerivD' used PatternSignatures = hasS isPatTypeSig'-used RecordWildCards = hasS hasFieldsDotDot' ||^ hasS hasPFieldsDotDot'-used RecordPuns = hasS isPFieldPun' ||^ hasS isFieldPun'-used NamedFieldPuns = hasS isPFieldPun' ||^ hasS isFieldPun'+used RecordWildCards = hasS hasFieldsDotDot ||^ hasS hasPFieldsDotDot'+used RecordPuns = hasS isPFieldPun' ||^ hasS isFieldPun+used NamedFieldPuns = hasS isPFieldPun' ||^ hasS isFieldPun used UnboxedTuples = has isUnboxedTuple' ||^ has (== Unboxed) ||^ hasS isDeriving where -- detect if there are deriving declarations or data ... deriving stuff@@ -299,7 +300,7 @@ f :: ImportDecl GhcPs -> Bool f ImportDecl{ideclPkgQual=Just _} = True f _ = False-used QuasiQuotes = hasS isQuasiQuote' ||^ hasS isTyQuasiQuote'+used QuasiQuotes = hasS isQuasiQuote ||^ hasS isTyQuasiQuote' used ViewPatterns = hasS isPViewPat' used DefaultSignatures = hasS isClsDefSig' used DeriveDataTypeable = hasDerive ["Data","Typeable"]@@ -308,9 +309,9 @@ used DeriveTraversable = hasDerive ["Traversable","Foldable","Functor"] used DeriveGeneric = hasDerive ["Generic","Generic1"] used GeneralizedNewtypeDeriving = not . null . derivesNewtype' . derives-used LambdaCase = hasS isLCase'-used TupleSections = hasS isTupleSection'-used OverloadedStrings = hasS isString'+used LambdaCase = hasS isLCase+used TupleSections = hasS isTupleSection+used OverloadedStrings = hasS isString used Arrows = hasS f where f :: HsExpr GhcPs -> Bool@@ -322,7 +323,7 @@ f :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool f TransStmt{} = True f _ = False-used MagicHash = hasS f ||^ hasS isPrimLiteral'+used MagicHash = hasS f ||^ hasS isPrimLiteral where f :: RdrName -> Bool f s = "#" `isSuffixOf` (occNameString . rdrNameOcc) s
src/Hint/List.hs view
@@ -58,6 +58,8 @@ import TysWiredIn import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances listHint :: DeclHint' listHint _ _ = listDecl@@ -94,7 +96,7 @@ list_comp_aux e xs | "False" `elem` cons = [suggest' "Short-circuited list comprehension" o o' (suggestExpr o o')] | "True" `elem` cons = [suggest' "Redundant True guards" o o2 (suggestExpr o o2)]- | not (astListEq' xs ys) = [suggest' "Move guards forward" o o3 (suggestExpr o o3)]+ | not (astListEq xs ys) = [suggest' "Move guards forward" o o3 (suggestExpr o o3)] | otherwise = [] where ys = moveGuardsForward xs@@ -108,7 +110,7 @@ listCompCheckMap :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsStmtContext Name -> [ExprLStmt GhcPs] -> [Idea]-listCompCheckMap o mp f ctx stmts | varToStr' mp == "map" =+listCompCheckMap o mp f ctx stmts | varToStr mp == "map" = [suggest' "Move map inside list comprehension" o o2 (suggestExpr o o2)] where revs = reverse stmts@@ -152,7 +154,7 @@ , Just (x2, subts, temp) <- [f x] , let r = Replace Pattern (toSS' x) subts temp ] isAppend :: View' a App2' => a -> Bool-isAppend (view' -> App2' op _ _) = varToStr' op == "++"+isAppend (view' -> App2' op _ _) = varToStr op == "++" isAppend _ = False checks ::[(String, Bool -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String))]@@ -193,7 +195,7 @@ g c p = ([c], VarPat noExt (noLoc $ mkVarUnqual (fsLit [c]))) useString :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [a], String)-useString b (LL _ (ExplicitList _ _ xs)) | not $ null xs, Just s <- mapM fromChar' xs =+useString b (LL _ (ExplicitList _ _ xs)) | not $ null xs, Just s <- mapM fromChar xs = let literal = noLoc (HsLit noExt (HsString NoSourceText (fsLit (show s)))) in Just (literal, [], unsafePrettyPrint literal) useString _ _ = Nothing@@ -209,27 +211,27 @@ ) . f True ['a'..'z'] where- f first _ x | varToStr' x == "[]" = if first then Nothing else Just []- f first (ident:cs) (view' -> App2' c a b) | varToStr' c == ":" =+ f first _ x | varToStr x == "[]" = if first then Nothing else Just []+ f first (ident:cs) (view' -> App2' c a b) | varToStr c == ":" = ((a, g ident a) :) <$> f False cs b f first _ _ = Nothing g :: Char -> LHsExpr GhcPs -> (String, LHsExpr GhcPs)- g c p = ([c], strToVar' [c])+ g c p = ([c], strToVar [c]) useCons :: View' a App2' => Bool -> a -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String)-useCons False (view' -> App2' op x y) | varToStr' op == "++"+useCons False (view' -> App2' op x y) | varToStr op == "++" , Just (x2, build) <- f x , not $ isAppend y = Just (gen (build x2) y , [("x", toSS' x2), ("xs", toSS' y)]- , unsafePrettyPrint $ gen (build $ strToVar' "x") (strToVar' "xs")+ , unsafePrettyPrint $ gen (build $ strToVar "x") (strToVar "xs") ) where f :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs) f (LL _ (ExplicitList _ _ [x]))=- Just (x, \v -> if isApp' x then v else paren' v)+ Just (x, \v -> if isApp x then v else paren' v) f _ = Nothing gen :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs@@ -258,6 +260,6 @@ g :: LHsType GhcPs -> [Idea] g e@(fromTyParen' -> x) = [suggest' "Use String" x (transform f x) rs | not . null $ rs]- where f x = if astEq' x typeListChar then typeString else x- rs = [Replace Type (toSS' t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq' t typeListChar]+ where f x = if astEq x typeListChar then typeString else x+ rs = [Replace Type (toSS' t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq t typeListChar] stringType _ = [] -- {-# COMPLETE LL #-}
src/Hint/ListRec.hs view
@@ -53,6 +53,8 @@ import BasicTypes import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances listRecHint :: DeclHint' listRecHint _ _ = concatMap f . universe@@ -69,7 +71,7 @@ recursiveStr :: String recursiveStr = "_recursive_"-recursive = strToVar' recursiveStr+recursive = strToVar recursiveStr data ListCase = ListCase@@ -97,29 +99,29 @@ matchListRec :: ListCase -> Maybe (String, Severity, LHsExpr GhcPs) matchListRec o@(ListCase vs nil (x, xs, cons)) -- Suggest 'map'?- | [] <- vs, varToStr' nil == "[]", (LL _ (OpApp _ lhs c rhs)) <- cons, varToStr' c == ":"- , astEq' (fromParen' rhs) recursive, xs `notElem` vars' lhs+ | [] <- vs, varToStr nil == "[]", (LL _ (OpApp _ lhs c rhs)) <- cons, varToStr c == ":"+ , astEq (fromParen' rhs) recursive, xs `notElem` vars' lhs = Just $ (,,) "map" Hint.Type.Warning $- appsBracket' [ strToVar' "map", niceLambda' [x] lhs, strToVar' xs]+ appsBracket' [ strToVar "map", niceLambda' [x] lhs, strToVar xs] -- Suggest 'foldr'? | [] <- vs, App2' op lhs rhs <- view' cons , xs `notElem` (vars' op ++ vars' lhs) -- the meaning of xs changes, see #793- , astEq' (fromParen' rhs) recursive+ , astEq (fromParen' rhs) recursive = Just $ (,,) "foldr" Suggestion $- appsBracket' [ strToVar' "foldr", niceLambda' [x] $ appsBracket' [op,lhs], nil, strToVar' xs]+ appsBracket' [ strToVar "foldr", niceLambda' [x] $ appsBracket' [op,lhs], nil, strToVar xs] -- Suggest 'foldl'? | [v] <- vs, view' nil == Var_' v, (LL _ (HsApp _ r lhs)) <- cons- , astEq' (fromParen' r) recursive+ , astEq (fromParen' r) recursive , xs `notElem` vars' lhs = Just $ (,,) "foldl" Suggestion $- appsBracket' [ strToVar' "foldl", niceLambda' [v,x] lhs, strToVar' v, strToVar' xs]+ appsBracket' [ strToVar "foldl", niceLambda' [v,x] lhs, strToVar v, strToVar xs] -- Suggest 'foldM'?- | [v] <- vs, (LL _ (HsApp _ ret res)) <- nil, isReturn' ret, varToStr' res == "()" || view' res == Var_' v+ | [v] <- vs, (LL _ (HsApp _ ret res)) <- nil, isReturn ret, varToStr res == "()" || view' res == Var_' v , [LL _ (BindStmt _ (view' -> PVar_' b1) e _ _), LL _ (BodyStmt _ (fromParen' -> (LL _ (HsApp _ r (view' -> Var_' b2)))) _ _)] <- asDo cons- , b1 == b2, astEq' r recursive, xs `notElem` vars' e- , name <- "foldM" ++ ['_' | varToStr' res == "()"]+ , b1 == b2, astEq r recursive, xs `notElem` vars' e+ , name <- "foldM" ++ ['_' | varToStr res == "()"] = Just $ (,,) name Suggestion $- appsBracket' [strToVar' name, niceLambda' [v,x] e, strToVar' v, strToVar' xs]+ appsBracket' [strToVar name, niceLambda' [v,x] e, strToVar v, strToVar xs] -- Nope, I got nothing ¯\_(ツ)_/¯. | otherwise = Nothing @@ -137,10 +139,10 @@ [LL _ (GRHS _ [] rhs)] (LL _ (EmptyLocalBinds _))}]})) ) =- [ noLoc $ BindStmt noExt v lhs noSyntaxExpr' noSyntaxExpr'- , noLoc $ BodyStmt noExt rhs noSyntaxExpr' noSyntaxExpr' ]+ [ noLoc $ BindStmt noExt v lhs noSyntaxExpr noSyntaxExpr+ , noLoc $ BodyStmt noExt rhs noSyntaxExpr noSyntaxExpr ] asDo (LL _ (HsDo _ DoExpr (LL _ stmts))) = stmts-asDo x = [noLoc $ BodyStmt noExt x noSyntaxExpr' noSyntaxExpr']+asDo x = [noLoc $ BodyStmt noExt x noSyntaxExpr noSyntaxExpr] ---------------------------------------------------------------------@@ -185,11 +187,11 @@ eliminateArgs :: [String] -> LHsExpr GhcPs -> ([String], LHsExpr GhcPs) eliminateArgs ps cons = (remove ps, transform f cons) where- args = [zs | z : zs <- map fromApps' $ universeApps' cons, astEq' z recursive]+ args = [zs | z : zs <- map fromApps' $ universeApps' cons, astEq z recursive] elim = [all (\xs -> length xs > i && view' (xs !! i) == Var_' p) args | (i, p) <- zip [0..] ps] ++ repeat False remove = concat . zipWith (\b x -> [x | not b]) elim - f (fromApps' -> x : xs) | astEq' x recursive = apps' $ x : remove xs+ f (fromApps' -> x : xs) | astEq x recursive = apps' $ x : remove xs f x = x
src/Hint/Match.hs view
@@ -60,28 +60,30 @@ import OccName import Data.Data import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr+import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances readMatch' :: [HintRule] -> Scope' -> ModuleEx -> LHsDecl GhcPs -> [Idea] readMatch' settings = findIdeas' (concatMap readRule' settings) readRule' :: HintRule -> [HintRule]-readRule' m@HintRule{ hintRuleGhcLHS=(stripLocs' . unExtendInstances' -> hintRuleGhcLHS)- , hintRuleGhcRHS=(stripLocs' . unExtendInstances' -> hintRuleGhcRHS)- , hintRuleGhcSide=((stripLocs' . unExtendInstances' <$>) -> hintRuleGhcSide)+readRule' m@HintRule{ hintRuleGhcLHS=(stripLocs' . unextendInstances -> hintRuleGhcLHS)+ , hintRuleGhcRHS=(stripLocs' . unextendInstances -> hintRuleGhcRHS)+ , hintRuleGhcSide=((stripLocs' . unextendInstances <$>) -> hintRuleGhcSide) } =- (:) m{ hintRuleGhcLHS=extendInstances' hintRuleGhcLHS- , hintRuleGhcRHS=extendInstances' hintRuleGhcRHS- , hintRuleGhcSide=extendInstances' <$> hintRuleGhcSide } $ do+ (:) m{ hintRuleGhcLHS=extendInstances hintRuleGhcLHS+ , hintRuleGhcRHS=extendInstances hintRuleGhcRHS+ , hintRuleGhcSide=extendInstances <$> hintRuleGhcSide } $ do (l, v1) <- dotVersion' hintRuleGhcLHS (r, v2) <- dotVersion' hintRuleGhcRHS guard $ v1 == v2 && not (null l) && (length l > 1 || length r > 1) && Set.notMember v1 (Set.map occNameString (freeVars' $ maybeToList hintRuleGhcSide ++ l ++ r)) if not (null r) then- [ m{ hintRuleGhcLHS=extendInstances' (dotApps' l), hintRuleGhcRHS=extendInstances' (dotApps' r), hintRuleGhcSide=extendInstances' <$> hintRuleGhcSide }- , m{ hintRuleGhcLHS=extendInstances' (dotApps' (l ++ [strToVar' v1])), hintRuleGhcRHS=extendInstances' (dotApps' (r ++ [strToVar' v1])), hintRuleGhcSide=extendInstances' <$> hintRuleGhcSide } ]+ [ m{ hintRuleGhcLHS=extendInstances (dotApps' l), hintRuleGhcRHS=extendInstances (dotApps' r), hintRuleGhcSide=extendInstances <$> hintRuleGhcSide }+ , m{ hintRuleGhcLHS=extendInstances (dotApps' (l ++ [strToVar v1])), hintRuleGhcRHS=extendInstances (dotApps' (r ++ [strToVar v1])), hintRuleGhcSide=extendInstances <$> hintRuleGhcSide } ] else if length l > 1 then- [ m{ hintRuleGhcLHS=extendInstances' (dotApps' l), hintRuleGhcRHS=extendInstances' (strToVar' "id"), hintRuleGhcSide=extendInstances' <$> hintRuleGhcSide }- , m{ hintRuleGhcLHS=extendInstances' (dotApps' (l++[strToVar' v1])), hintRuleGhcRHS=extendInstances' (strToVar' v1), hintRuleGhcSide=extendInstances' <$> hintRuleGhcSide}]+ [ m{ hintRuleGhcLHS=extendInstances (dotApps' l), hintRuleGhcRHS=extendInstances (strToVar "id"), hintRuleGhcSide=extendInstances <$> hintRuleGhcSide }+ , m{ hintRuleGhcLHS=extendInstances (dotApps' (l++[strToVar v1])), hintRuleGhcRHS=extendInstances (strToVar v1), hintRuleGhcSide=extendInstances <$> hintRuleGhcSide}] else [] -- Find a dot version of this rule, return the sequence of app@@ -110,7 +112,7 @@ | (name, expr) <- findDecls' decl , (parent,x) <- universeParentExp' expr , m <- matches, Just (y, notes, subst) <- [matchIdea' s name m parent x]- , let r = R.Replace R.Expr (toSS' x) subst (unsafePrettyPrint $ unExtendInstances' (hintRuleGhcRHS m))+ , let r = R.Replace R.Expr (toSS' x) subst (unsafePrettyPrint $ unextendInstances (hintRuleGhcRHS m)) ] -- | A list of root expressions, with their associated names@@ -127,12 +129,12 @@ -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [Note], [(String, R.SrcSpan)]) matchIdea' sb declName HintRule{..} parent x = do- let lhs = unExtendInstances' hintRuleGhcLHS- rhs = unExtendInstances' hintRuleGhcRHS- sa = unExtendInstances' hintRuleGhcScope+ let lhs = unextendInstances hintRuleGhcLHS+ rhs = unextendInstances hintRuleGhcRHS+ sa = unextendInstances hintRuleGhcScope nm a b = scopeMatch' (sa, a) (sb, b) u <- unifyExp' nm True lhs x- u <- validSubst' astEq' u+ u <- validSubst' astEq u -- Need to check free vars before unqualification, but after subst -- (with 'e') need to unqualify before substitution (with 'res').@@ -145,9 +147,9 @@ -- we have lambdas we might be moving, and QuasiQuotes, we might -- inadvertantly break free vars because quasi quotes don't show -- what free vars they make use of.- guard $ not (any isLambda' $ universe lhs) || not (any isQuasiQuote' $ universe x)+ guard $ not (any isLambda $ universe lhs) || not (any isQuasiQuote $ universe x) - guard $ checkSide' (unExtendInstances' <$> hintRuleGhcSide) $ ("original", x) : ("result", res) : fromSubst' u+ guard $ checkSide' (unextendInstances <$> hintRuleGhcSide) $ ("original", x) : ("result", res) : fromSubst' u guard $ checkDefine' declName parent res return (res, hintRuleNotes, [(s, toSS' pos) | (s, pos) <- fromSubst' u, getLoc pos /= noSrcSpan])@@ -160,29 +162,29 @@ where bool :: LHsExpr GhcPs -> Bool bool (LL _ (OpApp _ x op y))- | varToStr' op == "&&" = bool x && bool y- | varToStr' op == "||" = bool x || bool y- | varToStr' op == "==" = expr (fromParen1' x) `astEq'` expr (fromParen1' y)- bool (LL _ (HsApp _ x y)) | varToStr' x == "not" = not $ bool y+ | varToStr op == "&&" = bool x && bool y+ | varToStr op == "||" = bool x || bool y+ | varToStr op == "==" = expr (fromParen1' x) `astEq` expr (fromParen1' y)+ bool (LL _ (HsApp _ x y)) | varToStr x == "not" = not $ bool y bool (LL _ (HsPar _ x)) = bool x bool (LL _ (HsApp _ cond (sub -> y)))- | 'i' : 's' : typ <- varToStr' cond = isType typ y+ | 'i' : 's' : typ <- varToStr cond = isType typ y bool (LL _ (HsApp _ (LL _ (HsApp _ cond (sub -> x))) (sub -> y)))- | varToStr' cond == "notIn" = and [extendInstances' (stripLocs' x) `notElem` map (extendInstances' . stripLocs') (universe y) | x <- list x, y <- list y]- | varToStr' cond == "notEq" = not (x `astEq'` y)- bool x | varToStr' x == "noTypeCheck" = True- bool x | varToStr' x == "noQuickCheck" = True+ | varToStr cond == "notIn" = and [extendInstances (stripLocs' x) `notElem` map (extendInstances . stripLocs') (universe y) | x <- list x, y <- list y]+ | varToStr cond == "notEq" = not (x `astEq` y)+ bool x | varToStr x == "noTypeCheck" = True+ bool x | varToStr x == "noQuickCheck" = True bool x = error $ "Hint.Match.checkSide', unknown side condition: " ++ unsafePrettyPrint x expr :: LHsExpr GhcPs -> LHsExpr GhcPs- expr (LL _ (HsApp _ (varToStr' -> "subst") x)) = sub $ fromParen1' x+ expr (LL _ (HsApp _ (varToStr -> "subst") x)) = sub $ fromParen1' x expr x = x isType "Compare" x = True -- Just a hint for proof stuff isType "Atom" x = isAtom' x- isType "WHNF" x = isWHNF' x- isType "Wildcard" x = any isFieldPun' (universeBi x) || any hasFieldsDotDot' (universeBi x)+ isType "WHNF" x = isWHNF x+ isType "Wildcard" x = any isFieldPun (universeBi x) || any hasFieldsDotDot (universeBi x) isType "Nat" (asInt -> Just x) | x >= 0 = True isType "Pos" (asInt -> Just x) | x > 0 = True isType "Neg" (asInt -> Just x) | x < 0 = True@@ -218,7 +220,12 @@ -- Does the result look very much like the declaration? checkDefine' :: String -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool-checkDefine' declName Nothing y = declName /= varToStr' (transformBi unqual' $ head $ fromApps' y)+checkDefine' declName Nothing y =+ let funOrOp expr = case expr of+ LL _ (HsApp _ fun _) -> funOrOp fun+ LL _ (OpApp _ _ op _) -> funOrOp op+ other -> other+ in declName /= varToStr (transformBi unqual' $ funOrOp y) checkDefine' _ _ _ = True ---------------------------------------------------------------------@@ -229,9 +236,9 @@ performSpecial' = transform fNoParen . fEval where fEval, fNoParen :: LHsExpr GhcPs -> LHsExpr GhcPs- fEval (LL _ (HsApp _ e x)) | varToStr' e == "_eval_" = reduce' x+ fEval (LL _ (HsApp _ e x)) | varToStr e == "_eval_" = reduce' x fEval x = x- fNoParen (LL _ (HsApp _ e x)) | varToStr' e == "_noParen_" = fromParen' x+ fNoParen (LL _ (HsApp _ e x)) | varToStr e == "_noParen_" = fromParen' x fNoParen x = x -- Contract : 'Data.List.foo' => 'foo' if 'Data.List' is loaded.
src/Hint/Monad.hs view
@@ -64,6 +64,7 @@ import RdrName import OccName import Bag+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import GHC.Util import Data.Tuple.Extra@@ -83,10 +84,10 @@ monadExp :: LHsDecl GhcPs -> (Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs) -> [Idea] monadExp (declName -> decl) (parent, x) = case x of- (view' -> App2' op x1 x2) | isTag' op ">>" -> f x1- (view' -> App2' op x1 (view' -> LamConst1' _)) | isTag' op ">>=" -> f x1- (LL l (HsApp _ op x)) | isTag' op "void" -> seenVoid (cL l . HsApp noExt op) x- (LL l (OpApp _ op dol x)) | isTag' op "void", isDol' dol -> seenVoid (cL l . OpApp noExt op dol) x+ (view' -> App2' op x1 x2) | isTag ">>" op -> f x1+ (view' -> App2' op x1 (view' -> LamConst1' _)) | isTag ">>=" op -> f x1+ (LL l (HsApp _ op x)) | isTag "void" op -> seenVoid (cL l . HsApp noExt op) x+ (LL l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (cL l . OpApp noExt op dol) x (LL loc (HsDo _ _ (LL _ [LL _ (BodyStmt _ y _ _ )]))) -> [warn' "Redundant do" x y [Replace Expr (toSS' x) [("y", toSS' y)] "y"] | not $ doOperator parent y] (LL loc (HsDo _ DoExpr (L _ xs))) -> monadSteps (cL loc . HsDo noExt DoExpr . noLoc) xs ++@@ -101,14 +102,14 @@ -- Sometimes people write 'a * do a + b', to avoid brackets. -- or using BlockArguments they can write 'a do a b' doOperator :: (Eq a, Num a) => Maybe (a, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool-doOperator (Just (2, LL _ (OpApp _ _ op _ ))) (LL _ OpApp {}) | not $ isDol' op = True+doOperator (Just (2, LL _ (OpApp _ _ op _ ))) (LL _ OpApp {}) | not $ isDol op = True doOperator (Just (1, LL _ HsApp{})) b | not $ isAtom' b = True doOperator _ _ = False returnsUnit :: LHsExpr GhcPs -> Bool returnsUnit (LL _ (HsPar _ x)) = returnsUnit x returnsUnit (LL _ (HsApp _ x _)) = returnsUnit x-returnsUnit (LL _ (OpApp _ x op _)) | isDol' op = returnsUnit x+returnsUnit (LL _ (OpApp _ x op _)) | isDol op = returnsUnit x returnsUnit (LL _ (HsVar _ (L _ x))) = occNameString (rdrNameOcc x) `elem` map (++ "_") badFuncs ++ unitFuncs returnsUnit _ = False @@ -118,12 +119,12 @@ monadNoResult inside wrap (LL l (HsPar _ x)) = monadNoResult inside (wrap . cL l . HsPar noExt) x monadNoResult inside wrap (LL l (HsApp _ x y)) = monadNoResult inside (\x -> wrap $ cL l (HsApp noExt x y)) x monadNoResult inside wrap (LL l (OpApp _ x tag@(LL _ (HsVar _ (L _ op))) y))- | isDol' tag = monadNoResult inside (\x -> wrap $ cL l (OpApp noExt x tag y)) x+ | isDol tag = monadNoResult inside (\x -> wrap $ cL l (OpApp noExt x tag y)) x | occNameString (rdrNameOcc op) == ">>=" = monadNoResult inside (wrap . cL l . OpApp noExt x tag) y monadNoResult inside wrap x- | x2 : _ <- filter (isTag' x) badFuncs+ | x2 : _ <- filter (`isTag` x) badFuncs , let x3 = x2 ++ "_"- = [warn' ("Use " ++ x3) (wrap x) (wrap $ strToVar' x3) [Replace Expr (toSS' x) [] x3] | inside /= x3]+ = [warn' ("Use " ++ x3) (wrap x) (wrap $ strToVar x3) [Replace Expr (toSS' x) [] x3] | inside /= x3] monadNoResult inside wrap (replaceBranches' -> (bs, rewrap)) = map (\x -> x{ideaNote=nubOrd $ Note "May require adding void to other branches" : ideaNote x}) $ concat [monadNoResult inside id b | b <- bs]@@ -139,14 +140,14 @@ monadStep wrap o@[ g@(LL _ (BindStmt _ (LL _ (VarPat _ (L _ p))) x _ _ )) , q@(LL _ (BodyStmt _ (fromRet -> Just (ret, LL _ (HsVar _ (L _ v)))) _ _))] | occNameString (rdrNameOcc p) == occNameString (rdrNameOcc v)- = [warn' ("Redundant " ++ ret) (wrap o) (wrap [noLoc $ BodyStmt noExt x noSyntaxExpr' noSyntaxExpr'])+ = [warn' ("Redundant " ++ ret) (wrap o) (wrap [noLoc $ BodyStmt noExt x noSyntaxExpr noSyntaxExpr]) [Replace Stmt (toSS' g) [("x", toSS' x)] "x", Delete Stmt (toSS' q)]] -- Suggest to use join. Rewrite 'do x <- $1; x; $2' as 'do join $1; $2'. monadStep wrap o@(g@(LL _ (BindStmt _ (view' -> PVar_' p) x _ _)):q@(LL _ (BodyStmt _ (view' -> Var_' v) _ _)):xs) | p == v && v `notElem` varss' xs- = let app = noLoc $ HsApp noExt (strToVar' "join") x- body = noLoc $ BodyStmt noExt (rebracket1' app) noSyntaxExpr' noSyntaxExpr'+ = let app = noLoc $ HsApp noExt (strToVar "join") x+ body = noLoc $ BodyStmt noExt (rebracket1' app) noSyntaxExpr noSyntaxExpr stmts = body : xs in [warn' "Use join" (wrap o) (wrap stmts) r] where r = [Replace Stmt (toSS' g) [("x", toSS' x)] "join x", Delete Stmt (toSS' q)]@@ -155,7 +156,7 @@ -- 'do <return ()>; $1'. monadStep wrap (o@(LL loc (BindStmt _ p x _ _)) : rest) | isPWildCard' p, returnsUnit x- = let body = cL loc $ BodyStmt noExt x noSyntaxExpr' noSyntaxExpr' :: ExprLStmt GhcPs+ = let body = cL loc $ BodyStmt noExt x noSyntaxExpr noSyntaxExpr :: ExprLStmt GhcPs in [warn' "Redundant variable capture" o body []] -- Redundant unit return : 'do <return ()>; return ()'.@@ -169,16 +170,16 @@ monadStep wrap o@[g@(LL _ (BindStmt _ (view' -> PVar_' u) x _ _)) , q@(LL _ (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)+ | isReturn ret, notDol x, u == v, length fs < 3, all isSimple (f : fs), v `notElem` vars' (f : fs) =- [warn' "Use <$>" (wrap o) (wrap [noLoc $ BodyStmt noExt (noLoc $ OpApp noExt (foldl' (\acc e -> noLoc $ OpApp noExt acc (strToVar' ".") e) f fs) (strToVar' "<$>") x) noSyntaxExpr' noSyntaxExpr'])+ [warn' "Use <$>" (wrap o) (wrap [noLoc $ BodyStmt noExt (noLoc $ OpApp noExt (foldl' (\acc e -> noLoc $ OpApp noExt acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr]) [Replace Stmt (toSS' g) (("x", toSS' x):zip vs (toSS' <$> f:fs)) (intercalate " . " (take (length fs + 1) vs) ++ " <$> x"), Delete Stmt (toSS' q)]] where isSimple (fromApps' -> xs) = all isAtom' (x : xs) vs = ('f':) . show <$> [0..] notDol :: LHsExpr GhcPs -> Bool- notDol (LL _ (OpApp _ _ op _)) = not $ isDol' op+ notDol (LL _ (OpApp _ _ op _)) = not $ isDol op notDol _ = True monadStep _ _ = []@@ -201,7 +202,7 @@ = (template p y, Just refact) where refact = Replace Stmt (toSS' g) [("lhs", toSS' v), ("rhs", toSS' y)]- (unsafePrettyPrint $ template "lhs" (strToVar' "rhs"))+ (unsafePrettyPrint $ template "lhs" (strToVar "rhs")) mkLet x = (x, Nothing) template :: String -> LHsExpr GhcPs -> ExprLStmt GhcPs@@ -218,11 +219,11 @@ fromApplies :: LHsExpr GhcPs -> ([LHsExpr GhcPs], LHsExpr GhcPs) fromApplies (LL _ (HsApp _ f x)) = first (f:) $ fromApplies (fromParen' x)-fromApplies (LL _ (OpApp _ f (isDol' -> True) x)) = first (f:) $ fromApplies x+fromApplies (LL _ (OpApp _ f (isDol -> True) x)) = first (f:) $ fromApplies x fromApplies x = ([], x) fromRet :: LHsExpr GhcPs -> Maybe (String, LHsExpr GhcPs) fromRet (LL _ (HsPar _ x)) = fromRet x fromRet (LL _ (OpApp _ x (LL _ (HsVar _ (L _ y))) z)) | occNameString (rdrNameOcc y) == "$" = fromRet $ noLoc (HsApp noExt x z)-fromRet (LL _ (HsApp _ x y)) | isReturn' x = Just (unsafePrettyPrint x, y)+fromRet (LL _ (HsApp _ x y)) | isReturn x = Just (unsafePrettyPrint x, y) fromRet _ = Nothing
src/Hint/Pattern.hs view
@@ -73,6 +73,7 @@ import BasicTypes import GHC.Util+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr patternHint :: DeclHint' patternHint _scope modu x =@@ -111,7 +112,7 @@ rawGuards = asGuards bod mkGuard :: LHsExpr GhcPs -> (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs))- mkGuard a = GRHS noExt [noLoc $ BodyStmt noExt a noSyntaxExpr' noSyntaxExpr']+ mkGuard a = GRHS noExt [noLoc $ BodyStmt noExt a noSyntaxExpr noSyntaxExpr] guards :: [LGRHS GhcPs (LHsExpr GhcPs)] guards = map (noLoc . uncurry mkGuard) rawGuards@@ -135,7 +136,7 @@ templateGuards = map noLoc (zipWith (mkGuard `on` toString) guardSubts exprSubts) toString (Left e) = e- toString (Right (v, _)) = strToVar' v+ toString (Right (v, _)) = strToVar v toString' (Left e) = e toString' (Right (v, _)) = strToPat' v @@ -157,7 +158,7 @@ hints gen (Pattern l t pats o@(GRHSs _ (unsnoc -> Just (gs, LL _ (GRHS _ [test] bod))) binds)) | unsafePrettyPrint test == "True" = let tag = noLoc (mkRdrUnqual $ mkVarOcc "otherwise")- otherwise_ = noLoc $ BodyStmt noExt (noLoc (HsVar noExt tag)) noSyntaxExpr' noSyntaxExpr' in+ otherwise_ = noLoc $ BodyStmt noExt (noLoc (HsVar noExt tag)) noSyntaxExpr noSyntaxExpr in [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLoc (GRHS noExt [otherwise_] bod)]}) [Replace Expr (toSS' test) [] "otherwise"]] hints _ _ = []
src/Hint/Unsafe.hs view
@@ -29,6 +29,7 @@ import FastString import BasicTypes import SrcLoc+import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import GHC.Util -- The conditions on which to fire this hint are subtle. We are@@ -74,12 +75,12 @@ -- Am I equivalent to @unsafePerformIO x@? isUnsafeApp :: HsExpr GhcPs -> Bool-isUnsafeApp (OpApp _ (LL _ l) op _ ) | isDol' op = isUnsafeFun l+isUnsafeApp (OpApp _ (LL _ l) op _ ) | isDol op = isUnsafeFun l isUnsafeApp (HsApp _ (LL _ x) _) = isUnsafeFun x isUnsafeApp _ = False -- Am I equivalent to @unsafePerformIO . x@? isUnsafeFun :: HsExpr GhcPs -> Bool isUnsafeFun (HsVar _ (LL _ x)) | x == mkVarUnqual (fsLit "unsafePerformIO") = True-isUnsafeFun (OpApp _ (LL _ l) op _) | isDot' op = isUnsafeFun l+isUnsafeFun (OpApp _ (LL _ l) op _) | isDot op = isUnsafeFun l isUnsafeFun _ = False