{-# LANGUAGE LambdaCase, PatternGuards, ViewPatterns #-}

{-
    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 ==> y -- 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

<TEST>
f a = \x -> x + x -- f a x = x + x
f a = \a -> a + a -- f _ a = a + a
a = \x -> x + x -- a x = x + x
f (Just a) = \a -> a + a -- f (Just _) a = a + a
f (Foo a b c) = \c -> c + c -- f (Foo a b _) c = c + c
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 @NoRefactor: refactoring for eta reduce is not implemented
fun x y z = f x x y z -- fun x = f x x @NoRefactor
fun x y z = f g z -- fun x y = f g @NoRefactor
fun x = f . g $ x -- fun = f . g @NoRefactor
f = foo (\y -> g x . h $ y) -- g x . h
f = foo (\y -> g x . h $ y) -- @Message Avoid lambda
f = foo ((*) x) -- (x *) @NoRefactor
f = (*) x
f = foo (flip op x) -- (`op` x) @NoRefactor
f = foo (flip op x) -- @Message Use section @NoRefactor
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) @NoRefactor
f = foo (flip (-) x)
f = foo (\x y -> fun x y) -- @Warning fun
f = foo (\x y z -> fun x y z) -- @Warning fun
f = foo (\z -> f x $ z) -- f x
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 @NoRefactor
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) @NoRefactor
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) @NoRefactor
foo a b c = bar (flux ++ quux) c where flux = c
yes = foo (\x -> Just x) -- @Warning Just
foo = bar (\x -> (x `f`)) -- f
foo = bar (\x -> shakeRoot </> "src" </> x)
baz = bar (\x -> (x +)) -- (+) @NoRefactor
xs `withArgsFrom` args = f args
foo = bar (\x -> case x of Y z -> z) -- \(Y z) -> z @NoRefactor
yes = blah (\ x -> case x of A -> a; B -> b) -- \ case A -> a; B -> b @NoRefactor
yes = blah (\ x -> case x of A -> a; B -> b) -- @Note may require `{-# LANGUAGE LambdaCase #-}` adding to the top of the file @NoRefactor
no = blah (\ x -> case x of A -> a x; B -> b x)
yes = blah (\ x -> (y, x)) -- (y,) @NoRefactor
yes = blah (\ x -> (y, x, z+q)) -- (y, , z+q) @NoRefactor
yes = blah (\ x -> (y, x, y, u, v)) -- (y, , y, u, v) @NoRefactor
yes = blah (\ x -> (y, x, z+q)) -- @Note may require `{-# LANGUAGE TupleSections #-}` adding to the top of the file @NoRefactor
yes = blah (\ x -> (y, x, z+x))
tmp = map (\ x -> runST $ action x)
yes = map (\f -> dataDir </> f) dataFiles -- (dataDir </>)
{-# LANGUAGE TypeApplications #-}; noBug545 = coerce ((<>) @[a])
{-# LANGUAGE QuasiQuotes #-}; authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name
{-# LANGUAGE QuasiQuotes #-}; authOAuth2 = foo (\name -> authOAuth2Widget [whamlet|Login via #{name}|] name)
f = {- generates a hint using hlint.yaml only -} map (flip (,) "a") "123"
f = {- generates a hint using hlint.yaml only -} map ((,) "a") "123"
f = map (\s -> MkFoo s 0 s) ["a","b","c"]
</TEST>
-}


module Hint.Lambda(lambdaHint) where

import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, suggestN, ideaNote)
import Util
import Data.List.Extra
import Data.Set (Set)
import qualified Data.Set as Set
import Refact.Types hiding (RType(Match))
import Data.Generics.Uniplate.DataOnly (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 :: DeclHint
lambdaHint Scope
_ ModuleEx
_ LHsDecl GhcPs
x
    =  ((Maybe (LHsExpr GhcPs), LHsExpr GhcPs) -> [Idea])
-> [(Maybe (LHsExpr GhcPs), LHsExpr GhcPs)] -> [Idea]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea])
-> (Maybe (LHsExpr GhcPs), LHsExpr GhcPs) -> [Idea]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
lambdaExp) (LHsDecl GhcPs -> [(Maybe (LHsExpr GhcPs), LHsExpr GhcPs)]
forall a b. (Data a, Data b) => a -> [(Maybe b, b)]
universeParentBi LHsDecl GhcPs
x)
    [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++ (LHsDecl GhcPs -> [Idea]) -> [LHsDecl GhcPs] -> [Idea]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LHsDecl GhcPs -> [Idea]
lambdaDecl (LHsDecl GhcPs -> [LHsDecl GhcPs]
forall on. Uniplate on => on -> [on]
universe LHsDecl GhcPs
x)

lambdaDecl :: LHsDecl GhcPs -> [Idea]
lambdaDecl :: LHsDecl GhcPs -> [Idea]
lambdaDecl
    o :: LHsDecl GhcPs
o@(L SrcSpan
_ (ValD XValD GhcPs
_
        origBind :: HsBind GhcPs
origBind@FunBind {fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = funName :: Located (IdP GhcPs)
funName@(L SrcSpan
loc1 IdP GhcPs
_), fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches =
            MG {mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts =
                L SrcSpan
_ [L SrcSpan
_ (Match XCMatch GhcPs (LHsExpr GhcPs)
_ ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs))
ctxt@(FunRhs Located (NameOrRdrName (IdP GhcPs))
_ LexicalFixity
Prefix SrcStrictness
_) [LPat GhcPs]
pats (GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
_ [L SrcSpan
_ (GRHS XCGRHS GhcPs (LHsExpr GhcPs)
_ [] origBody :: LHsExpr GhcPs
origBody@(L SrcSpan
loc2 HsExpr GhcPs
_))] LHsLocalBinds GhcPs
bind))]}}))
    | L SrcSpan
