{-# LANGUAGE ViewPatterns, PatternGuards #-}
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)
[
]]
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
t1 = template finalpats body
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)
lambdaExp :: Maybe Exp_ -> Exp_ -> [Idea]
lambdaExp p o@(Paren _ (App _ v@(Var l (UnQual _ (Symbol _ x))) y)) | isAtom y, not $ isTypeApp y, allowLeftSection x =
[suggestN "Use section" o (exp y x)]
where
exp op rhs = LeftSection an op (toNamed rhs)
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 _ _ = []
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)