{-# 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)
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
    =  forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
lambdaExp) (forall a b. (Data a, Data b) => a -> [(Maybe b, b)]
universeParentBi LHsDecl GhcPs
x)
    forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry LHsBind 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) -> ((forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsBindLR GhcPs GhcPs
bind, RType
Decl) forall a. a -> [a] -> [a]
:)
            LHsDecl GhcPs
_ -> forall a. a -> a
id
        )
            ((,RType
Bind) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall from to. Biplate from to => from -> [to]
universeBi LHsDecl 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 forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
fromParen GenLocated SrcSpanAnnA (HsExpr GhcPs)
origBody
    , forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall from to. Biplate from to => from -> [to]
universeBi [LPat GhcPs]
pats :: [HsExpr GhcPs])
    = let ([GenLocated SrcSpanAnnA (Pat GhcPs)]
newPats, GenLocated SrcSpanAnnA (HsExpr GhcPs)
newBody) = LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
fromLambda forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [LPat GhcPs]
pats forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs)
origBody
          ([(String, SrcSpan)]
sub, String
tpl) = 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 = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
reform forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
fromLambda 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)
_ -> [forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
rtype (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LHsBind GhcPs
o) [(String, SrcSpan)]
sub String
tpl]
       in [forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
warn String
"Redundant lambda" (forall a e. LocatedAn a e -> Located e
reLoc LHsBind GhcPs
o) ([LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
gen [LPat GhcPs]
pats 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 GenLocated SrcSpanAnnA (HsExpr GhcPs)
origBody
    , forall (t :: * -> *) a. Foldable t => t a -> Int
length [GenLocated SrcSpanAnnA (Pat GhcPs)]
newPats forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length [LPat GhcPs]
pats, forall a. AllVars a => a -> [String]
pvars (forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [GenLocated SrcSpanAnnA (Pat GhcPs)]
newPats) [LPat GhcPs]
pats) forall a. Eq a => [a] -> [a] -> Bool
`disjoint` forall a. AllVars a => a -> [String]
varss HsLocalBinds GhcPs
bind
    = let ([(String, SrcSpan)]
sub, String
tpl) = 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 [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 GenLocated SrcSpanAnnA (HsExpr GhcPs)
origBody) ([LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
reform [GenLocated SrcSpanAnnA (Pat GhcPs)]
newPats GenLocated SrcSpanAnnA (HsExpr GhcPs)
newBody)
            [forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
rtype (forall a. Located a -> SrcSpan
toSS forall a b. (a -> b) -> a -> b
$ [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
reform [LPat GhcPs]
pats 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 = forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc1) (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc2)) forall a b. (a -> b) -> a -> b
$ forall p. XValD p -> HsBind p -> HsDecl p
ValD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$
             HsBindLR GhcPs GhcPs
origBind {fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches = forall p body.
XMG p body -> XRec p [LMatch p body] -> MatchGroup p body
MG Origin
Generated (forall a an. a -> LocatedAn an a
noLocA [forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p body.
XCMatch p body
-> HsMatchContext p -> [LPat p] -> GRHSs p body -> Match p body
Match forall ann. EpAnn ann
EpAnnNotUsed HsMatchContext GhcPs
ctxt [LPat GhcPs]
ps forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
emptyComments [forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS forall ann. EpAnn ann
EpAnnNotUsed [] LHsExpr GhcPs
b] forall a b. (a -> b) -> a -> b
$ forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds NoExtField
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 (forall a. a -> Maybe a
Just (GenLocated SrcSpanAnnN RdrName -> String
rdrNameStr LIdP GhcPs
funName)) [GenLocated SrcSpanAnnA (Pat GhcPs)]
newPats
              sub :: [(String, SrcSpan)]
sub = (String
"body", forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA GenLocated (SrcSpanAnn' a) e
newBody) forall a. a -> [a] -> [a]
: forall a b. [a] -> [b] -> [(a, b)]
zip [String]
vars (forall a b. (a -> b) -> [a] -> [b]
map forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA [GenLocated SrcSpanAnnA (Pat GhcPs)]
newPats)
              tpl :: String
tpl = forall a. Outputable a => a -> String
unsafePrettyPrint ([LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
reform [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 (forall a. [a] -> Maybe ([a], a)
unsnoc -> Just ([GenLocated SrcSpanAnnA (Pat GhcPs)]
ps, forall a b. View a b => a -> b
view -> PVar_ String
p)) (L SrcSpanAnnA
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
x (forall a b. View a b => a -> b
view -> Var_ String
y)))
    | String
p forall a. Eq a => a -> a -> Bool
== String
y
    , String
y forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall a. FreeVars a => a -> [String]
vars LHsExpr GhcPs
x
    , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LHsExpr GhcPs -> Bool
isQuasiQuoteExpr forall a b. (a -> b) -> a -> b
$ forall on. Uniplate on => on -> [on]
universe LHsExpr GhcPs
x
    = [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce [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 (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp 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?
    , forall a. Brackets a => a -> Bool
isAtom LHsExpr GhcPs
y
    , String -> Bool
allowLeftSection forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString OccName
f
    , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Bool
isTypeApp LHsExpr GhcPs
y
    = [forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
suggest String
"Use section" (forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
o) (forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
to) [Refactoring SrcSpan
r]]
    where
        to :: LHsExpr GhcPs
        to :: LHsExpr GhcPs
to = forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar forall a b. (a -> b) -> a -> b
$ forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
y LHsExpr GhcPs
oper
        r :: Refactoring SrcSpan
r = forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LHsExpr GhcPs
o) [(String
"x", forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LHsExpr GhcPs
y)] (String
"(x " forall a. [a] -> [a] -> [a]
++ forall a. Outputable a => a -> String
unsafePrettyPrint LIdP GhcPs
origf forall a. [a] -> [a] -> [a]
++ String
")")

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

lambdaExp Maybe (LHsExpr GhcPs)
p o :: LHsExpr GhcPs
o@(L SrcSpanAnnA
_ HsLam{})
    | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Bool
isLambda LHsExpr GhcPs
res
    , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LHsExpr GhcPs -> Bool
isQuasiQuoteExpr forall a b. (a -> b) -> a -> b
$ forall on. Uniplate on => on -> [on]
universe LHsExpr GhcPs
res
    , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ String
"runST" forall a. Ord a => a -> Set a -> Bool
`Set.member` forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map OccName -> String
occNameString (forall a. FreeVars a => a -> Set OccName
freeVars LHsExpr GhcPs
o)
    , let name :: String
name = String
"Avoid lambda" forall a. [a] -> [a] -> [a]
++ (if LHsExpr GhcPs -> Int
countRightSections LHsExpr GhcPs
res 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 forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
warn else forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
suggest) String
name (forall a e. LocatedAn a e -> Located e
reLoc GenLocated SrcSpanAnnA (HsExpr GhcPs)
from) (forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
res) (SrcSpan -> [Refactoring SrcSpan]
refact forall a b. (a -> b) -> a -> b
$ 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | L SrcSpanAnnA
_ (SectionR XSectionR GhcPs
_ (forall a b. View a b => a -> b
view -> Var_ String
_) LHsExpr GhcPs
_) <- forall on. Uniplate on => on -> [on]
universe LHsExpr 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)
    , forall (t :: * -> *) a. Foldable t => t a -> Bool
null (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?
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> Bool
isLambda) Maybe (LHsExpr GhcPs)
p =
    [forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
suggest String
"Collapse lambdas" (forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
o) (forall a e. LocatedAn a e -> Located e
reLoc ([LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [GenLocated SrcSpanAnnA (Pat GhcPs)]
pats GenLocated SrcSpanAnnA (HsExpr GhcPs)
body)) [forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LHsExpr 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 forall a. Maybe a
Nothing [GenLocated SrcSpanAnnA (Pat GhcPs)]
pats
      subts :: [(String, SrcSpan)]
subts = (String
"body", forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA GenLocated SrcSpanAnnA (HsExpr GhcPs)
body) forall a. a -> [a] -> [a]
: forall a b. [a] -> [b] -> [(a, b)]
zip [String]
vars (forall a b. (a -> b) -> [a] -> [b]
map forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA [GenLocated SrcSpanAnnA (Pat GhcPs)]
pats)
      template :: String
template = forall a. Outputable a => a -> String
unsafePrettyPrint ([LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [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 [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) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Eq a => a -> a -> Bool
==forall a. a -> Maybe a
Just String
x) 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
            , forall a. Ord a => a -> Set a -> Bool
Set.notMember String
x forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map OccName -> String
occNameString forall a b. (a -> b) -> a -> b
$ forall a. FreeVars a => a -> Set OccName
freeVars [HsTupArg GhcPs]
ys
            -> [(forall a. Outputable a => String -> Located a -> Located a -> Idea
suggestN String
"Use tuple-section" (forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
o) forall a b. (a -> b) -> a -> b
$ forall e. e -> Located e
noLoc forall a b. (a -> b) -> a -> b
$ forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple forall ann. EpAnn ann
EpAnnNotUsed (forall a b. (a -> b) -> [a] -> [b]
map HsTupArg GhcPs -> HsTupArg GhcPs
removeX [HsTupArg 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
_ (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 forall a. Eq a => a -> a -> Bool
== String
x'
            -- x must not be used in some other way inside the matches
            , forall a. Ord a => a -> Set a -> Bool
Set.notMember String
x forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map OccName -> String
occNameString forall a b. (a -> b) -> a -> b
$ Vars -> Set OccName
free forall a b. (a -> b) -> a -> b
$ 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 SrcSpanAnnL
_ [L SrcSpanAnnA
_ Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
oldmatch]))
                   | 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)
_)) -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GuardLStmt GhcPs]
stmts) (forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs (forall p body. Match p body -> GRHSs p body
m_grhss Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
oldmatch)) ->
                     let patLocs :: [SrcSpan]
patLocs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. SrcSpanAnn' a -> SrcSpan
locA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> l
getLoc) (forall p body. Match p body -> [LPat p]
m_pats Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
oldmatch)
                         bodyLocs :: [SrcSpan]
bodyLocs = 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) -> [forall a. SrcSpanAnn' a -> SrcSpan
locA (forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnA (HsExpr GhcPs)
body)])
                                        forall a b. (a -> b) -> a -> b
$ forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs (forall p body. Match p body -> GRHSs p body
m_grhss Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
oldmatch)
                         r :: [Refactoring SrcSpan]
r | forall a. [a] -> Bool
notNull [SrcSpan]
patLocs Bool -> Bool -> Bool
&& forall a. [a] -> Bool
notNull [SrcSpan]
bodyLocs =
                             let xloc :: SrcSpan
xloc = forall a. (a -> a -> a) -> [a] -> a
foldl1' SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans [SrcSpan]
patLocs
                                 yloc :: SrcSpan
yloc = forall a. (a -> a -> a) -> [a] -> a
foldl1' SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans [SrcSpan]
bodyLocs
                              in [ forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LHsExpr 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") forall a. [a] -> [a] -> [a]
++ String
" -> y")
                                 ]
                           | Bool
otherwise = []
                         needParens :: Bool
needParens = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (p :: Pass). IsPass p => PprPrec -> Pat (GhcPass p) -> Bool
patNeedsParens PprPrec
appPrec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) (forall p body. Match p body -> [LPat p]
m_pats Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
oldmatch)
                      in [ forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
suggest String
"Use lambda" (forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
o)
                             ( forall e. e -> Located e
noLoc forall a b. (a -> b) -> a -> b
$ forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
noExtField MatchGroup GhcPs (LHsExpr GhcPs)
oldMG
                                 { mg_alts :: XRec GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
mg_alts = forall a an. a -> LocatedAn an a
noLocA
                                     [ forall a an. a -> LocatedAn an a
noLocA Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
oldmatch
                                         { m_pats :: [LPat GhcPs]
m_pats = forall a b. (a -> b) -> [a] -> [b]
map forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
mkParPat forall a b. (a -> b) -> a -> b
$ forall p body. Match p body -> [LPat p]
m_pats Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
oldmatch
                                         , m_ctxt :: HsMatchContext GhcPs
m_ctxt = forall p. HsMatchContext p
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)))]
_) ->
                     [(forall a. Outputable a => String -> Located a -> Located a -> Idea
suggestN String
"Use lambda-case" (forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
o) forall a b. (a -> b) -> a -> b
$ forall e. e -> Located e
noLoc forall a b. (a -> b) -> a -> b
$ forall p.
XLamCase p
-> LamCaseVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase forall ann. EpAnn ann
EpAnnNotUsed LamCaseVariant
LamCase MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup)
                         {ideaNote :: [Note]
ideaNote=[String -> Note
RequiresExtension String
"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
_ (forall a b. View a b => a -> b
view -> Var_ String
x'))
            | String
x forall a. Eq a => a -> a -> Bool
== String
x' = forall id. XMissing id -> HsTupArg id
Missing 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
_ (forall a b. View a b => a -> b
view -> Var_ String
x)) = forall a. a -> Maybe a
Just String
x
        tupArgVar HsTupArg GhcPs
_ = 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)
fromLambda 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))) = (forall from to. Biplate from to => (to -> to) -> from -> from
transformBi ([String] -> Pat GhcPs -> Pat GhcPs
f forall a b. (a -> b) -> a -> b
$ forall a. AllVars a => a -> [String]
pvars [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps2) [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps1 forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps2, GenLocated SrcSpanAnnA (HsExpr GhcPs)
x)
    where f :: [String] -> Pat GhcPs -> Pat GhcPs
          f :: [String] -> Pat GhcPs -> Pat GhcPs
f [String]
bad (VarPat XVarPat GhcPs
_ (GenLocated SrcSpanAnnN RdrName -> String
rdrNameStr -> String
x))
              | String
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
bad = forall p. XWildPat p -> Pat p
WildPat 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 = (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> (Bool, LPat GhcPs) -> LPat GhcPs
munge [String]
vars [(Bool, GenLocated SrcSpanAnnA (Pat GhcPs))]
pats', [String]
vars)
  where
    (forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions -> Set String
used, [(Bool, GenLocated SrcSpanAnnA (Pat GhcPs))]
pats') = forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b. (a -> b) -> [a] -> [b]
map LPat GhcPs -> (Set String, (Bool, LPat GhcPs))
f [LPat GhcPs]
pats)

    -- Remove variables that occur in the function name or patterns with wildcards
    vars :: [String]
vars = forall a. (a -> Bool) -> [a] -> [a]
filter (\String
s -> String
s forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set String
used Bool -> Bool -> Bool
&& forall a. a -> Maybe a
Just String
s 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
      | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LPat GhcPs -> Bool
isWildPat (forall on. Uniplate on => on -> [on]
universe LPat GhcPs
p) =
          let used :: Set String
used = forall a. Ord a => [a] -> Set a
Set.fromList [GenLocated SrcSpanAnnN RdrName -> String
rdrNameStr LIdP GhcPs
name | (L SrcSpanAnnA
_ (VarPat XVarPat GhcPs
_ LIdP GhcPs
name)) <- forall on. Uniplate on => on -> [on]
universe LPat GhcPs
p]
           in (Set String
used, (Bool
True, LPat GhcPs
p))
      | Bool
otherwise = (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
_) = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
ploc (forall p. XVarPat p -> LIdP p -> Pat p
VarPat NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ OccName -> RdrName
mkRdrUnqual forall a b. (a -> b) -> a -> b
$ String -> OccName
mkVarOcc String
ident))