{-# LANGUAGE ViewPatterns, PatternGuards #-}
module Hint.Lambda(lambdaHint) where
import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, suggestN, ideaNote)
import Util
import Data.List.Extra
import qualified Data.Set as Set
import Refact.Types hiding (RType(Match))
import Data.Generics.Uniplate.Operations (universe, universeBi, transformBi)
import BasicTypes
import GHC.Hs
import OccName
import RdrName
import SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr (isTypeApp, isOpApp, isLambda, isQuasiQuote, isVar, isDol, strToVar)
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import GHC.Util.Brackets (isAtom)
import GHC.Util.FreeVars (free, allVars, freeVars, pvars, vars, varss)
import GHC.Util.HsExpr (allowLeftSection, allowRightSection, niceLambdaR, lambda)
import GHC.Util.View
lambdaHint :: DeclHint
lambdaHint _ _ x
= concatMap (uncurry lambdaExp) (universeParentBi x)
++ concatMap lambdaDecl (universe x)
lambdaDecl :: LHsDecl GhcPs -> [Idea]
lambdaDecl
o@(L _ (ValD _
origBind@FunBind {fun_id = L loc1 _, fun_matches =
MG {mg_alts =
L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _) pats (GRHSs _ [L _ (GRHS _ [] origBody@(L loc2 _))] bind))]}}))
| L _ (EmptyLocalBinds noExtField) <- bind
, isLambda $ fromParen origBody
, null (universeBi pats :: [HsExpr GhcPs])
= [warn "Redundant lambda" o (gen pats origBody) [Replace Decl (toSS o) s1 t1]]
| length pats2 < length pats, pvars (drop (length pats2) pats) `disjoint` varss bind
= [warn "Eta reduce" (reform pats origBody) (reform pats2 bod2)
[
]]
where reform :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
reform ps b = L loc $ ValD noExtField $
origBind
{fun_matches = MG noExtField (noLoc [noLoc $ Match noExtField ctxt ps $ GRHSs noExtField [noLoc $ GRHS noExtField [] b] $ noLoc $ EmptyLocalBinds noExtField]) Generated}
loc = combineSrcSpans loc1 loc2
gen :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
gen ps = uncurry reform . fromLambda . lambda ps
(finalpats, body) = fromLambda . lambda pats $ origBody
(pats2, bod2) = etaReduce pats origBody
template fps = unsafePrettyPrint $ reform (zipWith munge ['a'..'z'] fps) varBody
subts fps b = ("body", toSS b) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS fps)
s1 = subts finalpats body
t1 = template finalpats
lambdaDecl _ = []
etaReduce :: [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce (unsnoc -> Just (ps, view -> PVar_ p)) (L _ (HsApp _ x (view -> Var_ y)))
| p == y
, y `notElem` vars x
, not $ any isQuasiQuote $ universe x
= etaReduce ps x
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 _ (L _ (rdrNameOcc -> f)))) y))))
| isSymOcc f
, isAtom y
, allowLeftSection $ occNameString f
, not $ isTypeApp y =
[suggestN "Use section" o $ noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField y oper]
lambdaExp _ o@(L _ (HsPar _ (view -> App2 (view -> Var_ "flip") origf@(view -> Var_ f) y)))
| allowRightSection f, not $ "(" `isPrefixOf` f
= [suggestN "Use section" o $ noLoc $ HsPar noExtField $ noLoc $ SectionR noExtField origf y]
lambdaExp p o@(L _ HsLam{})
| not $ any isOpApp p
, (res, refact) <- niceLambdaR [] o
, not $ isLambda res
, not $ any isQuasiQuote $ universe res
, not $ "runST" `Set.member` Set.map occNameString (freeVars o)
, let name = "Avoid lambda" ++ (if countRightSections res > countRightSections o then " using `infix`" else "")
= [(if isVar res then warn else suggest) name o res (refact $ toSS o)]
where
countRightSections :: LHsExpr GhcPs -> Int
countRightSections x = length [() | L _ (SectionR _ (view -> Var_ _) _) <- universe x]
lambdaExp p o@(SimpleLambda origPats origBody)
| isLambda (fromParen origBody)
, null (universeBi origPats :: [HsExpr GhcPs])
, maybe True (not . isLambda) p =
[suggest "Collapse lambdas" o (lambda pats body) [Replace Expr (toSS o) subts template]]
where
(pats, body) = fromLambda o
template = unsafePrettyPrint $ lambda (zipWith munge ['a'..'z'] pats) varBody
subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS pats)
lambdaExp _ o@(SimpleLambda [view -> PVar_ x] (L _ expr)) =
case expr of
ExplicitTuple _ args boxity
| ([_x], ys) <- partition ((==Just x) . tupArgVar) args
, Set.notMember x $ Set.map occNameString $ freeVars ys
-> [(suggestN "Use tuple-section" o $ noLoc $ ExplicitTuple noExtField (map removeX args) boxity)
{ideaNote = [RequiresExtension "TupleSections"]}]
HsCase _ (view -> Var_ x') matchGroup
| x == x'
, Set.notMember x $ Set.map occNameString $ free $ allVars matchGroup
-> case matchGroup of
oldMG@(MG _ (L _ [L _ oldmatch]) _) ->
[suggestN "Use lambda" o $ noLoc $ HsLam noExtField oldMG
{ mg_alts = noLoc
[noLoc oldmatch
{ m_pats = map mkParPat $ m_pats oldmatch
, m_ctxt = LambdaExpr
}
] }
]
MG _ (L _ xs) _ ->
[(suggestN "Use lambda-case" o $ noLoc $ HsLamCase noExtField matchGroup)
{ideaNote=[RequiresExtension "LambdaCase"]}]
_ -> []
_ -> []
where
removeX :: LHsTupArg GhcPs -> LHsTupArg GhcPs
removeX arg@(L _ (Present _ (view -> Var_ x')))
| x == x' = noLoc $ Missing noExtField
removeX y = y
tupArgVar :: LHsTupArg GhcPs -> Maybe String
tupArgVar (L _ (Present _ (view -> Var_ x))) = Just x
tupArgVar _ = Nothing
lambdaExp _ _ = []
varBody :: LHsExpr GhcPs
varBody = strToVar "body"
fromLambda :: LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
fromLambda (SimpleLambda ps1 (fromLambda . fromParen -> (ps2,x))) = (transformBi (f $ pvars ps2) ps1 ++ ps2, x)
where f :: [String] -> Pat GhcPs -> Pat GhcPs
f bad (VarPat _ (rdrNameStr -> x))
| x `elem` bad = WildPat noExtField
f bad x = x
fromLambda x = ([], x)
munge :: Char -> LPat GhcPs -> LPat GhcPs
munge ident p@(L _ (WildPat _)) = p
munge ident (L ploc p) = L ploc (VarPat noExtField (L ploc $ mkRdrUnqual $ mkVarOcc [ident]))