{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase, PatternGuards, TupleSections, 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
fun x y z = f x x y z -- fun x = f x x
fun x y z = f g z -- fun x y = f g
fun x = f . g $ x -- fun = f . g
fun a b = f a b c where g x y = h x y -- g = h
fun a b = let g x y = h x y in f a b c -- g = h
f = foo (\y -> g x . h $ y) -- g x . h
f = foo (\y -> g x . h $ y) -- @Message Avoid lambda
f = foo ((*) x) -- (x *)
f = (*) x
f = foo (flip op x) -- (`op` x)
f = foo (flip op x) -- @Message Use section
f = foo (flip x y) -- (`x` y)
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)
f = foo (flip (Prelude.*) x) -- (Prelude.* x)
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
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)
f = a b (\x -> c x d)  -- (`c` d)
yes = \x -> a x where -- a
yes = \x y -> op y x where -- flip op
yes = \x y -> op z y x where -- flip (op z)
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)
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 +)) -- (+)
xs `withArgsFrom` args = f args
foo = bar (\x -> case x of Y z -> z) -- \(Y z) -> z
foo = bar (\x -> case x of [y, z] -> z) -- \[y, z] -> z
yes = blah (\ x -> case x of A -> a; B -> b) -- \ case A -> a; B -> b
yes = blah (\ x -> case x of A -> a; B -> b) -- @Note may require `{-# LANGUAGE LambdaCase #-}` adding to the top of the file
no = blah (\ x -> case x of A -> a x; B -> b x)
no = blah (\ x -> case x of A -> a x; x -> b x)
foo = bar (\x -> case x of Y z | z > 0 -> z) -- \case Y z | z > 0 -> z
yes = blah (\ x -> (y, x)) -- (y,)
yes = blah (\ x -> (y, x, z+q)) -- (y, , z+q)
yes = blah (\ x -> (y, x, y, u, v)) -- (y, , y, u, v)
yes = blah (\ x -> (y, x, z+q)) -- @Note may require `{-# LANGUAGE TupleSections #-}` adding to the top of the file
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, toSSA, suggestN, ideaNote, substVars, toRefactSrcSpan)
import Util
import Data.List.Extra
import Data.Set (Set)
import Data.Set qualified as Set
import Refact.Types hiding (Match)
import Data.Generics.Uniplate.DataOnly (universe, universeBi, transformBi)

import GHC.Types.Basic
import GHC.Types.Fixity
import GHC.Hs
import GHC.Types.Name.Occurrence
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr (isTypeApp, isOpApp, isLambda, isQuasiQuoteExpr, 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 (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
  GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> [Idea])
-> [(Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
     GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> [Idea]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> [Idea])
-> (Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
    GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [Idea]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> [Idea]
lambdaExp) (GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> [(Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
     GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a b. (Data a, Data b) => a -> [(Maybe b, b)]
universeParentBi LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs)
x)
    [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++ ((GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs), RType) -> [Idea])
-> [(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs), RType)]
-> [Idea]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs) -> RType -> [Idea])
-> (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs), RType) -> [Idea]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry LHsBind GhcPs -> RType -> [Idea]
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs) -> RType -> [Idea]
lambdaBind) [(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs), RType)]
binds
  where
    binds :: [(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs), RType)]
binds =
        ( case LHsDecl GhcPs
x of
            -- Turn a top-level HsBind under a ValD into an LHsBind.
            -- Also, its refact type needs to be Decl.
            L SrcSpanAnnA
loc (ValD XValD GhcPs
_ HsBindLR GhcPs GhcPs
bind) -> ((SrcSpanAnnA
-> HsBindLR GhcPs GhcPs
-> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsBindLR GhcPs GhcPs
bind, RType
Decl) (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs), RType)
-> [(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs), RType)]
-> [(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs), RType)]
forall a. a -> [a] -> [a]
:)
            LHsDecl GhcPs
_ -> [(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs), RType)]
-> [(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs), RType)]
forall a. a -> a
id
        )
            ((,RType
Bind) (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
 -> (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs), RType))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> [(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs), RType)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
forall from to. Biplate from to => from -> [to]
universeBi LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs)
x)

lambdaBind :: LHsBind GhcPs -> RType -> [Idea]
lambdaBind :: LHsBind GhcPs -> RType -> [Idea]
lambdaBind
    o :: LHsBind GhcPs
