{-# 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.Util.Brackets (isAtom')
import GHC.Util.FreeVars (free', allVars', freeVars', pvars', vars', varss')
import GHC.Util.HsExpr (allowLeftSection, allowRightSection, niceLambdaR', lambda)
import GHC.Util.RdrName (rdrNameStr')
import GHC.Util.View
import GHC.Hs
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr (isTypeApp, isOpApp, isLambda, isQuasiQuote, isVar, isDol, strToVar)
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import OccName
import RdrName
import SrcLoc
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]))