_ (EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
noExtField) <- LHsLocalBinds GhcPs
bind
    , LHsExpr GhcPs -> Bool
isLambda (LHsExpr GhcPs -> Bool) -> LHsExpr GhcPs -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
fromParen LHsExpr GhcPs
origBody
    , [HsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Located (Pat GhcPs)] -> [HsExpr GhcPs]
forall from to. Biplate from to => from -> [to]
universeBi [LPat GhcPs]
[Located (Pat GhcPs)]
pats :: [HsExpr GhcPs])
    = [String
-> LHsDecl GhcPs -> LHsDecl GhcPs -> [Refactoring SrcSpan] -> Idea
forall a b.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
String -> a -> b -> [Refactoring SrcSpan] -> Idea
warn String
"Redundant lambda" LHsDecl GhcPs
o ([LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
gen [LPat GhcPs]
pats LHsExpr GhcPs
origBody) [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Decl (LHsDecl GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSS LHsDecl GhcPs
o) [(String, SrcSpan)]
subts String
template]]
    | [Located (Pat GhcPs)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Located (Pat GhcPs)]
pats2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Located (Pat GhcPs)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LPat GhcPs]
[Located (Pat GhcPs)]
pats, [Located (Pat GhcPs)] -> [String]
forall a. AllVars a => a -> [String]
pvars (Int -> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a. Int -> [a] -> [a]
drop ([Located (Pat GhcPs)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Located (Pat GhcPs)]
pats2) [LPat GhcPs]
[Located (Pat GhcPs)]
pats) [String] -> [String] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`disjoint` LHsLocalBinds GhcPs -> [String]
forall a. AllVars a => a -> [String]
varss LHsLocalBinds GhcPs
bind
    = [String
-> LHsDecl GhcPs -> LHsDecl GhcPs -> [Refactoring SrcSpan] -> Idea
forall a b.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
String -> a -> b -> [Refactoring SrcSpan] -> Idea
warn String
"Eta reduce" ([LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
reform [LPat GhcPs]
pats LHsExpr GhcPs
origBody) ([LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
reform [LPat GhcPs]
[Located (Pat GhcPs)]
pats2 LHsExpr GhcPs
bod2)
          [ -- Disabled, see apply-refact #3
          ]
      ]
    where reform :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
          reform :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
reform [LPat GhcPs]
ps LHsExpr GhcPs
b = SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsDecl GhcPs -> LHsDecl GhcPs) -> HsDecl GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
ValD NoExtField
XValD GhcPs
noExtField (HsBind GhcPs -> HsDecl GhcPs) -> HsBind GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$
            HsBind GhcPs
origBind
              {fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches = XMG GhcPs (LHsExpr GhcPs)
-> GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
-> Origin
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG NoExtField
XMG GhcPs (LHsExpr GhcPs)
noExtField (SrcSpanLess (GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)])
-> GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> LMatch GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
 -> LMatch GhcPs (LHsExpr GhcPs))
-> SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> LMatch GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XCMatch GhcPs (LHsExpr GhcPs)
-> HsMatchContext (NameOrRdrName (IdP GhcPs))
-> [LPat GhcPs]
-> GRHSs GhcPs (LHsExpr GhcPs)
-> Match GhcPs (LHsExpr GhcPs)
forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noExtField HsMatchContext (NameOrRdrName (IdP GhcPs))
ctxt [LPat GhcPs]
ps (GRHSs GhcPs (LHsExpr GhcPs) -> Match GhcPs (LHsExpr GhcPs))
-> GRHSs GhcPs (LHsExpr GhcPs) -> Match GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XCGRHSs GhcPs (LHsExpr GhcPs)
-> [LGRHS GhcPs (LHsExpr GhcPs)]
-> LHsLocalBinds GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs NoExtField
XCGRHSs GhcPs (LHsExpr GhcPs)
noExtField [SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
-> LGRHS GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
 -> LGRHS GhcPs (LHsExpr GhcPs))
-> SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
-> LGRHS GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcPs (LHsExpr GhcPs)
-> [GuardLStmt GhcPs]
-> LHsExpr GhcPs
-> GRHS GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS NoExtField
XCGRHS GhcPs (LHsExpr GhcPs)
noExtField [] LHsExpr GhcPs
b] (LHsLocalBinds GhcPs -> GRHSs GhcPs (LHsExpr GhcPs))
-> LHsLocalBinds GhcPs -> GRHSs GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsLocalBinds GhcPs) -> LHsLocalBinds GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsLocalBinds GhcPs) -> LHsLocalBinds GhcPs)
-> SrcSpanLess (LHsLocalBinds GhcPs) -> LHsLocalBinds GhcPs
forall a b. (a -> b) -> a -> b
$ XEmptyLocalBinds GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds NoExtField
XEmptyLocalBinds GhcPs GhcPs
noExtField]) Origin
Generated}

          loc :: SrcSpan
loc = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
loc1 SrcSpan
loc2

          gen :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
          gen :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
gen [LPat GhcPs]
ps = ([Located (Pat GhcPs)] -> LHsExpr GhcPs -> LHsDecl GhcPs)
-> ([Located (Pat GhcPs)], LHsExpr GhcPs) -> LHsDecl GhcPs
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
[Located (Pat GhcPs)] -> LHsExpr GhcPs -> LHsDecl GhcPs
reform (([Located (Pat GhcPs)], LHsExpr GhcPs) -> LHsDecl GhcPs)
-> (LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs))
-> LHsExpr GhcPs
-> LHsDecl GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs)
fromLambda (LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs))
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs
-> ([Located (Pat GhcPs)], LHsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [LPat GhcPs]
ps

          ([Located (Pat GhcPs)]
finalpats, LHsExpr GhcPs
body) = LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs)
fromLambda (LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs))
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs
-> ([Located (Pat GhcPs)], LHsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [LPat GhcPs]
pats (LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs))
-> LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs
origBody
          ([Located (Pat GhcPs)]
pats2, LHsExpr GhcPs
bod2) = [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce [LPat GhcPs]
pats LHsExpr GhcPs
origBody
          ([Located (Pat GhcPs)]
origPats, String
subtsVars) = Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], String)
mkOrigPats (String -> Maybe String
forall a. a -> Maybe a
Just (Located RdrName -> String
rdrNameStr Located (IdP GhcPs)
Located RdrName
funName)) [LPat GhcPs]
[Located (Pat GhcPs)]
finalpats
          subts :: [(String, SrcSpan)]
