1{-# LANGUAGE LambdaCase, PatternGuards, TupleSections, ViewPatterns #-} 2 3{- 4 Concept: 5 Remove all the lambdas you can be inserting only sections 6 Never create a right section with +-# as the operator (they are misparsed) 7 8 Rules: 9 fun a = \x -> y -- promote lambdas, provided no where's outside the lambda 10 fun x = y x -- eta reduce, x /= mr and foo /= symbol 11 \x -> y x ==> y -- eta reduce 12 ((#) x) ==> (x #) -- rotate operators 13 (flip op x) ==> (`op` x) -- rotate operators 14 \x y -> x + y ==> (+) -- insert operator 15 \x y -> op y x ==> flip op 16 \x -> x + y ==> (+ y) -- insert section, 17 \x -> op x y ==> (`op` y) -- insert section 18 \x -> y + x ==> (y +) -- insert section 19 \x -> \y -> ... ==> \x y -- lambda compression 20 \x -> (x +) ==> (+) -- operator reduction 21 22<TEST> 23f a = \x -> x + x -- f a x = x + x 24f a = \a -> a + a -- f _ a = a + a 25a = \x -> x + x -- a x = x + x 26f (Just a) = \a -> a + a -- f (Just _) a = a + a 27f (Foo a b c) = \c -> c + c -- f (Foo a b _) c = c + c 28f a = \x -> x + x where _ = test 29f (test -> a) = \x -> x + x 30f = \x -> x + x -- f x = x + x 31fun x y z = f x y z -- fun = f 32fun x y z = f x x y z -- fun x = f x x 33fun x y z = f g z -- fun x y = f g 34fun x = f . g $ x -- fun = f . g 35fun a b = f a b c where g x y = h x y -- g = h 36fun a b = let g x y = h x y in f a b c -- g = h 37f = foo (\y -> g x . h $ y) -- g x . h 38f = foo (\y -> g x . h $ y) -- @Message Avoid lambda 39f = foo ((*) x) -- (x *) 40f = foo ((Prelude.*) x) -- (x Prelude.*) 41f = (*) x 42f = foo (flip op x) -- (`op` x) 43f = foo (flip op x) -- @Message Use section 44f = foo (flip x y) -- (`x` y) 45foo x = bar (\ d -> search d table) -- (`search` table) 46foo x = bar (\ d -> search d table) -- @Message Avoid lambda using `infix` 47f = flip op x 48f = foo (flip (*) x) -- (* x) 49f = foo (flip (Prelude.*) x) -- (Prelude.* x) 50f = foo (flip (-) x) 51f = foo (\x y -> fun x y) -- @Warning fun 52f = foo (\x y z -> fun x y z) -- @Warning fun 53f = foo (\z -> f x $ z) -- f x 54f = foo (\x y -> x + y) -- (+) 55f = foo (\x -> x * y) -- @Suggestion (* y) 56f = foo (\x -> x # y) 57f = foo (\x -> \y -> x x y y) -- \x y -> x x y y 58f = foo (\x -> \x -> foo x x) -- \_ x -> foo x x 59f = foo (\(foo -> x) -> \y -> x x y y) 60f = foo (\(x:xs) -> \x -> foo x x) -- \(_:xs) x -> foo x x 61f = foo (\x -> \y -> \z -> x x y y z z) -- \x y z -> x x y y z z 62x ! y = fromJust $ lookup x y 63f = foo (\i -> writeIdea (getClass i) i) 64f = bar (flip Foo.bar x) -- (`Foo.bar` x) 65f = a b (\x -> c x d) -- (`c` d) 66yes = \x -> a x where -- a 67yes = \x y -> op y x where -- flip op 68yes = \x y -> op z y x where -- flip (op z) 69f = \y -> nub $ reverse y where -- nub . reverse 70f = \z -> foo $ bar $ baz z where -- foo . bar . baz 71f = \z -> foo $ bar x $ baz z where -- foo . bar x . baz 72f = \z -> foo $ z $ baz z where 73f = \x -> bar map (filter x) where -- bar map . filter 74f = bar &+& \x -> f (g x) 75foo = [\column -> set column [treeViewColumnTitle := printf "%s (match %d)" name (length candidnates)]] 76foo = [\x -> x] 77foo = [\m x -> insert x x m] 78foo a b c = bar (flux ++ quux) c where flux = a -- foo a b = bar (flux ++ quux) 79foo a b c = bar (flux ++ quux) c where flux = c 80yes = foo (\x -> Just x) -- @Warning Just 81foo = bar (\x -> (x `f`)) -- f 82foo = bar (\x -> shakeRoot </> "src" </> x) 83baz = bar (\x -> (x +)) -- (+) 84xs `withArgsFrom` args = f args 85foo = bar (\x -> case x of Y z -> z) -- \(Y z) -> z 86foo = bar (\x -> case x of [y, z] -> z) -- \[y, z] -> z 87yes = blah (\ x -> case x of A -> a; B -> b) -- \ case A -> a; B -> b 88yes = blah (\ x -> case x of A -> a; B -> b) -- @Note may require `{-# LANGUAGE LambdaCase #-}` adding to the top of the file 89no = blah (\ x -> case x of A -> a x; B -> b x) 90foo = bar (\x -> case x of Y z | z > 0 -> z) -- \case Y z | z > 0 -> z 91yes = blah (\ x -> (y, x)) -- (y,) 92yes = blah (\ x -> (y, x, z+q)) -- (y, , z+q) 93yes = blah (\ x -> (y, x, y, u, v)) -- (y, , y, u, v) 94yes = blah (\ x -> (y, x, z+q)) -- @Note may require `{-# LANGUAGE TupleSections #-}` adding to the top of the file 95yes = blah (\ x -> (y, x, z+x)) 96tmp = map (\ x -> runST $ action x) 97yes = map (\f -> dataDir </> f) dataFiles -- (dataDir </>) 98{-# LANGUAGE TypeApplications #-}; noBug545 = coerce ((<>) @[a]) 99{-# LANGUAGE QuasiQuotes #-}; authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name 100{-# LANGUAGE QuasiQuotes #-}; authOAuth2 = foo (\name -> authOAuth2Widget [whamlet|Login via #{name}|] name) 101f = {- generates a hint using hlint.yaml only -} map (flip (,) "a") "123" 102f = {- generates a hint using hlint.yaml only -} map ((,) "a") "123" 103f = map (\s -> MkFoo s 0 s) ["a","b","c"] 104</TEST> 105-} 106 107 108module Hint.Lambda(lambdaHint) where 109 110import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, suggestN, ideaNote, substVars, toRefactSrcSpan) 111import Util 112import Data.List.Extra 113import Data.Set (Set) 114import qualified Data.Set as Set 115import Refact.Types hiding (Match) 116import Data.Generics.Uniplate.DataOnly (universe, universeBi, transformBi) 117 118import GHC.Types.Basic 119import GHC.Hs 120import GHC.Types.Name.Occurrence 121import GHC.Types.Name.Reader 122import GHC.Types.SrcLoc 123import Language.Haskell.GhclibParserEx.GHC.Hs.Expr (isTypeApp, isOpApp, isLambda, isQuasiQuote, isVar, isDol, strToVar) 124import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable 125import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader 126import GHC.Util.Brackets (isAtom) 127import GHC.Util.FreeVars (free, allVars, freeVars, pvars, vars, varss) 128import GHC.Util.HsExpr (allowLeftSection, allowRightSection, niceLambdaR, lambda) 129import GHC.Util.View 130 131lambdaHint :: DeclHint 132lambdaHint _ _ x 133 = concatMap (uncurry lambdaExp) (universeParentBi x) 134 ++ concatMap (uncurry lambdaBind) binds 135 where 136 binds = 137 ( case x of 138 -- Turn a top-level HsBind under a ValD into an LHsBind. 139 -- Also, its refact type needs to be Decl. 140 L loc (ValD _ bind) -> ((L loc bind, Decl) :) 141 _ -> id 142 ) 143 ((,Bind) <$> universeBi x) 144 145lambdaBind :: LHsBind GhcPs -> RType -> [Idea] 146lambdaBind 147 o@(L _ origBind@FunBind {fun_id = funName@(L loc1 _), fun_matches = 148 MG {mg_alts = 149 L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _) pats (GRHSs _ [L _ (GRHS _ [] origBody@(L loc2 _))] bind))]}}) rtype 150 | L _ (EmptyLocalBinds _) <- bind 151 , isLambda $ fromParen origBody 152 , null (universeBi pats :: [HsExpr GhcPs]) 153 = let (newPats, newBody) = fromLambda . lambda pats $ origBody 154 (sub, tpl) = mkSubtsAndTpl newPats newBody 155 gen :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs 156 gen ps = uncurry reform . fromLambda . lambda ps 157 refacts = case newBody of 158 -- https://github.com/alanz/ghc-exactprint/issues/97 159 L _ HsCase{} -> [] 160 _ -> [Replace rtype (toSS o) sub tpl] 161 in [warn "Redundant lambda" o (gen pats origBody) refacts] 162 163 | let (newPats, newBody) = etaReduce pats origBody 164 , length newPats < length pats, pvars (drop (length newPats) pats) `disjoint` varss bind 165 = let (sub, tpl) = mkSubtsAndTpl newPats newBody 166 in [warn "Eta reduce" (reform pats origBody) (reform newPats newBody) 167 [Replace rtype (toSS $ reform pats origBody) sub tpl] 168 ] 169 where reform :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs 170 reform ps b = L (combineSrcSpans loc1 loc2) $ ValD noExtField $ 171 origBind 172 {fun_matches = MG noExtField (noLoc [noLoc $ Match noExtField ctxt ps $ GRHSs noExtField [noLoc $ GRHS noExtField [] b] $ noLoc $ EmptyLocalBinds noExtField]) Generated} 173 174 mkSubtsAndTpl newPats newBody = (sub, tpl) 175 where 176 (origPats, vars) = mkOrigPats (Just (rdrNameStr funName)) newPats 177 sub = ("body", toSS newBody) : zip vars (map toSS newPats) 178 tpl = unsafePrettyPrint (reform origPats varBody) 179 180lambdaBind _ _ = [] 181 182etaReduce :: [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs) 183etaReduce (unsnoc -> Just (ps, view -> PVar_ p)) (L _ (HsApp _ x (view -> Var_ y))) 184 | p == y 185 , y `notElem` vars x 186 , not $ any isQuasiQuote $ universe x 187 = etaReduce ps x 188etaReduce ps (L loc (OpApp _ x (isDol -> True) y)) = etaReduce ps (L loc (HsApp noExtField x y)) 189etaReduce ps x = (ps, x) 190 191lambdaExp :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea] 192lambdaExp _ o@(L _ (HsPar _ (L _ (HsApp _ oper@(L _ (HsVar _ origf@(L _ (rdrNameOcc -> f)))) y)))) 193 | isSymOcc f -- is this an operator? 194 , isAtom y 195 , allowLeftSection $ occNameString f 196 , not $ isTypeApp y 197 = [suggest "Use section" o to [r]] 198 where 199 to :: LHsExpr GhcPs 200 to = noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField y oper 201 r = Replace Expr (toSS o) [("x", toSS y)] ("(x " ++ unsafePrettyPrint origf ++ ")") 202 203lambdaExp _ o@(L _ (HsPar _ (view -> App2 (view -> Var_ "flip") origf@(view -> RdrName_ f) y))) 204 | allowRightSection (rdrNameStr f), not $ "(" `isPrefixOf` rdrNameStr f 205 = [suggest "Use section" o to [r]] 206 where 207 to :: LHsExpr GhcPs 208 to = noLoc $ HsPar noExtField $ noLoc $ SectionR noExtField origf y 209 op = if isSymbolRdrName (unLoc f) 210 then unsafePrettyPrint f 211 else "`" ++ unsafePrettyPrint f ++ "`" 212 var = if rdrNameStr f == "x" then "y" else "x" 213 r = Replace Expr (toSS o) [(var, toSS y)] ("(" ++ op ++ " " ++ var ++ ")") 214lambdaExp p o@(L _ HsLam{}) 215 | not $ any isOpApp p 216 , (res, refact) <- niceLambdaR [] o 217 , not $ isLambda res 218 , not $ any isQuasiQuote $ universe res 219 , not $ "runST" `Set.member` Set.map occNameString (freeVars o) 220 , let name = "Avoid lambda" ++ (if countRightSections res > countRightSections o then " using `infix`" else "") 221 -- If the lambda's parent is an HsPar, and the result is also an HsPar, the span should include the parentheses. 222 , let from = case p of 223 -- Avoid creating redundant bracket. 224 Just p@(L _ (HsPar _ (L _ HsLam{}))) 225 | L _ HsPar{} <- res -> p 226 | L _ (HsVar _ (L _ name)) <- res, not (isSymbolRdrName name) -> p 227 _ -> o 228 = [(if isVar res then warn else suggest) name from res (refact $ toSS from)] 229 where 230 countRightSections :: LHsExpr GhcPs -> Int 231 countRightSections x = length [() | L _ (SectionR _ (view -> Var_ _) _) <- universe x] 232 233lambdaExp p o@(SimpleLambda origPats origBody) 234 | isLambda (fromParen origBody) 235 , null (universeBi origPats :: [HsExpr GhcPs]) -- TODO: I think this checks for view patterns only, so maybe be more explicit about that? 236 , maybe True (not . isLambda) p = 237 [suggest "Collapse lambdas" o (lambda pats body) [Replace Expr (toSS o) subts template]] 238 where 239 (pats, body) = fromLambda o 240 (oPats, vars) = mkOrigPats Nothing pats 241 subts = ("body", toSS body) : zip vars (map toSS pats) 242 template = unsafePrettyPrint (lambda oPats varBody) 243 244-- match a lambda with a variable pattern, with no guards and no where clauses 245lambdaExp _ o@(SimpleLambda [view -> PVar_ x] (L _ expr)) = 246 case expr of 247 -- suggest TupleSections instead of lambdas 248 ExplicitTuple _ args boxity 249 -- is there exactly one argument that is exactly x? 250 | ([_x], ys) <- partition ((==Just x) . tupArgVar) args 251 -- the other arguments must not have a nested x somewhere in them 252 , Set.notMember x $ Set.map occNameString $ freeVars ys 253 -> [(suggestN "Use tuple-section" o $ noLoc $ ExplicitTuple noExtField (map removeX args) boxity) 254 {ideaNote = [RequiresExtension "TupleSections"]}] 255 256 -- suggest @LambdaCase@/directly matching in a lambda instead of doing @\x -> case x of ...@ 257 HsCase _ (view -> Var_ x') matchGroup 258 -- is the case being done on the variable from our original lambda? 259 | x == x' 260 -- x must not be used in some other way inside the matches 261 , Set.notMember x $ Set.map occNameString $ free $ allVars matchGroup 262 -> case matchGroup of 263 -- is there a single match? - suggest match inside the lambda 264 -- 265 -- we need to 266 -- * add brackets to the match, because matches in lambdas require them 267 -- * mark match as being in a lambda context so that it's printed properly 268 oldMG@(MG _ (L _ [L _ oldmatch]) _) 269 | all (\(L _ (GRHS _ stmts _)) -> null stmts) (grhssGRHSs (m_grhss oldmatch)) -> 270 let patLocs = fmap getLoc (m_pats oldmatch) 271 bodyLocs = concatMap (\case L _ (GRHS _ _ body) -> [getLoc body]) 272 $ grhssGRHSs (m_grhss oldmatch) 273 r | notNull patLocs && notNull bodyLocs = 274 let xloc = foldl1' combineSrcSpans patLocs 275 yloc = foldl1' combineSrcSpans bodyLocs 276 in [ Replace Expr (toSS o) [("x", toRefactSrcSpan xloc), ("y", toRefactSrcSpan yloc)] 277 ((if needParens then "\\(x)" else "\\x") ++ " -> y") 278 ] 279 | otherwise = [] 280 needParens = any (patNeedsParens appPrec . unLoc) (m_pats oldmatch) 281 in [ suggest "Use lambda" o 282 ( noLoc $ HsLam noExtField oldMG 283 { mg_alts = noLoc 284 [ noLoc oldmatch 285 { m_pats = map mkParPat $ m_pats oldmatch 286 , m_ctxt = LambdaExpr 287 } 288 ] 289 } 290 :: LHsExpr GhcPs 291 ) 292 r 293 ] 294 295 -- otherwise we should use @LambdaCase@ 296 MG _ (L _ _) _ -> 297 [(suggestN "Use lambda-case" o $ noLoc $ HsLamCase noExtField matchGroup) 298 {ideaNote=[RequiresExtension "LambdaCase"]}] 299 _ -> [] 300 where 301 -- | Filter out tuple arguments, converting the @x@ (matched in the lambda) variable argument 302 -- to a missing argument, so that we get the proper section. 303 removeX :: LHsTupArg GhcPs -> LHsTupArg GhcPs 304 removeX (L _ (Present _ (view -> Var_ x'))) 305 | x == x' = noLoc $ Missing noExtField 306 removeX y = y 307 -- | Extract the name of an argument of a tuple if it's present and a variable. 308 tupArgVar :: LHsTupArg GhcPs -> Maybe String 309 tupArgVar (L _ (Present _ (view -> Var_ x))) = Just x 310 tupArgVar _ = Nothing 311 312lambdaExp _ _ = [] 313 314varBody :: LHsExpr GhcPs 315varBody = strToVar "body" 316 317-- | Squash lambdas and replace any repeated pattern variable with @_@ 318fromLambda :: LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs) 319fromLambda (SimpleLambda ps1 (fromLambda . fromParen -> (ps2,x))) = (transformBi (f $ pvars ps2) ps1 ++ ps2, x) 320 where f :: [String] -> Pat GhcPs -> Pat GhcPs 321 f bad (VarPat _ (rdrNameStr -> x)) 322 | x `elem` bad = WildPat noExtField 323 f bad x = x 324fromLambda x = ([], x) 325 326-- | For each pattern, if it does not contain wildcards, replace it with a variable pattern. 327-- 328-- The second component of the result is a list of substitution variables, which are guaranteed 329-- to not occur in the function name or patterns with wildcards. For example, given 330-- 'f (Foo a b _) = ...', 'f', 'a' and 'b' are not usable as substitution variables. 331mkOrigPats :: Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], [String]) 332mkOrigPats funName pats = (zipWith munge vars pats', vars) 333 where 334 (Set.unions -> used, pats') = unzip (map f pats) 335 336 -- Remove variables that occur in the function name or patterns with wildcards 337 vars = filter (\s -> s `Set.notMember` used && Just s /= funName) substVars 338 339 -- Returns (chars in the pattern if the pattern contains wildcards, (whether the pattern contains wildcards, the pattern)) 340 f :: LPat GhcPs -> (Set String, (Bool, LPat GhcPs)) 341 f p 342 | any isWildPat (universe p) = 343 let used = Set.fromList [rdrNameStr name | (L _ (VarPat _ name)) <- universe p] 344 in (used, (True, p)) 345 | otherwise = (mempty, (False, p)) 346 347 isWildPat :: LPat GhcPs -> Bool 348 isWildPat = \case (L _ (WildPat _)) -> True; _ -> False 349 350 -- Replace the pattern with a variable pattern if the pattern doesn't contain wildcards. 351 munge :: String -> (Bool, LPat GhcPs) -> LPat GhcPs 352 munge _ (True, p) = p 353 munge ident (False, L ploc _) = L ploc (VarPat noExtField (L ploc $ mkRdrUnqual $ mkVarOcc ident)) 354