o@(L SrcSpanAnnA
_ origBind :: HsBindLR GhcPs GhcPs
origBind@FunBind {fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = funName :: LIdP GhcPs
funName@(L SrcSpanAnnN
loc1 RdrName
_), fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches =
        MG {mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts =
            L SrcSpanAnnL
_ [L SrcSpanAnnA
_ (Match XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ ctxt :: HsMatchContext GhcPs
ctxt@(FunRhs LIdP (NoGhcTc GhcPs)
_ LexicalFixity
Prefix SrcStrictness
_) [LPat GhcPs]
pats (GRHSs XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [L SrcAnn NoEpAnns
_ (GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [] origBody :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
origBody@(L SrcSpanAnnA
loc2 HsExpr GhcPs
_))] HsLocalBinds GhcPs
bind))]}}) RType
rtype
    | EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
_ <- HsLocalBinds GhcPs
bind
    , LHsExpr GhcPs -> Bool
isLambda (LHsExpr GhcPs -> Bool) -> LHsExpr GhcPs -> Bool
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
fromParen GenLocated SrcSpanAnnA (HsExpr GhcPs)
origBody
    , [HsExpr GhcPs] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([GenLocated SrcSpanAnnA (Pat GhcPs)] -> [HsExpr GhcPs]
forall from to. Biplate from to => from -> [to]
universeBi [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats :: [HsExpr GhcPs])
    = let ([GenLocated SrcSpanAnnA (Pat GhcPs)]
newPats, GenLocated SrcSpanAnnA (HsExpr GhcPs)
newBody) = LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
    GenLocated SrcSpanAnnA (HsExpr GhcPs))