subts = (String
"body", LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSS LHsExpr GhcPs
body) (String, SrcSpan) -> [(String, SrcSpan)] -> [(String, SrcSpan)]
forall a. a -> [a] -> [a]
: (Char -> SrcSpan -> (String, SrcSpan))
-> String -> [SrcSpan] -> [(String, SrcSpan)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Char
x SrcSpan
y -> ([Char
x],SrcSpan
y)) String
subtsVars ((Located (Pat GhcPs) -> SrcSpan)
-> [Located (Pat GhcPs)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map Located (Pat GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSS [Located (Pat GhcPs)]
finalpats)
          template :: String
template = LHsDecl GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint ([LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
reform [LPat GhcPs]
[Located (Pat GhcPs)]
origPats LHsExpr GhcPs
varBody)
lambdaDecl LHsDecl GhcPs
_ = []


etaReduce :: [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce :: [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce ([LPat GhcPs] -> Maybe ([Located (Pat GhcPs)], Located (Pat GhcPs))
forall a. [a] -> Maybe ([a], a)
unsnoc -> Just ([Located (Pat GhcPs)]
ps, Located (Pat GhcPs) -> PVar_
forall a b. View a b => a -> b
view -> PVar_ String
p)) (L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
x (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
y)))
    | String
p String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y
    , String
y String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` LHsExpr GhcPs -> [String]
forall a. FreeVars a => a -> [String]
vars LHsExpr GhcPs
x
    , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (LHsExpr GhcPs -> Bool) -> [LHsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LHsExpr GhcPs -> Bool
isQuasiQuote ([LHsExpr GhcPs] -> Bool) -> [LHsExpr GhcPs] -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LHsExpr GhcPs]
forall on. Uniplate on => on -> [on]
universe LHsExpr GhcPs
x
    = [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce [LPat GhcPs]
[Located (Pat GhcPs)]
ps LHsExpr GhcPs
x
etaReduce [LPat GhcPs]
ps (L SrcSpan
loc (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
x (LHsExpr GhcPs -> Bool
isDol -> Bool
True) LHsExpr GhcPs
y)) = [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce [LPat GhcPs]
ps (SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExtField
XApp GhcPs
noExtField LHsExpr GhcPs
x LHsExpr GhcPs
y))
etaReduce [LPat GhcPs]
ps LHsExpr GhcPs
x = ([LPat GhcPs]
ps, LHsExpr GhcPs
x)

--Section refactoring is not currently implemented.
lambdaExp :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
lambdaExp :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
lambdaExp Maybe (LHsExpr GhcPs)
_ o :: LHsExpr GhcPs
o@(L SrcSpan
_ (HsPar XPar GhcPs
_ (L SrcSpan
_ (HsApp XApp GhcPs
_ oper :: LHsExpr GhcPs
oper@(L SrcSpan
_ (HsVar XVar GhcPs
_ (L SrcSpan
_ (IdP GhcPs -> OccName
RdrName -> OccName
rdrNameOcc -> OccName
f)))) LHsExpr GhcPs
y))))
    | OccName -> Bool
isSymOcc OccName
f -- is this an operator?
    , LHsExpr GhcPs -> Bool
forall a. Brackets a => a -> Bool
isAtom LHsExpr GhcPs
y
    , String -> Bool
allowLeftSection (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString OccName
f
    , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Bool
isTypeApp LHsExpr GhcPs
y =
      [String -> LHsExpr GhcPs -> LHsExpr GhcPs -> Idea
forall a. (HasSrcSpan a, Outputable a) => String -> a -> a -> Idea
suggestN String
"Use section" LHsExpr GhcPs
o (LHsExpr GhcPs -> Idea) -> LHsExpr GhcPs -> Idea
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExtField
XPar GhcPs
noExtField (LHsExpr GhcPs -> HsExpr GhcPs) -> LHsExpr GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XSectionL GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL NoExtField
XSectionL GhcPs
noExtField LHsExpr GhcPs
y LHsExpr GhcPs
oper]

lambdaExp Maybe (LHsExpr GhcPs)
_ o :: LHsExpr GhcPs
o@(L SrcSpan
_ (HsPar XPar GhcPs
_ (LHsExpr GhcPs -> App2
forall a b. View a b => a -> b
view -> App2 (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
"flip") origf :: LHsExpr GhcPs
origf@(LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
f) LHsExpr GhcPs
y)))
    | String -> Bool
allowRightSection String
f, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String
"(" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
f
    = [String -> LHsExpr GhcPs -> LHsExpr GhcPs -> Idea
forall a. (HasSrcSpan a, Outputable a) => String -> a -> a -> Idea
suggestN String
"Use section" LHsExpr GhcPs
o (LHsExpr GhcPs -> Idea) -> LHsExpr GhcPs -> Idea
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExtField
XPar GhcPs
noExtField (LHsExpr GhcPs -> HsExpr GhcPs) -> LHsExpr GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XSectionR GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR NoExtField
XSectionR GhcPs
noExtField LHsExpr GhcPs
origf LHsExpr GhcPs
y]
lambdaExp Maybe (LHsExpr GhcPs)
p o :: LHsExpr GhcPs
o@(L SrcSpan
_ HsLam{})
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (LHsExpr GhcPs -> Bool) -> Maybe (LHsExpr GhcPs) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LHsExpr GhcPs -> Bool
isOpApp Maybe (LHsExpr GhcPs)
p
    , (LHsExpr GhcPs
res, SrcSpan -> [Refactoring SrcSpan]
refact) <- [String]
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, SrcSpan -> [Refactoring SrcSpan])
niceLambdaR [] LHsExpr GhcPs
o
    , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Bool
isLambda LHsExpr GhcPs
res
    , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (LHsExpr GhcPs -> Bool) -> [LHsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LHsExpr GhcPs -> Bool
isQuasiQuote ([LHsExpr GhcPs] -> Bool) -> [LHsExpr GhcPs] -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LHsExpr GhcPs]
forall on. Uniplate on => on -> [on]
universe LHsExpr GhcPs
res
    , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String
"runST" String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` (OccName -> String) -> Set OccName -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map OccName -> String
occNameString (LHsExpr GhcPs -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars LHsExpr GhcPs
o)
    , let name :: String
name = String
"Avoid lambda" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if LHsExpr GhcPs -> Int
countRightSections LHsExpr GhcPs
res Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> LHsExpr GhcPs -> Int
countRightSections LHsExpr GhcPs
o then String
" using `infix`" else String
"")
    -- If the lambda's parent is an HsPar, and the result is also an HsPar, the span should include the parentheses.
    , let from :: LHsExpr GhcPs
from = case (Maybe (LHsExpr GhcPs)
p, LHsExpr GhcPs
res) of
              (Just p :: LHsExpr GhcPs
p@(L SrcSpan
_ (HsPar XPar GhcPs
_ (L SrcSpan
_ HsLam{}))), L SrcSpan
_ HsPar{}) -> LHsExpr GhcPs
p
              (Maybe (LHsExpr GhcPs), LHsExpr GhcPs)
_ -> LHsExpr GhcPs
o
    = [(if LHsExpr GhcPs -> Bool
isVar LHsExpr GhcPs
res then String
-> LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring SrcSpan] -> Idea
forall a b.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
String -> a -> b -> [Refactoring SrcSpan] -> Idea
warn else String
-> LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring SrcSpan] -> Idea
forall a b.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
String -> a -> b -> [Refactoring SrcSpan] -> Idea
suggest) String
name LHsExpr GhcPs
from LHsExpr GhcPs
res (SrcSpan -> [Refactoring SrcSpan]
refact (SrcSpan -> [Refactoring SrcSpan])
-> SrcSpan -> [Refactoring SrcSpan]
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSS LHsExpr GhcPs
from)]
    where
        countRightSections :: LHsExpr GhcPs -> Int
        countRightSections :: LHsExpr GhcPs -> Int
countRightSections LHsExpr GhcPs
x = [()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | L SrcSpan
_ (SectionR XSectionR GhcPs
_ (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
_) LHsExpr GhcPs
_) <- LHsExpr GhcPs -> [LHsExpr GhcPs]
forall on. Uniplate on => on -> [on]
universe LHsExpr GhcPs
x]

lambdaExp Maybe (LHsExpr GhcPs)
p o :: LHsExpr GhcPs
o@(SimpleLambda [LPat GhcPs]
origPats LHsExpr GhcPs
origBody)
    | LHsExpr GhcPs -> Bool
isLambda (LHsExpr GhcPs -> LHsExpr GhcPs
fromParen LHsExpr GhcPs
origBody)
    , [HsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Located (Pat GhcPs)] -> [HsExpr GhcPs]
forall from to. Biplate from to => from -> [to]
universeBi [LPat GhcPs]
[Located (Pat GhcPs)]
origPats :: [HsExpr GhcPs]) -- TODO: I think this checks for view patterns only, so maybe be more explicit about that?
    , Bool -> (LHsExpr GhcPs -> Bool) -> Maybe (LHsExpr GhcPs) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not (Bool -> Bool) -> (LHsExpr GhcPs -> Bool) -> LHsExpr GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> Bool
