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