fromLambda (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
     GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
    GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [LPat GhcPs]
pats (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
     GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
    GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs)
origBody
          ([(String, SrcSpan)]
sub, String
tpl) = [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ([(String, SrcSpan)], String)
forall {a} {e}.
[GenLocated SrcSpanAnnA (Pat GhcPs)]
-> GenLocated (SrcSpanAnn' a) e -> ([(String, SrcSpan)], String)
mkSubtsAndTpl [GenLocated SrcSpanAnnA (Pat GhcPs)]
newPats GenLocated SrcSpanAnnA (HsExpr GhcPs)
newBody
          gen :: [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
          gen :: [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
gen [LPat GhcPs]
ps = ([GenLocated SrcSpanAnnA (Pat GhcPs)]
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Located (HsDecl GhcPs))
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
    GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Located (HsDecl GhcPs)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
[GenLocated SrcSpanAnnA (Pat GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Located (HsDecl GhcPs)
reform (([GenLocated SrcSpanAnnA (Pat GhcPs)],
  GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> Located (HsDecl GhcPs))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
        GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Located (HsDecl GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
    GenLocated SrcSpanAnnA (HsExpr GhcPs))
fromLambda (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
     GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
    GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [LPat GhcPs]
ps
          refacts :: [Refactoring SrcSpan]
refacts = case GenLocated SrcSpanAnnA (HsExpr GhcPs)
newBody of
              -- https://github.com/alanz/ghc-exactprint/issues/97
              L SrcSpanAnnA
_ HsCase{} -> []
              GenLocated SrcSpanAnnA (HsExpr GhcPs)
_ -> [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
rtype (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
o) [(String, SrcSpan)]
sub String
tpl]
       in [String
-> Located (HsBindLR GhcPs GhcPs)
-> Located (HsDecl GhcPs)
-> [Refactoring SrcSpan]
-> Idea
forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
warn String
"Redundant lambda" (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
-> Located (HsBindLR GhcPs GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
o) ([LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
gen [LPat GhcPs]
pats LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
origBody) [Refactoring SrcSpan]
refacts]

    | let ([LPat GhcPs]
newPats, LHsExpr GhcPs
newBody) = [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce [LPat GhcPs]
pats LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
origBody
    , [GenLocated SrcSpanAnnA (Pat GhcPs)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GenLocated SrcSpanAnnA (Pat GhcPs)]
newPats Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [GenLocated SrcSpanAnnA (Pat GhcPs)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats, [GenLocated SrcSpanAnnA (Pat GhcPs)] -> [String]
forall a. AllVars a => a -> [String]
pvars (Int
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a. Int -> [a] -> [a]
drop ([GenLocated SrcSpanAnnA (Pat GhcPs)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GenLocated SrcSpanAnnA (Pat GhcPs)]
newPats) [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats) [String] -> [String] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`disjoint` HsLocalBinds GhcPs -> [String]
forall a. AllVars a => a -> [String]
varss HsLocalBinds GhcPs
bind
    = let ([(String, SrcSpan)]
sub, String
tpl) = [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ([(String, SrcSpan)], String)
forall {a} {e}.
[GenLocated SrcSpanAnnA (Pat GhcPs)]
-> GenLocated (SrcSpanAnn' a) e -> ([(String, SrcSpan)], String)
mkSubtsAndTpl [GenLocated SrcSpanAnnA (Pat GhcPs)]
newPats GenLocated SrcSpanAnnA (HsExpr GhcPs)
newBody
       in [String
-> Located (HsDecl GhcPs)
-> Located (HsDecl GhcPs)
-> [Refactoring SrcSpan]
-> Idea
forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
warn String
"Eta reduce" ([LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
reform [LPat GhcPs]
pats LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
origBody) ([LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
reform [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
newPats LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
newBody)
            [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
rtype (Located (HsDecl GhcPs) -> SrcSpan
forall a. Located a -> SrcSpan
toSS (Located (HsDecl GhcPs) -> SrcSpan)
-> Located (HsDecl GhcPs) -> SrcSpan
forall a b. (a -> b) -> a -> b
$ [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
reform [LPat GhcPs]
pats LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
origBody) [(String, SrcSpan)]
sub String
tpl]
          ]
    where
          reform :: [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
          reform :: [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
reform [LPat GhcPs]
ps LHsExpr GhcPs
b = SrcSpan -> HsDecl GhcPs -> Located (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc1) (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc2)) (HsDecl GhcPs -> Located (HsDecl GhcPs))
-> HsDecl GhcPs -> Located (HsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XValD GhcPs -> HsBindLR GhcPs GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
ValD XValD GhcPs
NoExtField
noExtField (HsBindLR GhcPs GhcPs -> HsDecl GhcPs)
-> HsBindLR GhcPs GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$
             HsBindLR GhcPs GhcPs
origBind {fun_matches = MG (Generated DoPmc) (noLocA [noLocA $ Match EpAnnNotUsed ctxt ps $ GRHSs emptyComments [noLocA $ GRHS EpAnnNotUsed [] b] $ EmptyLocalBinds noExtField])}

          mkSubtsAndTpl :: [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> GenLocated (SrcSpanAnn' a) e -> ([(String, SrcSpan)], String)
mkSubtsAndTpl [GenLocated SrcSpanAnnA (Pat GhcPs)]
newPats GenLocated (SrcSpanAnn' a) e
newBody = ([(String, SrcSpan)]
sub, String
tpl)
            where
              ([LPat GhcPs]
origPats, [String]
vars) = Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], [String])
mkOrigPats (String -> Maybe String
forall a. a -> Maybe a
Just (GenLocated SrcSpanAnnN RdrName -> String
rdrNameStr LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
funName)) [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
newPats
              sub :: [(String, SrcSpan)]
sub = (String
"body", GenLocated (SrcSpanAnn' a) e -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA GenLocated (SrcSpanAnn' a) e
newBody) (String, SrcSpan) -> [(String, SrcSpan)] -> [(String, SrcSpan)]
forall a. a -> [a] -> [a]
: [String] -> [SrcSpan] -> [(String, SrcSpan)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
vars ((GenLocated SrcSpanAnnA (Pat GhcPs) -> SrcSpan)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (Pat GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA [GenLocated SrcSpanAnnA (Pat GhcPs)]
newPats)
              tpl :: String
tpl = Located (HsDecl GhcPs) -> String
forall a. Outputable a => a -> String
unsafePrettyPrint ([LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
reform [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
origPats LHsExpr GhcPs
varBody)

lambdaBind LHsBind GhcPs
_ RType
_ = []

etaReduce :: [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce :: [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce ([LPat GhcPs]
-> Maybe
     ([GenLocated SrcSpanAnnA (Pat GhcPs)],
      GenLocated SrcSpanAnnA (Pat GhcPs))
[GenLocated SrcSpanAnnA (Pat GhcPs)]
-> Maybe
     ([GenLocated SrcSpanAnnA (Pat GhcPs)],
      GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. [a] -> Maybe ([a], a)
unsnoc -> Just ([GenLocated SrcSpanAnnA (Pat GhcPs)]
ps, GenLocated SrcSpanAnnA (Pat GhcPs) -> PVar_
forall a b. View a b => a -> b
view -> PVar_ String
p)) (L SrcSpanAnnA
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
x (LHsExpr GhcPs -> Var_
GenLocated SrcSpanAnnA (HsExpr 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` GenLocated SrcSpanAnnA (HsExpr GhcPs) -> [String]
forall a. FreeVars a => a -> [String]
vars LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x
    , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LHsExpr GhcPs -> Bool
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool
isQuasiQuoteExpr ([GenLocated SrcSpanAnnA (HsExpr GhcPs)] -> Bool)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)] -> Bool
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall on. Uniplate on => on -> [on]
universe LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x
    = [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
ps LHsExpr GhcPs
x
etaReduce [LPat GhcPs]
ps (L SrcSpanAnnA
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 (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
x LHsExpr GhcPs
y))
etaReduce [LPat GhcPs]
ps LHsExpr GhcPs
x = ([LPat GhcPs]
ps, LHsExpr GhcPs
x)

lambdaExp :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
lambdaExp :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
lambdaExp Maybe (LHsExpr GhcPs)
_ o :: LHsExpr GhcPs
o@(L SrcSpanAnnA
_ (HsPar XPar GhcPs
_ LHsToken "(" GhcPs
_ (L SrcSpanAnnA
_ (HsApp XApp GhcPs
_ oper :: LHsExpr GhcPs
oper@(L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ origf :: LIdP GhcPs
origf@(L SrcSpanAnnN
_ (RdrName -> OccName
rdrNameOcc -> OccName
f)))) LHsExpr GhcPs
y)) LHsToken ")" GhcPs
_))
    | OccName -> Bool
isSymOcc OccName
f -- is this an operator?
    , GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool
forall a. Brackets a => a -> Bool
isAtom LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
-> [Refactoring SrcSpan]
-> Idea
forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
suggest String
"Use section" (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
o) (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
to) [Refactoring SrcSpan
r]]
    where
        to :: LHsExpr GhcPs
        to :: LHsExpr GhcPs
to = LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr 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 XSectionL GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
y LHsExpr GhcPs
oper
        r :: Refactoring SrcSpan
r = RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
o) [(String
"x", GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
y)] (String
"(x " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LIdP GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint LIdP GhcPs
origf String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")

lambdaExp Maybe (LHsExpr GhcPs)
_ o :: LHsExpr GhcPs
o@(L SrcSpanAnnA
_ (HsPar XPar GhcPs
_ LHsToken "(" GhcPs
_ (LHsExpr GhcPs -> App2
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> App2
forall a b. View a b => a -> b
view -> App2 (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Var_
forall a b. View a b => a -> b
view -> Var_ String
"flip") origf :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
origf@(GenLocated SrcSpanAnnA (HsExpr GhcPs) -> RdrName_
forall a b. View a b => a -> b
view -> RdrName_ GenLocated SrcSpanAnnN RdrName
f) GenLocated SrcSpanAnnA (HsExpr GhcPs)
y) LHsToken ")" GhcPs
_))
    | String -> Bool
allowRightSection (GenLocated SrcSpanAnnN RdrName -> String
rdrNameStr GenLocated SrcSpanAnnN RdrName
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` GenLocated SrcSpanAnnN RdrName -> String
rdrNameStr GenLocated SrcSpanAnnN RdrName
f
    = [String
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
-> [Refactoring SrcSpan]
-> Idea
forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
suggest String
"Use section" (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
o) (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
to) [Refactoring SrcSpan
r]]
    where
        to :: LHsExpr GhcPs
        to :: LHsExpr GhcPs
to = LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr 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 XSectionR GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
origf LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
y
        op :: String
op = if RdrName -> Bool
isSymbolRdrName (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN RdrName
f)
               then GenLocated SrcSpanAnnN RdrName -> String
forall a. Outputable a => a -> String
unsafePrettyPrint GenLocated SrcSpanAnnN RdrName
f
               else String
"`" String -> String -> String
forall a. [a] -> [a] -> [a]
++ GenLocated SrcSpanAnnN RdrName -> String
forall a. Outputable a => a -> String
unsafePrettyPrint GenLocated SrcSpanAnnN RdrName
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"`"
        var :: String
var = if GenLocated SrcSpanAnnN RdrName -> String
rdrNameStr GenLocated SrcSpanAnnN RdrName
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"x" then String
"y" else String
"x"
        r :: Refactoring SrcSpan
r = RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
o) [(String
var, GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA GenLocated SrcSpanAnnA (HsExpr GhcPs)
y)] (String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")

lambdaExp Maybe (LHsExpr GhcPs)
p o :: LHsExpr GhcPs
o@(L SrcSpanAnnA
_ HsLam{})
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LHsExpr GhcPs -> Bool
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool
isOpApp Maybe (LHsExpr GhcPs)
Maybe (GenLocated SrcSpanAnnA (HsExpr 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
$ (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LHsExpr GhcPs -> Bool
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool
isQuasiQuoteExpr ([GenLocated SrcSpanAnnA (HsExpr GhcPs)] -> Bool)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)] -> Bool
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall on. Uniplate on => on -> [on]
universe LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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 (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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 of
              -- Avoid creating redundant bracket.
              Just p :: LHsExpr GhcPs
p@(L SrcSpanAnnA
_ (HsPar XPar GhcPs
_ LHsToken "(" GhcPs
_ (L SrcSpanAnnA
_ HsLam{}) LHsToken ")" GhcPs
_))
                | L SrcSpanAnnA
_ HsPar{} <- LHsExpr GhcPs
res -> LHsExpr GhcPs
p
                | L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ RdrName
name)) <- LHsExpr GhcPs
res, Bool -> Bool
not (RdrName -> Bool
isSymbolRdrName RdrName
name) -> LHsExpr GhcPs
p
              Maybe (LHsExpr GhcPs)
_ -> LHsExpr GhcPs
o
    = [(if LHsExpr GhcPs -> Bool
isVar LHsExpr GhcPs
res then String
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
-> [Refactoring SrcSpan]
-> Idea
forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
warn else String
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
-> [Refactoring SrcSpan]
-> Idea
forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
suggest) String
name (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc GenLocated SrcSpanAnnA (HsExpr GhcPs)
from) (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
res) (SrcSpan -> [Refactoring SrcSpan]
refact (SrcSpan -> [Refactoring SrcSpan])
-> SrcSpan -> [Refactoring SrcSpan]
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA GenLocated SrcSpanAnnA (HsExpr GhcPs)
from)]
    where
        countRightSections :: LHsExpr GhcPs -> Int
        countRightSections :: LHsExpr GhcPs -> Int
countRightSections LHsExpr GhcPs
x = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | L SrcSpanAnnA
_ (SectionR XSectionR GhcPs
_ (LHsExpr GhcPs -> Var_
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Var_
forall a b. View a b => a -> b
view -> Var_ String
_) LHsExpr GhcPs
_) <- GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall on. Uniplate on => on -> [on]
universe LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x]

lambdaExp Maybe (LHsExpr GhcPs)
p o :: LHsExpr GhcPs
o@(SimpleLambda [GenLocated SrcSpanAnnA (Pat GhcPs)]
origPats GenLocated SrcSpanAnnA (HsExpr GhcPs)
origBody)
    | LHsExpr GhcPs -> Bool
isLambda (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
fromParen GenLocated SrcSpanAnnA (HsExpr GhcPs)
origBody)
    , [HsExpr GhcPs] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([GenLocated SrcSpanAnnA (Pat GhcPs)] -> [HsExpr GhcPs]
forall from to. Biplate from to => from -> [to]
universeBi [GenLocated SrcSpanAnnA (Pat GhcPs)]
origPats :: [HsExpr GhcPs]) -- TODO: I think this checks for view patterns only, so maybe be more explicit about that?
    , Bool
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not (Bool -> Bool)
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> Bool
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool
isLambda) Maybe (LHsExpr GhcPs)
Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
p =
    [String
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
-> [Refactoring SrcSpan]
-> Idea
forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
suggest String
"Collapse lambdas" (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
o) (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc ([LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
body)) [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
o) [(String, SrcSpan)]
subts String
template]]
    where
      ([LPat GhcPs]
pats, LHsExpr GhcPs
body) = LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
fromLambda LHsExpr GhcPs
o
      ([LPat GhcPs]
oPats, [String]
vars) = Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], [String])
mkOrigPats Maybe String
forall a. Maybe a
Nothing [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats
      subts :: [(String, SrcSpan)]
subts = (String
"body", GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA GenLocated SrcSpanAnnA (HsExpr GhcPs)
body) (String, SrcSpan) -> [(String, SrcSpan)] -> [(String, SrcSpan)]
forall a. a -> [a] -> [a]
: [String] -> [SrcSpan] -> [(String, SrcSpan)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
vars ((GenLocated SrcSpanAnnA (Pat GhcPs) -> SrcSpan)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (Pat GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA [GenLocated SrcSpanAnnA (Pat GhcPs)]
pats)
      template :: String
template = GenLocated SrcSpanAnnA (HsExpr GhcPs) -> String
forall a. Outputable a => a -> String
unsafePrettyPrint ([LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [LPat GhcPs]
[GenLocated SrcSpanAnnA (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 [GenLocated SrcSpanAnnA (Pat GhcPs) -> PVar_
forall a b. View a b => a -> b
view -> PVar_ String
x] (L SrcSpanAnnA
_ HsExpr GhcPs
expr)) =
    case HsExpr GhcPs
expr of
        -- suggest TupleSections instead of lambdas
        ExplicitTuple XExplicitTuple GhcPs
_ [HsTupArg GhcPs]
args Boxity
boxity
            -- is there exactly one argument that is exactly x?
            | ([HsTupArg GhcPs
_x], [HsTupArg GhcPs]
ys) <- (HsTupArg GhcPs -> Bool)
-> [HsTupArg GhcPs] -> ([HsTupArg GhcPs], [HsTupArg 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)
-> (HsTupArg GhcPs -> Maybe String) -> HsTupArg GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsTupArg GhcPs -> Maybe String
tupArgVar) [HsTupArg 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
$ [HsTupArg GhcPs] -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars [HsTupArg GhcPs]
ys
            -> [(String -> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs) -> Idea
forall a. Outputable a => String -> Located a -> Located a -> Idea
suggestN String
"Use tuple-section" (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
o) (Located (HsExpr GhcPs) -> Idea) -> Located (HsExpr GhcPs) -> Idea
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> Located (HsExpr GhcPs)
forall e. e -> Located e
noLoc (HsExpr GhcPs -> Located (HsExpr GhcPs))
-> HsExpr GhcPs -> Located (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XExplicitTuple GhcPs -> [HsTupArg GhcPs] -> Boxity -> HsExpr GhcPs
forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
EpAnnNotUsed ((HsTupArg GhcPs -> HsTupArg GhcPs)
-> [HsTupArg GhcPs] -> [HsTupArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map HsTupArg GhcPs -> HsTupArg GhcPs
removeX [HsTupArg GhcPs]
args) Boxity
boxity)
                  {ideaNote = [RequiresExtension "TupleSections"]}]
        -- suggest @LambdaCase@/directly matching in a lambda instead of doing @\x -> case x of ...@
        HsCase XCase GhcPs
_ (LHsExpr GhcPs -> Var_
GenLocated SrcSpanAnnA (HsExpr 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 (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> Vars
forall a. AllVars a => a -> Vars
allVars MatchGroup GhcPs (LHsExpr GhcPs)
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr 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 SrcSpanAnnL
_ [L SrcSpanAnnA
_ Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
oldmatch]))
                   | (GenLocated
   (SrcAnn NoEpAnns)
   (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> Bool)
-> [GenLocated
      (SrcAnn NoEpAnns)
      (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(L SrcAnn NoEpAnns
_ (GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [GuardLStmt GhcPs]
stmts GenLocated SrcSpanAnnA (HsExpr GhcPs)
_)) -> [GuardLStmt GhcPs] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GuardLStmt GhcPs]
stmts) (GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body. Match p body -> GRHSs p body
m_grhss Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
oldmatch)) ->
                     let patLocs :: [SrcSpan]
patLocs = (GenLocated SrcSpanAnnA (Pat GhcPs) -> SrcSpan)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA (SrcSpanAnnA -> SrcSpan)
-> (GenLocated SrcSpanAnnA (Pat GhcPs) -> SrcSpanAnnA)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Pat GhcPs) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc) (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> [LPat GhcPs]
forall p body. Match p body -> [LPat p]
m_pats Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
oldmatch)
                         bodyLocs :: [SrcSpan]
bodyLocs = (GenLocated
   (Anno (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
   (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> [SrcSpan])
-> [GenLocated
      (Anno (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
      (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [SrcSpan]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\case L Anno (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
_ (GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [GuardLStmt GhcPs]
_ GenLocated SrcSpanAnnA (HsExpr GhcPs)
body) -> [SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnA (HsExpr GhcPs)
body)])
                                        ([GenLocated
    (Anno (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
    (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> [SrcSpan])
-> [GenLocated
      (Anno (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
      (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [SrcSpan]
forall a b. (a -> b) -> a -> b
$ GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body. Match p body -> GRHSs p body
m_grhss Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
oldmatch)
                         r :: [Refactoring SrcSpan]
r | [SrcSpan] -> Bool
forall a. [a] -> Bool
notNull [SrcSpan]
patLocs Bool -> Bool -> Bool
&& [SrcSpan] -> Bool
forall a. [a] -> Bool
notNull [SrcSpan]
bodyLocs =
                             let xloc :: SrcSpan
xloc = (SrcSpan -> SrcSpan -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans [SrcSpan]
patLocs
                                 yloc :: SrcSpan
yloc = (SrcSpan -> SrcSpan -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans [SrcSpan]
bodyLocs
                              in [ RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
o) [(String
"x", SrcSpan -> SrcSpan
toRefactSrcSpan SrcSpan
xloc), (String
"y", SrcSpan -> SrcSpan
toRefactSrcSpan SrcSpan
yloc)]
                                     ((if Bool
needParens then String
"\\(x)" else String
"\\x") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> y")
                                 ]
                           | Bool
otherwise = []
                         needParens :: Bool
needParens = (GenLocated SrcSpanAnnA (Pat GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (PprPrec -> Pat GhcPs -> Bool
forall (p :: Pass). IsPass p => PprPrec -> Pat (GhcPass p) -> Bool
patNeedsParens PprPrec
appPrec (Pat GhcPs -> Bool)
-> (GenLocated SrcSpanAnnA (Pat GhcPs) -> Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Pat GhcPs) -> Pat GhcPs
forall l e. GenLocated l e -> e
unLoc) (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> [LPat GhcPs]
forall p body. Match p body -> [LPat p]
m_pats Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
oldmatch)
                      in [ String
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
-> [Refactoring SrcSpan]
-> Idea
forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
suggest String
"Use lambda" (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
o)
                             ( HsExpr GhcPs -> Located (HsExpr GhcPs)
forall e. e -> Located e
noLoc (HsExpr GhcPs -> Located (HsExpr GhcPs))
-> HsExpr GhcPs -> Located (HsExpr 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 XLam GhcPs
NoExtField
noExtField MatchGroup GhcPs (LHsExpr GhcPs)
oldMG
                                 { mg_alts = noLocA
                                     [ noLocA oldmatch
                                         { m_pats = map mkParPat $ m_pats oldmatch
                                         , m_ctxt = LambdaExpr
                                         }
                                     ]
                                 }
                               :: Located (HsExpr GhcPs)
                             )
                             [Refactoring SrcSpan]
r
                         ]

                 -- otherwise we should use @LambdaCase@
                 MG XMG GhcPs (LHsExpr GhcPs)
_ (L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
_) ->
                     [(String -> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs) -> Idea
forall a. Outputable a => String -> Located a -> Located a -> Idea
suggestN String
"Use lambda-case" (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
o) (Located (HsExpr GhcPs) -> Idea) -> Located (HsExpr GhcPs) -> Idea
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> Located (HsExpr GhcPs)
forall e. e -> Located e
noLoc (HsExpr GhcPs -> Located (HsExpr GhcPs))
-> HsExpr GhcPs -> Located (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XLamCase GhcPs
-> LamCaseVariant
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> HsExpr GhcPs
forall p.
XLamCase p
-> LamCaseVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase XLamCase GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
EpAnnNotUsed LamCaseVariant
LamCase MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup)
                         {ideaNote=[RequiresExtension "LambdaCase"]}]
        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 :: HsTupArg GhcPs -> HsTupArg GhcPs
        removeX :: HsTupArg GhcPs -> HsTupArg GhcPs
removeX (Present XPresent GhcPs
_ (LHsExpr GhcPs -> Var_
GenLocated SrcSpanAnnA (HsExpr 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' = XMissing GhcPs -> HsTupArg GhcPs
forall id. XMissing id -> HsTupArg id
Missing XMissing GhcPs
EpAnn EpaLocation
forall ann. EpAnn ann
EpAnnNotUsed
        removeX HsTupArg GhcPs
y = HsTupArg GhcPs
y
        -- | Extract the name of an argument of a tuple if it's present and a variable.
        tupArgVar :: HsTupArg GhcPs -> Maybe String
        tupArgVar :: HsTupArg GhcPs -> Maybe String
tupArgVar (Present XPresent GhcPs
_ (LHsExpr GhcPs -> Var_
GenLocated SrcSpanAnnA (HsExpr 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 HsTupArg 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 [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps1 (LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
    GenLocated SrcSpanAnnA (HsExpr GhcPs))
fromLambda (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
     GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
    GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
fromParen -> ([GenLocated SrcSpanAnnA (Pat GhcPs)]
ps2,GenLocated SrcSpanAnnA (HsExpr GhcPs)
x))) = ((Pat GhcPs -> Pat GhcPs)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (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
$ [GenLocated SrcSpanAnnA (Pat GhcPs)] -> [String]
forall a. AllVars a => a -> [String]
pvars [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps2) [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps1 [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps2, LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x)
    where f :: [String] -> Pat GhcPs -> Pat GhcPs
          f :: [String] -> Pat GhcPs -> Pat GhcPs
f [String]
bad (VarPat XVarPat GhcPs
_ (LIdP GhcPs -> String
GenLocated SrcSpanAnnN RdrName -> String
rdrNameStr -> String
x))
              | String
x String -> [String] -> Bool
forall a. Eq a => a -> [a] -> 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 XWildPat GhcPs
NoExtField
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 are guaranteed
-- to not occur in the function name or patterns with wildcards. For example, given
-- 'f (Foo a b _) = ...', 'f', 'a' and 'b' are not usable as substitution variables.
mkOrigPats :: Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], [String])
mkOrigPats :: Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], [String])
mkOrigPats Maybe String
funName [LPat GhcPs]
pats = ((String
 -> (Bool, GenLocated SrcSpanAnnA (Pat GhcPs))
 -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [String]
-> [(Bool, GenLocated SrcSpanAnnA (Pat GhcPs))]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> (Bool, LPat GhcPs) -> LPat GhcPs
String
-> (Bool, GenLocated SrcSpanAnnA (Pat GhcPs))
-> GenLocated SrcSpanAnnA (Pat GhcPs)
munge [String]
vars [(Bool, GenLocated SrcSpanAnnA (Pat GhcPs))]
pats', [String]
vars)
  where
    ([Set String] -> Set String
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions -> Set String
used, [(Bool, GenLocated SrcSpanAnnA (Pat GhcPs))]
pats') = [(Set String, (Bool, GenLocated SrcSpanAnnA (Pat GhcPs)))]
-> ([Set String], [(Bool, GenLocated SrcSpanAnnA (Pat GhcPs))])
forall a b. [(a, b)] -> ([a], [b])
unzip ((GenLocated SrcSpanAnnA (Pat GhcPs)
 -> (Set String, (Bool, GenLocated SrcSpanAnnA (Pat GhcPs))))
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [(Set String, (Bool, GenLocated SrcSpanAnnA (Pat GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcPs -> (Set String, (Bool, LPat GhcPs))
GenLocated SrcSpanAnnA (Pat GhcPs)
-> (Set String, (Bool, GenLocated SrcSpanAnnA (Pat GhcPs)))
f [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats)

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

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

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

    -- Replace the pattern with a variable pattern if the pattern doesn't contain wildcards.
    munge :: String -> (Bool, LPat GhcPs) -> LPat GhcPs
    munge :: String -> (Bool, LPat GhcPs) -> LPat GhcPs
munge String
_ (Bool
True, LPat GhcPs
p) = LPat GhcPs
p
    munge String
ident (Bool
False, L SrcSpanAnnA
ploc Pat GhcPs
_) = SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
ploc (XVarPat GhcPs -> LIdP GhcPs -> Pat GhcPs
forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat GhcPs
NoExtField
noExtField (RdrName -> GenLocated SrcSpanAnnN RdrName
forall a an. a -> LocatedAn an a
noLocA (RdrName -> GenLocated SrcSpanAnnN RdrName)
-> RdrName -> GenLocated SrcSpanAnnN 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 String
ident))