isLambda) Maybe (LHsExpr GhcPs)
p =
    [String
-> LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring SrcSpan] -> Idea
forall a b.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
String -> a -> b -> [Refactoring SrcSpan] -> Idea
suggest String
"Collapse lambdas" LHsExpr GhcPs
o ([LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [LPat GhcPs]
[Located (Pat GhcPs)]
pats LHsExpr GhcPs
body) [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr (LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSS LHsExpr GhcPs
o) [(String, SrcSpan)]
subts String
template]]
    where
      ([Located (Pat GhcPs)]
pats, LHsExpr GhcPs
body) = LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
fromLambda LHsExpr GhcPs
o
      ([Located (Pat GhcPs)]
oPats, String
subtsVars) = Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], String)
mkOrigPats Maybe String
forall a. Maybe a
Nothing [LPat GhcPs]
[Located (Pat GhcPs)]
pats
      subts :: [(String, SrcSpan)]
subts = (String
"body", LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSS LHsExpr GhcPs
body) (String, SrcSpan) -> [(String, SrcSpan)] -> [(String, SrcSpan)]
forall a. a -> [a] -> [a]
: (Char -> SrcSpan -> (String, SrcSpan))
-> String -> [SrcSpan] -> [(String, SrcSpan)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Char
x SrcSpan
y -> ([Char
x],SrcSpan
y)) String
subtsVars ((Located (Pat GhcPs) -> SrcSpan)
-> [Located (Pat GhcPs)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map Located (Pat GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSS [Located (Pat GhcPs)]
pats)
      template :: String
template = LHsExpr GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint ([LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [LPat GhcPs]
[Located (Pat GhcPs)]
oPats LHsExpr GhcPs
varBody)

-- match a lambda with a variable pattern, with no guards and no where clauses
lambdaExp Maybe (LHsExpr GhcPs)
_ o :: LHsExpr GhcPs
o@(SimpleLambda [LPat GhcPs -> PVar_
forall a b. View a b => a -> b
view -> PVar_ String
x] (L SrcSpan
_ HsExpr GhcPs
expr)) =
    case HsExpr GhcPs
expr of
        -- suggest TupleSections instead of lambdas
        ExplicitTuple XExplicitTuple GhcPs
_ [LHsTupArg GhcPs]
args Boxity
boxity
            -- is there exactly one argument that is exactly x?
            | ([LHsTupArg GhcPs
_x], [LHsTupArg GhcPs]
ys) <- (LHsTupArg GhcPs -> Bool)
-> [LHsTupArg GhcPs] -> ([LHsTupArg GhcPs], [LHsTupArg GhcPs])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
==String -> Maybe String
forall a. a -> Maybe a
Just String
x) (Maybe String -> Bool)
-> (LHsTupArg GhcPs -> Maybe String) -> LHsTupArg GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsTupArg GhcPs -> Maybe String
tupArgVar) [LHsTupArg GhcPs]
args
            -- the other arguments must not have a nested x somewhere in them
            , String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember String
x (Set String -> Bool) -> Set String -> Bool
forall a b. (a -> b) -> a -> b
$ (OccName -> String) -> Set OccName -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map OccName -> String
occNameString (Set OccName -> Set String) -> Set OccName -> Set String
forall a b. (a -> b) -> a -> b
$ [LHsTupArg GhcPs] -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars [LHsTupArg GhcPs]
ys
            -> [(String -> LHsExpr GhcPs -> LHsExpr GhcPs -> Idea
forall a. (HasSrcSpan a, Outputable a) => String -> a -> a -> Idea
suggestN String
"Use tuple-section" LHsExpr GhcPs
o (LHsExpr GhcPs -> Idea) -> LHsExpr GhcPs -> Idea
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XExplicitTuple GhcPs -> [LHsTupArg GhcPs] -> Boxity -> HsExpr GhcPs
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple NoExtField
XExplicitTuple GhcPs
noExtField ((LHsTupArg GhcPs -> LHsTupArg GhcPs)
-> [LHsTupArg GhcPs] -> [LHsTupArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LHsTupArg GhcPs -> LHsTupArg GhcPs
removeX [LHsTupArg GhcPs]
args) Boxity
boxity)
                  {ideaNote :: [Note]
ideaNote = [String -> Note
RequiresExtension String
"TupleSections"]}]

        -- suggest @LambdaCase@/directly matching in a lambda instead of doing @\x -> case x of ...@
        HsCase XCase GhcPs
_ (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
x') MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup
            -- is the case being done on the variable from our original lambda?
            | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
x'
            -- x must not be used in some other way inside the matches
            , String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember String
x (Set String -> Bool) -> Set String -> Bool
forall a b. (a -> b) -> a -> b
$ (OccName -> String) -> Set OccName -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map OccName -> String
occNameString (Set OccName -> Set String) -> Set OccName -> Set String
forall a b. (a -> b) -> a -> b
$ Vars -> Set OccName
free (Vars -> Set OccName) -> Vars -> Set OccName
forall a b. (a -> b) -> a -> b
$ MatchGroup GhcPs (LHsExpr GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup
            -> case MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup of
                 -- is there a single match? - suggest match inside the lambda
                 --
                 -- we need to
                 --     * add brackets to the match, because matches in lambdas require them
                 --     * mark match as being in a lambda context so that it's printed properly
                 oldMG :: MatchGroup GhcPs (LHsExpr GhcPs)
oldMG@(MG XMG GhcPs (LHsExpr GhcPs)
_ (L SrcSpan
_ [L SrcSpan
_ Match GhcPs (LHsExpr GhcPs)
oldmatch]) Origin
_) ->
                     [String -> LHsExpr GhcPs -> LHsExpr GhcPs -> Idea
forall a. (HasSrcSpan a, Outputable a) => String -> a -> a -> Idea
suggestN String
"Use lambda" LHsExpr GhcPs
o (LHsExpr GhcPs -> Idea) -> LHsExpr GhcPs -> Idea
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XLam GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
XLam GhcPs
noExtField MatchGroup GhcPs (LHsExpr GhcPs)
oldMG
                         { mg_alts :: GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
mg_alts = SrcSpanLess (GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)])
-> GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc
                             [SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> LMatch GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc Match GhcPs (LHsExpr GhcPs)
oldmatch
                                 { m_pats :: [LPat GhcPs]
m_pats = (Located (Pat GhcPs) -> Located (Pat GhcPs))
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map Located (Pat GhcPs) -> Located (Pat GhcPs)
forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
mkParPat ([Located (Pat GhcPs)] -> [Located (Pat GhcPs)])
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a b. (a -> b) -> a -> b
$ Match GhcPs (LHsExpr GhcPs) -> [LPat GhcPs]
forall p body. Match p body -> [LPat p]
m_pats Match GhcPs (LHsExpr GhcPs)
oldmatch
                                 , m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs))
m_ctxt = HsMatchContext (NameOrRdrName (IdP GhcPs))
forall id. HsMatchContext id
LambdaExpr
                                 }
                             ] }
                     ]

                 -- otherwise we should use @LambdaCase@
                 MG XMG GhcPs (LHsExpr GhcPs)
