{-# LANGUAGE ViewPatterns, PatternGuards #-} {- Concept: Remove all the lambdas you can be inserting only sections Never create a right section with +-# as the operator (they are misparsed) Rules: fun a = \x -> y -- promote lambdas, provided no where's outside the lambda fun x = y x -- eta reduce, x /= mr and foo /= symbol \x -> y x -- eta reduce ((#) x) ==> (x #) -- rotate operators (flip op x) ==> (`op` x) -- rotate operators \x y -> x + y ==> (+) -- insert operator \x y -> op y x ==> flip op \x -> x + y ==> (+ y) -- insert section, \x -> op x y ==> (`op` y) -- insert section \x -> y + x ==> (y +) -- insert section \x -> \y -> ... ==> \x y -- lambda compression \x -> (x +) ==> (+) -- operator reduction f a = \x -> x + x -- f a x = x + x f a = \a -> a + a -- f _ a = a + a f a = \x -> x + x where _ = test f (test -> a) = \x -> x + x f = \x -> x + x -- f x = x + x fun x y z = f x y z -- fun = f fun x y z = f x x y z -- fun x = f x x fun x y z = f g z -- fun x y = f g fun mr = y mr fun x = f . g \$ x -- fun = f . g f = foo (\y -> g x . h \$ y) -- g x . h f = foo (\y -> g x . h \$ y) -- @Message Avoid lambda f = foo ((*) x) -- (x *) f = (*) x f = foo (flip op x) -- (`op` x) f = foo (flip op x) -- @Message Use section foo x = bar (\ d -> search d table) -- (`search` table) foo x = bar (\ d -> search d table) -- @Message Avoid lambda using `infix` f = flip op x f = foo (flip (*) x) -- (* x) f = foo (flip (-) x) f = foo (\x y -> fun x y) -- @Warning fun f = foo (\x y -> x + y) -- (+) f = foo (\x -> x * y) -- @Suggestion (* y) f = foo (\x -> x # y) f = foo (\x -> \y -> x x y y) -- \x y -> x x y y f = foo (\x -> \x -> foo x x) -- \_ x -> foo x x f = foo (\(foo -> x) -> \y -> x x y y) f = foo (\(x:xs) -> \x -> foo x x) -- \(_:xs) x -> foo x x f = foo (\x -> \y -> \z -> x x y y z z) -- \x y z -> x x y y z z x ! y = fromJust \$ lookup x y f = foo (\i -> writeIdea (getClass i) i) f = bar (flip Foo.bar x) -- (`Foo.bar` x) f = a b (\x -> c x d) -- (`c` d) yes = \x -> a x where -- a yes = \x y -> op y x where -- flip op f = \y -> nub \$ reverse y where -- nub . reverse f = \z -> foo \$ bar \$ baz z where -- foo . bar . baz f = \z -> foo \$ bar x \$ baz z where -- foo . bar x . baz f = \z -> foo \$ z \$ baz z where f = \x -> bar map (filter x) where -- bar map . filter f = bar &+& \x -> f (g x) foo = [\column -> set column [treeViewColumnTitle := printf "%s (match %d)" name (length candidnates)]] foo = [\x -> x] foo = [\m x -> insert x x m] foo a b c = bar (flux ++ quux) c where flux = a -- foo a b = bar (flux ++ quux) foo a b c = bar (flux ++ quux) c where flux = c yes = foo (\x -> Just x) -- @Warning Just foo = bar (\x -> (x `f`)) -- f baz = bar (\x -> (x +)) -- (+) yes = blah (\ x -> case x of A -> a; B -> b) -- \ case A -> a; B -> b no = blah (\ x -> case x of A -> a x; B -> b x) yes = blah (\ x -> (y, x, z+q)) -- (y, , z+q) yes = blah (\ x -> (y, x, z+x)) tmp = map (\ x -> runST \$ action x) {-# LANGUAGE QuasiQuotes #-}; authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name {-# LANGUAGE QuasiQuotes #-}; authOAuth2 = foo (\name -> authOAuth2Widget [whamlet|Login via #{name}|] name) -} module Hint.Lambda(lambdaHint) where import Hint.Util import Hint.Type import Util import Data.List.Extra import Data.Maybe import qualified Data.Set as Set import Refact.Types hiding (RType(Match)) lambdaHint :: DeclHint lambdaHint _ _ x = concatMap (uncurry lambdaExp) (universeParentBi x) ++ concatMap lambdaDecl (universe x) lambdaDecl :: Decl_ -> [Idea] lambdaDecl (toFunBind -> o@(FunBind loc1 [Match _ name pats (UnGuardedRhs loc2 bod) bind])) | isNothing bind, isLambda \$ fromParen bod, null (universeBi pats :: [Exp_]) = [warn "Redundant lambda" o (gen pats bod) [Replace Decl (toSS o) s1 t1]] | length pats2 < length pats, pvars (drop (length pats2) pats) `disjoint` varss bind = [warn "Eta reduce" (reform pats bod) (reform pats2 bod2) [ -- Disabled, see apply-refact #3 -- Replace Decl (toSS \$ reform pats bod) s2 t2]] ]] where reform p b = FunBind loc [Match an name p (UnGuardedRhs an b) Nothing] loc = setSpanInfoEnd loc1 \$ srcSpanEnd \$ srcInfoSpan loc2 gen ps = uncurry reform . fromLambda . Lambda an ps (finalpats, body) = fromLambda . Lambda an pats \$ bod (pats2, bod2) = etaReduce pats bod template fps b = prettyPrint \$ reform (zipWith munge ['a'..'z'] fps) (toNamed "body") munge :: Char -> Pat_ -> Pat_ munge ident p@(PWildCard _) = p munge ident p = PVar (ann p) (Ident (ann p) [ident]) subts fps b = ("body", toSS b) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS fps) s1 = subts finalpats body --s2 = subts pats2 bod2 t1 = template finalpats body --t2 = template pats2 bod2 lambdaDecl _ = [] setSpanInfoEnd ssi (line, col) = ssi{srcInfoSpan = (srcInfoSpan ssi){srcSpanEndLine=line, srcSpanEndColumn=col}} etaReduce :: [Pat_] -> Exp_ -> ([Pat_], Exp_) etaReduce ps (App _ x (Var _ (UnQual _ (Ident _ y)))) | ps /= [], PVar _ (Ident _ p) <- last ps, p == y, p /= "mr", y `notElem` vars x , not \$ any isQuasiQuote \$ universe x = etaReduce (init ps) x etaReduce ps (InfixApp a x (isDol -> True) y) = etaReduce ps (App a x y) etaReduce ps x = (ps,x) --Section refactoring is not currently implemented. lambdaExp :: Maybe Exp_ -> Exp_ -> [Idea] lambdaExp p o@(Paren _ (App _ v@(Var l (UnQual _ (Symbol _ x))) y)) | isAtom y, allowLeftSection x = [suggestN "Use section" o (exp y x)] -- [Replace Expr (toSS o) subts template]] where exp op rhs = LeftSection an op (toNamed rhs) -- template = prettyPrint (exp (toNamed "a") "*") -- subts = [("a", toSS y), ("*", toSS v)] lambdaExp p o@(Paren _ (App _ (App _ (view -> Var_ "flip") (Var _ x)) y)) | allowRightSection \$ fromNamed x = [suggestN "Use section" o \$ RightSection an (QVarOp an x) y] lambdaExp p o@Lambda{} | maybe True (not . isInfixApp) p, (res, refact) <- niceLambdaR [] o , not \$ isLambda res, not \$ any isQuasiQuote \$ universe res, not \$ "runST" `Set.member` freeVars o , let name = "Avoid lambda" ++ (if countInfixNames res > countInfixNames o then " using `infix`" else "") = [(if isVar res || isCon res then warn else suggest) name o res (refact \$ toSS o)] where countInfixNames x = length [() | RightSection _ (QVarOp _ (UnQual _ (Ident _ _))) _ <- universe x] lambdaExp p o@(Lambda _ pats x) | isLambda (fromParen x), null (universeBi pats :: [Exp_]), maybe True (not . isLambda) p = [suggest "Collapse lambdas" o (Lambda an pats body) [Replace Expr (toSS o) subts template]] where (pats, body) = fromLambda o template = prettyPrint \$ Lambda an (zipWith munge ['a'..'z'] pats) (toNamed "body") munge :: Char -> Pat_ -> Pat_ munge ident p@(PWildCard _) = p munge ident p = PVar (ann p) (Ident (ann p) [ident]) subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS pats) lambdaExp p o@(Lambda _ [view -> PVar_ u] (Case _ (view -> Var_ v) alts)) | u == v, u `notElem` vars alts = [(suggestN "Use lambda-case" o \$ LCase an alts){ideaNote=[RequiresExtension "LambdaCase"]}] lambdaExp p o@(Lambda _ [view -> PVar_ u] (Tuple _ boxed xs)) | ([yes],no) <- partition (~= u) xs, u `notElem` concatMap vars no = [(suggestN "Use tuple-section" o \$ TupleSection an boxed [if x ~= u then Nothing else Just x | x <- xs]) {ideaNote=[RequiresExtension "TupleSections"]}] lambdaExp _ _ = [] -- replace any repeated pattern variable with _ fromLambda :: Exp_ -> ([Pat_], Exp_) fromLambda (Lambda _ ps1 (fromLambda . fromParen -> (ps2,x))) = (transformBi (f \$ pvars ps2) ps1 ++ ps2, x) where f bad x@PVar{} | prettyPrint x `elem` bad = PWildCard an f bad x = x fromLambda x = ([], x)