_ (L SrcSpan
_ [LMatch GhcPs (LHsExpr GhcPs)]
xs) Origin
_ ->
                     [(String -> LHsExpr GhcPs -> LHsExpr GhcPs -> Idea
forall a. (HasSrcSpan a, Outputable a) => String -> a -> a -> Idea
suggestN String
"Use lambda-case" LHsExpr GhcPs
o (LHsExpr GhcPs -> Idea) -> LHsExpr GhcPs -> Idea
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XLamCase GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
forall p. XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase NoExtField
XLamCase GhcPs
noExtField MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup)
                         {ideaNote :: [Note]
ideaNote=[String -> Note
RequiresExtension String
"LambdaCase"]}]
                 MatchGroup GhcPs (LHsExpr GhcPs)
_ -> []
        HsExpr GhcPs
_ -> []
    where
        -- | Filter out tuple arguments, converting the @x@ (matched in the lambda) variable argument
        -- to a missing argument, so that we get the proper section.
        removeX :: LHsTupArg GhcPs -> LHsTupArg GhcPs
        removeX :: LHsTupArg GhcPs -> LHsTupArg GhcPs
removeX arg :: LHsTupArg GhcPs
arg@(L SrcSpan
_ (Present XPresent GhcPs
_ (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
x')))
            | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
x' = SrcSpanLess (LHsTupArg GhcPs) -> LHsTupArg GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsTupArg GhcPs) -> LHsTupArg GhcPs)
-> SrcSpanLess (LHsTupArg GhcPs) -> LHsTupArg GhcPs
forall a b. (a -> b) -> a -> b
$ XMissing GhcPs -> HsTupArg GhcPs
forall id. XMissing id -> HsTupArg id
Missing NoExtField
XMissing GhcPs
noExtField
        removeX LHsTupArg GhcPs
y = LHsTupArg GhcPs
y
        -- | Extract the name of an argument of a tuple if it's present and a variable.
        tupArgVar :: LHsTupArg GhcPs -> Maybe String
        tupArgVar :: LHsTupArg GhcPs -> Maybe String
tupArgVar (L SrcSpan
_ (Present XPresent GhcPs
_ (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
x))) = String -> Maybe String
forall a. a -> Maybe a
Just String
x
        tupArgVar LHsTupArg GhcPs
_ = Maybe String
forall a. Maybe a
Nothing

lambdaExp Maybe (LHsExpr GhcPs)
_ LHsExpr GhcPs
_ = []

varBody :: LHsExpr GhcPs
varBody :: LHsExpr GhcPs
varBody = String -> LHsExpr GhcPs
strToVar String
"body"

-- | Squash lambdas and replace any repeated pattern variable with @_@
fromLambda :: LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
fromLambda :: LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
fromLambda (SimpleLambda [LPat GhcPs]
ps1 (LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs)
fromLambda (LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs))
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs
-> ([Located (Pat GhcPs)], LHsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs
fromParen -> ([Located (Pat GhcPs)]
ps2,LHsExpr GhcPs
x))) = ((Pat GhcPs -> Pat GhcPs)
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi ([String] -> Pat GhcPs -> Pat GhcPs
f ([String] -> Pat GhcPs -> Pat GhcPs)
-> [String] -> Pat GhcPs -> Pat GhcPs
forall a b. (a -> b) -> a -> b
$ [Located (Pat GhcPs)] -> [String]
forall a. AllVars a => a -> [String]
pvars [Located (Pat GhcPs)]
ps2) [LPat GhcPs]
[Located (Pat GhcPs)]
ps1 [Located (Pat GhcPs)]
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Located (Pat GhcPs)]
ps2, LHsExpr GhcPs
x)
    where f :: [String] -> Pat GhcPs -> Pat GhcPs
          f :: [String] -> Pat GhcPs -> Pat GhcPs
f [String]
bad (VarPat XVarPat GhcPs
_ (Located (IdP GhcPs) -> String
Located RdrName -> String
rdrNameStr -> String
x))
              | String
x String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
bad = XWildPat GhcPs -> Pat GhcPs
forall p. XWildPat p -> Pat p
WildPat NoExtField
XWildPat GhcPs
noExtField
          f [String]
bad Pat GhcPs
x = Pat GhcPs
x
fromLambda LHsExpr GhcPs
x = ([], LHsExpr GhcPs
x)

-- | For each pattern, if it does not contain wildcards, replace it with a variable pattern.
--
-- The second component of the result is a list of substitution variables, which is ['a'..'z'],
-- excluding variables that occur in the function name or patterns with wildcards. For example, given
-- 'f (Foo a b _) = ...', 'f', 'a' and 'b' are removed.
mkOrigPats :: Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], [Char])
mkOrigPats :: Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], String)
mkOrigPats Maybe String
funName [LPat GhcPs]
pats = ((Char -> (Bool, Located (Pat GhcPs)) -> Located (Pat GhcPs))
-> String -> [(Bool, Located (Pat GhcPs))] -> [Located (Pat GhcPs)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Char -> (Bool, LPat GhcPs) -> LPat GhcPs
Char -> (Bool, Located (Pat GhcPs)) -> Located (Pat GhcPs)
munge String
subtsVars [(Bool, Located (Pat GhcPs))]
pats', String
subtsVars)
  where
    ([Set Char] -> Set Char
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions -> Set Char
used, [(Bool, Located (Pat GhcPs))]
pats') = [(Set Char, (Bool, Located (Pat GhcPs)))]
-> ([Set Char], [(Bool, Located (Pat GhcPs))])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Located (Pat GhcPs) -> (Set Char, (Bool, Located (Pat GhcPs))))
-> [Located (Pat GhcPs)]
-> [(Set Char, (Bool, Located (Pat GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcPs -> (Set Char, (Bool, LPat GhcPs))
Located (Pat GhcPs) -> (Set Char, (Bool, Located (Pat GhcPs)))
f [LPat GhcPs]
[Located (Pat GhcPs)]
pats)

    -- Remove variables that occur in the function name or patterns with wildcards
    subtsVars :: String
subtsVars = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (\Char
c -> Char
c Char -> Set Char -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Char
used Bool -> Bool -> Bool
&& String -> Maybe String
forall a. a -> Maybe a
Just [Char
c] Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe String
funName) [Char
'a'..Char
'z']

    -- Returns (chars in the pattern if the pattern contains wildcards, (whether the pattern contains wildcards, the pattern))
    f :: LPat GhcPs -> (Set Char, (Bool, LPat GhcPs))
    f :: LPat GhcPs -> (Set Char, (Bool, LPat GhcPs))
f LPat GhcPs
p
      | (Located (Pat GhcPs) -> Bool) -> [Located (Pat GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LPat GhcPs -> Bool
Located (Pat GhcPs) -> Bool
isWildPat (Located (Pat GhcPs) -> [Located (Pat GhcPs)]
forall on. Uniplate on => on -> [on]
universe LPat GhcPs
Located (Pat GhcPs)
p) =
          let used :: Set Char
used = String -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList [Char
c | (L SrcSpan
_ (VarPat XVarPat GhcPs
_ (Located (IdP GhcPs) -> String
Located RdrName -> String
rdrNameStr -> [Char
c]))) <- Located (Pat GhcPs) -> [Located (Pat GhcPs)]
forall on. Uniplate on => on -> [on]
universe LPat GhcPs
Located (Pat GhcPs)
p]
           in (Set Char
used, (Bool
True, LPat GhcPs
p))
      | Bool
otherwise = (Set Char
forall a. Monoid a => a
mempty, (Bool
False, LPat GhcPs
p))

    isWildPat :: LPat GhcPs -> Bool
    isWildPat :: LPat GhcPs -> Bool
isWildPat = \case (L _ (WildPat _)) -> Bool
True; LPat GhcPs
_ -> Bool
False

    -- Replace the pattern with a variable pattern if the pattern doesn't contain wildcards.
    munge :: Char -> (Bool, LPat GhcPs) -> LPat GhcPs
    munge :: Char -> (Bool, LPat GhcPs) -> LPat GhcPs
munge Char
_ (Bool
True, LPat GhcPs
p) = LPat GhcPs
p
    munge Char
ident (Bool
False, L ploc _) = SrcSpan -> Pat GhcPs -> Located (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
ploc (XVarPat GhcPs -> Located (IdP GhcPs) -> Pat GhcPs
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat NoExtField
XVarPat GhcPs
noExtField (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
ploc (RdrName -> Located RdrName) -> RdrName -> Located RdrName
forall a b. (a -> b) -> a -> b
$ OccName -> RdrName
mkRdrUnqual (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ String -> OccName
mkVarOcc [Char
ident]))