{-# LANGUAGE LambdaCase, PatternGuards, ViewPatterns #-}
module Hint.Lambda(lambdaHint) where
import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, suggestN, ideaNote)
import Util
import Data.List.Extra
import Data.Set (Set)
import qualified Data.Set as Set
import Refact.Types hiding (RType(Match))
import Data.Generics.Uniplate.DataOnly (universe, universeBi, transformBi)
import BasicTypes
import GHC.Hs
import OccName
import RdrName
import SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr (isTypeApp, isOpApp, isLambda, isQuasiQuote, isVar, isDol, strToVar)
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import GHC.Util.Brackets (isAtom)
import GHC.Util.FreeVars (free, allVars, freeVars, pvars, vars, varss)
import GHC.Util.HsExpr (allowLeftSection, allowRightSection, niceLambdaR, lambda)
import GHC.Util.View
lambdaHint :: DeclHint
lambdaHint :: DeclHint
lambdaHint Scope
_ ModuleEx
_ LHsDecl GhcPs
x
= ((Maybe (LHsExpr GhcPs), LHsExpr GhcPs) -> [Idea])
-> [(Maybe (LHsExpr GhcPs), LHsExpr GhcPs)] -> [Idea]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea])
-> (Maybe (LHsExpr GhcPs), LHsExpr GhcPs) -> [Idea]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
lambdaExp) (LHsDecl GhcPs -> [(Maybe (LHsExpr GhcPs), LHsExpr GhcPs)]
forall a b. (Data a, Data b) => a -> [(Maybe b, b)]
universeParentBi LHsDecl GhcPs
x)
[Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++ (LHsDecl GhcPs -> [Idea]) -> [LHsDecl GhcPs] -> [Idea]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LHsDecl GhcPs -> [Idea]
lambdaDecl (LHsDecl GhcPs -> [LHsDecl GhcPs]
forall on. Uniplate on => on -> [on]
universe LHsDecl GhcPs
x)
lambdaDecl :: LHsDecl GhcPs -> [Idea]
lambdaDecl :: LHsDecl GhcPs -> [Idea]
lambdaDecl
o :: LHsDecl GhcPs
o@(L SrcSpan
_ (ValD XValD GhcPs
_
origBind :: HsBind GhcPs
origBind@FunBind {fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = funName :: Located (IdP GhcPs)
funName@(L SrcSpan
loc1 IdP GhcPs
_), fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches =
MG {mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts =
L SrcSpan
_ [L SrcSpan
_ (Match XCMatch GhcPs (LHsExpr GhcPs)
_ ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs))
ctxt@(FunRhs Located (NameOrRdrName (IdP GhcPs))
_ LexicalFixity
Prefix SrcStrictness
_) [LPat GhcPs]
pats (GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
_ [L SrcSpan
_ (GRHS XCGRHS GhcPs (LHsExpr GhcPs)
_ [] origBody :: LHsExpr GhcPs
origBody@(L SrcSpan
loc2 HsExpr GhcPs
_))] LHsLocalBinds GhcPs
bind))]}}))
| L SrcSpan
_ (EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
noExtField) <- LHsLocalBinds GhcPs
bind
, LHsExpr GhcPs -> Bool
isLambda (LHsExpr GhcPs -> Bool) -> LHsExpr GhcPs -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
fromParen LHsExpr GhcPs
origBody
, [HsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Located (Pat GhcPs)] -> [HsExpr GhcPs]
forall from to. Biplate from to => from -> [to]
universeBi [LPat GhcPs]
[Located (Pat GhcPs)]
pats :: [HsExpr GhcPs])
= [String
-> LHsDecl GhcPs -> LHsDecl GhcPs -> [Refactoring SrcSpan] -> Idea
forall a b.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
String -> a -> b -> [Refactoring SrcSpan] -> Idea
warn String
"Redundant lambda" LHsDecl GhcPs
o ([LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
gen [LPat GhcPs]
pats LHsExpr GhcPs
origBody) [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Decl (LHsDecl GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSS LHsDecl GhcPs
o) [(String, SrcSpan)]
subts String
template]]
| [Located (Pat GhcPs)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Located (Pat GhcPs)]
pats2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Located (Pat GhcPs)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LPat GhcPs]
[Located (Pat GhcPs)]
pats, [Located (Pat GhcPs)] -> [String]
forall a. AllVars a => a -> [String]
pvars (Int -> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a. Int -> [a] -> [a]
drop ([Located (Pat GhcPs)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Located (Pat GhcPs)]
pats2) [LPat GhcPs]
[Located (Pat GhcPs)]
pats) [String] -> [String] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`disjoint` LHsLocalBinds GhcPs -> [String]
forall a. AllVars a => a -> [String]
varss LHsLocalBinds GhcPs
bind
= [String
-> LHsDecl GhcPs -> LHsDecl GhcPs -> [Refactoring SrcSpan] -> Idea
forall a b.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
String -> a -> b -> [Refactoring SrcSpan] -> Idea
warn String
"Eta reduce" ([LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
reform [LPat GhcPs]
pats LHsExpr GhcPs
origBody) ([LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
reform [LPat GhcPs]
[Located (Pat GhcPs)]
pats2 LHsExpr GhcPs
bod2)
[
]
]
where reform :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
reform :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
reform [LPat GhcPs]
ps LHsExpr GhcPs
b = SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsDecl GhcPs -> LHsDecl GhcPs) -> HsDecl GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
ValD NoExtField
XValD GhcPs
noExtField (HsBind GhcPs -> HsDecl GhcPs) -> HsBind GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$
HsBind GhcPs
origBind
{fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches = XMG GhcPs (LHsExpr GhcPs)
-> GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
-> Origin
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG NoExtField
XMG GhcPs (LHsExpr GhcPs)
noExtField (SrcSpanLess (GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)])
-> GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> LMatch GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> LMatch GhcPs (LHsExpr GhcPs))
-> SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> LMatch GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XCMatch GhcPs (LHsExpr GhcPs)
-> HsMatchContext (NameOrRdrName (IdP GhcPs))
-> [LPat GhcPs]
-> GRHSs GhcPs (LHsExpr GhcPs)
-> Match GhcPs (LHsExpr GhcPs)
forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noExtField HsMatchContext (NameOrRdrName (IdP GhcPs))
ctxt [LPat GhcPs]
ps (GRHSs GhcPs (LHsExpr GhcPs) -> Match GhcPs (LHsExpr GhcPs))
-> GRHSs GhcPs (LHsExpr GhcPs) -> Match GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XCGRHSs GhcPs (LHsExpr GhcPs)
-> [LGRHS GhcPs (LHsExpr GhcPs)]
-> LHsLocalBinds GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs NoExtField
XCGRHSs GhcPs (LHsExpr GhcPs)
noExtField [SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
-> LGRHS GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
-> LGRHS GhcPs (LHsExpr GhcPs))
-> SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
-> LGRHS GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcPs (LHsExpr GhcPs)
-> [GuardLStmt GhcPs]
-> LHsExpr GhcPs
-> GRHS GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS NoExtField
XCGRHS GhcPs (LHsExpr GhcPs)
noExtField [] LHsExpr GhcPs
b] (LHsLocalBinds GhcPs -> GRHSs GhcPs (LHsExpr GhcPs))
-> LHsLocalBinds GhcPs -> GRHSs GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsLocalBinds GhcPs) -> LHsLocalBinds GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsLocalBinds GhcPs) -> LHsLocalBinds GhcPs)
-> SrcSpanLess (LHsLocalBinds GhcPs) -> LHsLocalBinds GhcPs
forall a b. (a -> b) -> a -> b
$ XEmptyLocalBinds GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds NoExtField
XEmptyLocalBinds GhcPs GhcPs
noExtField]) Origin
Generated}
loc :: SrcSpan
loc = SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
loc1 SrcSpan
loc2
gen :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
gen :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
gen [LPat GhcPs]
ps = ([Located (Pat GhcPs)] -> LHsExpr GhcPs -> LHsDecl GhcPs)
-> ([Located (Pat GhcPs)], LHsExpr GhcPs) -> LHsDecl GhcPs
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
[Located (Pat GhcPs)] -> LHsExpr GhcPs -> LHsDecl GhcPs
reform (([Located (Pat GhcPs)], LHsExpr GhcPs) -> LHsDecl GhcPs)
-> (LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs))
-> LHsExpr GhcPs
-> LHsDecl GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs)
fromLambda (LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs))
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs
-> ([Located (Pat GhcPs)], LHsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [LPat GhcPs]
ps
([Located (Pat GhcPs)]
finalpats, LHsExpr GhcPs
body) = LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs)
fromLambda (LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs))
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs
-> ([Located (Pat GhcPs)], LHsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [LPat GhcPs]
pats (LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs))
-> LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs
origBody
([Located (Pat GhcPs)]
pats2, LHsExpr GhcPs
bod2) = [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce [LPat GhcPs]
pats LHsExpr GhcPs
origBody
([Located (Pat GhcPs)]
origPats, String
subtsVars) = Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], String)
mkOrigPats (String -> Maybe String
forall a. a -> Maybe a
Just (Located RdrName -> String
rdrNameStr Located (IdP GhcPs)
Located RdrName
funName)) [LPat GhcPs]
[Located (Pat GhcPs)]
finalpats
subts :: [(String, SrcSpan)]
subts = (String
"body", LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSS LHsExpr GhcPs
body) (String, SrcSpan) -> [(String, SrcSpan)] -> [(String, SrcSpan)]
forall a. a -> [a] -> [a]
: (Char -> SrcSpan -> (String, SrcSpan))
-> String -> [SrcSpan] -> [(String, SrcSpan)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Char
x SrcSpan
y -> ([Char
x],SrcSpan
y)) String
subtsVars ((Located (Pat GhcPs) -> SrcSpan)
-> [Located (Pat GhcPs)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map Located (Pat GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSS [Located (Pat GhcPs)]
finalpats)
template :: String
template = LHsDecl GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint ([LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs
reform [LPat GhcPs]
[Located (Pat GhcPs)]
origPats LHsExpr GhcPs
varBody)
lambdaDecl LHsDecl GhcPs
_ = []
etaReduce :: [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce :: [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce ([LPat GhcPs] -> Maybe ([Located (Pat GhcPs)], Located (Pat GhcPs))
forall a. [a] -> Maybe ([a], a)
unsnoc -> Just ([Located (Pat GhcPs)]
ps, Located (Pat GhcPs) -> PVar_
forall a b. View a b => a -> b
view -> PVar_ String
p)) (L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
x (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
y)))
| String
p String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y
, String
y String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` LHsExpr GhcPs -> [String]
forall a. FreeVars a => a -> [String]
vars LHsExpr GhcPs
x
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (LHsExpr GhcPs -> Bool) -> [LHsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LHsExpr GhcPs -> Bool
isQuasiQuote ([LHsExpr GhcPs] -> Bool) -> [LHsExpr GhcPs] -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LHsExpr GhcPs]
forall on. Uniplate on => on -> [on]
universe LHsExpr GhcPs
x
= [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce [LPat GhcPs]
[Located (Pat GhcPs)]
ps LHsExpr GhcPs
x
etaReduce [LPat GhcPs]
ps (L SrcSpan
loc (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
x (LHsExpr GhcPs -> Bool
isDol -> Bool
True) LHsExpr GhcPs
y)) = [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
etaReduce [LPat GhcPs]
ps (SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExtField
XApp GhcPs
noExtField LHsExpr GhcPs
x LHsExpr GhcPs
y))
etaReduce [LPat GhcPs]
ps LHsExpr GhcPs
x = ([LPat GhcPs]
ps, LHsExpr GhcPs
x)
lambdaExp :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
lambdaExp :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
lambdaExp Maybe (LHsExpr GhcPs)
_ o :: LHsExpr GhcPs
o@(L SrcSpan
_ (HsPar XPar GhcPs
_ (L SrcSpan
_ (HsApp XApp GhcPs
_ oper :: LHsExpr GhcPs
oper@(L SrcSpan
_ (HsVar XVar GhcPs
_ (L SrcSpan
_ (IdP GhcPs -> OccName
RdrName -> OccName
rdrNameOcc -> OccName
f)))) LHsExpr GhcPs
y))))
| OccName -> Bool
isSymOcc OccName
f
, LHsExpr GhcPs -> Bool
forall a. Brackets a => a -> Bool
isAtom LHsExpr GhcPs
y
, String -> Bool
allowLeftSection (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString OccName
f
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Bool
isTypeApp LHsExpr GhcPs
y =
[String -> LHsExpr GhcPs -> LHsExpr GhcPs -> Idea
forall a. (HasSrcSpan a, Outputable a) => String -> a -> a -> Idea
suggestN String
"Use section" LHsExpr GhcPs
o (LHsExpr GhcPs -> Idea) -> LHsExpr GhcPs -> Idea
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExtField
XPar GhcPs
noExtField (LHsExpr GhcPs -> HsExpr GhcPs) -> LHsExpr GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XSectionL GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL NoExtField
XSectionL GhcPs
noExtField LHsExpr GhcPs
y LHsExpr GhcPs
oper]
lambdaExp Maybe (LHsExpr GhcPs)
_ o :: LHsExpr GhcPs
o@(L SrcSpan
_ (HsPar XPar GhcPs
_ (LHsExpr GhcPs -> App2
forall a b. View a b => a -> b
view -> App2 (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
"flip") origf :: LHsExpr GhcPs
origf@(LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
f) LHsExpr GhcPs
y)))
| String -> Bool
allowRightSection String
f, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String
"(" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
f
= [String -> LHsExpr GhcPs -> LHsExpr GhcPs -> Idea
forall a. (HasSrcSpan a, Outputable a) => String -> a -> a -> Idea
suggestN String
"Use section" LHsExpr GhcPs
o (LHsExpr GhcPs -> Idea) -> LHsExpr GhcPs -> Idea
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExtField
XPar GhcPs
noExtField (LHsExpr GhcPs -> HsExpr GhcPs) -> LHsExpr GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XSectionR GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR NoExtField
XSectionR GhcPs
noExtField LHsExpr GhcPs
origf LHsExpr GhcPs
y]
lambdaExp Maybe (LHsExpr GhcPs)
p o :: LHsExpr GhcPs
o@(L SrcSpan
_ HsLam{})
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (LHsExpr GhcPs -> Bool) -> Maybe (LHsExpr GhcPs) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LHsExpr GhcPs -> Bool
isOpApp Maybe (LHsExpr GhcPs)
p
, (LHsExpr GhcPs
res, SrcSpan -> [Refactoring SrcSpan]
refact) <- [String]
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, SrcSpan -> [Refactoring SrcSpan])
niceLambdaR [] LHsExpr GhcPs
o
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Bool
isLambda LHsExpr GhcPs
res
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (LHsExpr GhcPs -> Bool) -> [LHsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LHsExpr GhcPs -> Bool
isQuasiQuote ([LHsExpr GhcPs] -> Bool) -> [LHsExpr GhcPs] -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LHsExpr GhcPs]
forall on. Uniplate on => on -> [on]
universe LHsExpr GhcPs
res
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String
"runST" String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` (OccName -> String) -> Set OccName -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map OccName -> String
occNameString (LHsExpr GhcPs -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars LHsExpr GhcPs
o)
, let name :: String
name = String
"Avoid lambda" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if LHsExpr GhcPs -> Int
countRightSections LHsExpr GhcPs
res Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> LHsExpr GhcPs -> Int
countRightSections LHsExpr GhcPs
o then String
" using `infix`" else String
"")
, let from :: LHsExpr GhcPs
from = case (Maybe (LHsExpr GhcPs)
p, LHsExpr GhcPs
res) of
(Just p :: LHsExpr GhcPs
p@(L SrcSpan
_ (HsPar XPar GhcPs
_ (L SrcSpan
_ HsLam{}))), L SrcSpan
_ HsPar{}) -> LHsExpr GhcPs
p
(Maybe (LHsExpr GhcPs), LHsExpr GhcPs)
_ -> LHsExpr GhcPs
o
= [(if LHsExpr GhcPs -> Bool
isVar LHsExpr GhcPs
res then String
-> LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring SrcSpan] -> Idea
forall a b.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
String -> a -> b -> [Refactoring SrcSpan] -> Idea
warn else String
-> LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring SrcSpan] -> Idea
forall a b.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
String -> a -> b -> [Refactoring SrcSpan] -> Idea
suggest) String
name LHsExpr GhcPs
from LHsExpr GhcPs
res (SrcSpan -> [Refactoring SrcSpan]
refact (SrcSpan -> [Refactoring SrcSpan])
-> SrcSpan -> [Refactoring SrcSpan]
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSS LHsExpr GhcPs
from)]
where
countRightSections :: LHsExpr GhcPs -> Int
countRightSections :: LHsExpr GhcPs -> Int
countRightSections LHsExpr GhcPs
x = [()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | L SrcSpan
_ (SectionR XSectionR GhcPs
_ (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
_) LHsExpr GhcPs
_) <- LHsExpr GhcPs -> [LHsExpr GhcPs]
forall on. Uniplate on => on -> [on]
universe LHsExpr GhcPs
x]
lambdaExp Maybe (LHsExpr GhcPs)
p o :: LHsExpr GhcPs
o@(SimpleLambda [LPat GhcPs]
origPats LHsExpr GhcPs
origBody)
| LHsExpr GhcPs -> Bool
isLambda (LHsExpr GhcPs -> LHsExpr GhcPs
fromParen LHsExpr GhcPs
origBody)
, [HsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Located (Pat GhcPs)] -> [HsExpr GhcPs]
forall from to. Biplate from to => from -> [to]
universeBi [LPat GhcPs]
[Located (Pat GhcPs)]
origPats :: [HsExpr GhcPs])
, Bool -> (LHsExpr GhcPs -> Bool) -> Maybe (LHsExpr GhcPs) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not (Bool -> Bool) -> (LHsExpr GhcPs -> Bool) -> LHsExpr GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> Bool
isLambda) Maybe (LHsExpr GhcPs)
p =
[String
-> LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring SrcSpan] -> Idea
forall a b.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
String -> a -> b -> [Refactoring SrcSpan] -> Idea
suggest String
"Collapse lambdas" LHsExpr GhcPs
o ([LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [LPat GhcPs]
[Located (Pat GhcPs)]
pats LHsExpr GhcPs
body) [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr (LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSS LHsExpr GhcPs
o) [(String, SrcSpan)]
subts String
template]]
where
([Located (Pat GhcPs)]
pats, LHsExpr GhcPs
body) = LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
fromLambda LHsExpr GhcPs
o
([Located (Pat GhcPs)]
oPats, String
subtsVars) = Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], String)
mkOrigPats Maybe String
forall a. Maybe a
Nothing [LPat GhcPs]
[Located (Pat GhcPs)]
pats
subts :: [(String, SrcSpan)]
subts = (String
"body", LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSS LHsExpr GhcPs
body) (String, SrcSpan) -> [(String, SrcSpan)] -> [(String, SrcSpan)]
forall a. a -> [a] -> [a]
: (Char -> SrcSpan -> (String, SrcSpan))
-> String -> [SrcSpan] -> [(String, SrcSpan)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Char
x SrcSpan
y -> ([Char
x],SrcSpan
y)) String
subtsVars ((Located (Pat GhcPs) -> SrcSpan)
-> [Located (Pat GhcPs)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map Located (Pat GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSS [Located (Pat GhcPs)]
pats)
template :: String
template = LHsExpr GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint ([LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [LPat GhcPs]
[Located (Pat GhcPs)]
oPats LHsExpr GhcPs
varBody)
lambdaExp Maybe (LHsExpr GhcPs)
_ o :: LHsExpr GhcPs
o@(SimpleLambda [LPat GhcPs -> PVar_
forall a b. View a b => a -> b
view -> PVar_ String
x] (L SrcSpan
_ HsExpr GhcPs
expr)) =
case HsExpr GhcPs
expr of
ExplicitTuple XExplicitTuple GhcPs
_ [LHsTupArg GhcPs]
args Boxity
boxity
| ([LHsTupArg GhcPs
_x], [LHsTupArg GhcPs]
ys) <- (LHsTupArg GhcPs -> Bool)
-> [LHsTupArg GhcPs] -> ([LHsTupArg GhcPs], [LHsTupArg GhcPs])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
==String -> Maybe String
forall a. a -> Maybe a
Just String
x) (Maybe String -> Bool)
-> (LHsTupArg GhcPs -> Maybe String) -> LHsTupArg GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsTupArg GhcPs -> Maybe String
tupArgVar) [LHsTupArg GhcPs]
args
, String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember String
x (Set String -> Bool) -> Set String -> Bool
forall a b. (a -> b) -> a -> b
$ (OccName -> String) -> Set OccName -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map OccName -> String
occNameString (Set OccName -> Set String) -> Set OccName -> Set String
forall a b. (a -> b) -> a -> b
$ [LHsTupArg GhcPs] -> Set OccName
forall a. FreeVars a => a -> Set OccName
freeVars [LHsTupArg GhcPs]
ys
-> [(String -> LHsExpr GhcPs -> LHsExpr GhcPs -> Idea
forall a. (HasSrcSpan a, Outputable a) => String -> a -> a -> Idea
suggestN String
"Use tuple-section" LHsExpr GhcPs
o (LHsExpr GhcPs -> Idea) -> LHsExpr GhcPs -> Idea
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XExplicitTuple GhcPs -> [LHsTupArg GhcPs] -> Boxity -> HsExpr GhcPs
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple NoExtField
XExplicitTuple GhcPs
noExtField ((LHsTupArg GhcPs -> LHsTupArg GhcPs)
-> [LHsTupArg GhcPs] -> [LHsTupArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LHsTupArg GhcPs -> LHsTupArg GhcPs
removeX [LHsTupArg GhcPs]
args) Boxity
boxity)
{ideaNote :: [Note]
ideaNote = [String -> Note
RequiresExtension String
"TupleSections"]}]
HsCase XCase GhcPs
_ (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
x') MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup
| String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
x'
, String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember String
x (Set String -> Bool) -> Set String -> Bool
forall a b. (a -> b) -> a -> b
$ (OccName -> String) -> Set OccName -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map OccName -> String
occNameString (Set OccName -> Set String) -> Set OccName -> Set String
forall a b. (a -> b) -> a -> b
$ Vars -> Set OccName
free (Vars -> Set OccName) -> Vars -> Set OccName
forall a b. (a -> b) -> a -> b
$ MatchGroup GhcPs (LHsExpr GhcPs) -> Vars
forall a. AllVars a => a -> Vars
allVars MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup
-> case MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup of
oldMG :: MatchGroup GhcPs (LHsExpr GhcPs)
oldMG@(MG XMG GhcPs (LHsExpr GhcPs)
_ (L SrcSpan
_ [L SrcSpan
_ Match GhcPs (LHsExpr GhcPs)
oldmatch]) Origin
_) ->
[String -> LHsExpr GhcPs -> LHsExpr GhcPs -> Idea
forall a. (HasSrcSpan a, Outputable a) => String -> a -> a -> Idea
suggestN String
"Use lambda" LHsExpr GhcPs
o (LHsExpr GhcPs -> Idea) -> LHsExpr GhcPs -> Idea
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XLam GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
XLam GhcPs
noExtField MatchGroup GhcPs (LHsExpr GhcPs)
oldMG
{ mg_alts :: GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
mg_alts = SrcSpanLess (GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)])
-> GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc
[SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> LMatch GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc Match GhcPs (LHsExpr GhcPs)
oldmatch
{ m_pats :: [LPat GhcPs]
m_pats = (Located (Pat GhcPs) -> Located (Pat GhcPs))
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map Located (Pat GhcPs) -> Located (Pat GhcPs)
forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
mkParPat ([Located (Pat GhcPs)] -> [Located (Pat GhcPs)])
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a b. (a -> b) -> a -> b
$ Match GhcPs (LHsExpr GhcPs) -> [LPat GhcPs]
forall p body. Match p body -> [LPat p]
m_pats Match GhcPs (LHsExpr GhcPs)
oldmatch
, m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs))
m_ctxt = HsMatchContext (NameOrRdrName (IdP GhcPs))
forall id. HsMatchContext id
LambdaExpr
}
] }
]
MG XMG GhcPs (LHsExpr GhcPs)
_ (L SrcSpan
_ [LMatch GhcPs (LHsExpr GhcPs)]
xs) Origin
_ ->
[(String -> LHsExpr GhcPs -> LHsExpr GhcPs -> Idea
forall a. (HasSrcSpan a, Outputable a) => String -> a -> a -> Idea
suggestN String
"Use lambda-case" LHsExpr GhcPs
o (LHsExpr GhcPs -> Idea) -> LHsExpr GhcPs -> Idea
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XLamCase GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
forall p. XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase NoExtField
XLamCase GhcPs
noExtField MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup)
{ideaNote :: [Note]
ideaNote=[String -> Note
RequiresExtension String
"LambdaCase"]}]
MatchGroup GhcPs (LHsExpr GhcPs)
_ -> []
HsExpr GhcPs
_ -> []
where
removeX :: LHsTupArg GhcPs -> LHsTupArg GhcPs
removeX :: LHsTupArg GhcPs -> LHsTupArg GhcPs
removeX arg :: LHsTupArg GhcPs
arg@(L SrcSpan
_ (Present XPresent GhcPs
_ (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
x')))
| String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
x' = SrcSpanLess (LHsTupArg GhcPs) -> LHsTupArg GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsTupArg GhcPs) -> LHsTupArg GhcPs)
-> SrcSpanLess (LHsTupArg GhcPs) -> LHsTupArg GhcPs
forall a b. (a -> b) -> a -> b
$ XMissing GhcPs -> HsTupArg GhcPs
forall id. XMissing id -> HsTupArg id
Missing NoExtField
XMissing GhcPs
noExtField
removeX LHsTupArg GhcPs
y = LHsTupArg GhcPs
y
tupArgVar :: LHsTupArg GhcPs -> Maybe String
tupArgVar :: LHsTupArg GhcPs -> Maybe String
tupArgVar (L SrcSpan
_ (Present XPresent GhcPs
_ (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
x))) = String -> Maybe String
forall a. a -> Maybe a
Just String
x
tupArgVar LHsTupArg GhcPs
_ = Maybe String
forall a. Maybe a
Nothing
lambdaExp Maybe (LHsExpr GhcPs)
_ LHsExpr GhcPs
_ = []
varBody :: LHsExpr GhcPs
varBody :: LHsExpr GhcPs
varBody = String -> LHsExpr GhcPs
strToVar String
"body"
fromLambda :: LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
fromLambda :: LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
fromLambda (SimpleLambda [LPat GhcPs]
ps1 (LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)
LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs)
fromLambda (LHsExpr GhcPs -> ([Located (Pat GhcPs)], LHsExpr GhcPs))
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs
-> ([Located (Pat GhcPs)], LHsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs
fromParen -> ([Located (Pat GhcPs)]
ps2,LHsExpr GhcPs
x))) = ((Pat GhcPs -> Pat GhcPs)
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi ([String] -> Pat GhcPs -> Pat GhcPs
f ([String] -> Pat GhcPs -> Pat GhcPs)
-> [String] -> Pat GhcPs -> Pat GhcPs
forall a b. (a -> b) -> a -> b
$ [Located (Pat GhcPs)] -> [String]
forall a. AllVars a => a -> [String]
pvars [Located (Pat GhcPs)]
ps2) [LPat GhcPs]
[Located (Pat GhcPs)]
ps1 [Located (Pat GhcPs)]
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Located (Pat GhcPs)]
ps2, LHsExpr GhcPs
x)
where f :: [String] -> Pat GhcPs -> Pat GhcPs
f :: [String] -> Pat GhcPs -> Pat GhcPs
f [String]
bad (VarPat XVarPat GhcPs
_ (Located (IdP GhcPs) -> String
Located RdrName -> String
rdrNameStr -> String
x))
| String
x String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
bad = XWildPat GhcPs -> Pat GhcPs
forall p. XWildPat p -> Pat p
WildPat NoExtField
XWildPat GhcPs
noExtField
f [String]
bad Pat GhcPs
x = Pat GhcPs
x
fromLambda LHsExpr GhcPs
x = ([], LHsExpr GhcPs
x)
mkOrigPats :: Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], [Char])
mkOrigPats :: Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], String)
mkOrigPats Maybe String
funName [LPat GhcPs]
pats = ((Char -> (Bool, Located (Pat GhcPs)) -> Located (Pat GhcPs))
-> String -> [(Bool, Located (Pat GhcPs))] -> [Located (Pat GhcPs)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Char -> (Bool, LPat GhcPs) -> LPat GhcPs
Char -> (Bool, Located (Pat GhcPs)) -> Located (Pat GhcPs)
munge String
subtsVars [(Bool, Located (Pat GhcPs))]
pats', String
subtsVars)
where
([Set Char] -> Set Char
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions -> Set Char
used, [(Bool, Located (Pat GhcPs))]
pats') = [(Set Char, (Bool, Located (Pat GhcPs)))]
-> ([Set Char], [(Bool, Located (Pat GhcPs))])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Located (Pat GhcPs) -> (Set Char, (Bool, Located (Pat GhcPs))))
-> [Located (Pat GhcPs)]
-> [(Set Char, (Bool, Located (Pat GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcPs -> (Set Char, (Bool, LPat GhcPs))
Located (Pat GhcPs) -> (Set Char, (Bool, Located (Pat GhcPs)))
f [LPat GhcPs]
[Located (Pat GhcPs)]
pats)
subtsVars :: String
subtsVars = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (\Char
c -> Char
c Char -> Set Char -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Char
used Bool -> Bool -> Bool
&& String -> Maybe String
forall a. a -> Maybe a
Just [Char
c] Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe String
funName) [Char
'a'..Char
'z']
f :: LPat GhcPs -> (Set Char, (Bool, LPat GhcPs))
f :: LPat GhcPs -> (Set Char, (Bool, LPat GhcPs))
f LPat GhcPs
p
| (Located (Pat GhcPs) -> Bool) -> [Located (Pat GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LPat GhcPs -> Bool
Located (Pat GhcPs) -> Bool
isWildPat (Located (Pat GhcPs) -> [Located (Pat GhcPs)]
forall on. Uniplate on => on -> [on]
universe LPat GhcPs
Located (Pat GhcPs)
p) =
let used :: Set Char
used = String -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList [Char
c | (L SrcSpan
_ (VarPat XVarPat GhcPs
_ (Located (IdP GhcPs) -> String
Located RdrName -> String
rdrNameStr -> [Char
c]))) <- Located (Pat GhcPs) -> [Located (Pat GhcPs)]
forall on. Uniplate on => on -> [on]
universe LPat GhcPs
Located (Pat GhcPs)
p]
in (Set Char
used, (Bool
True, LPat GhcPs
p))
| Bool
otherwise = (Set Char
forall a. Monoid a => a
mempty, (Bool
False, LPat GhcPs
p))
isWildPat :: LPat GhcPs -> Bool
isWildPat :: LPat GhcPs -> Bool
isWildPat = \case (L _ (WildPat _)) -> Bool
True; LPat GhcPs
_ -> Bool
False
munge :: Char -> (Bool, LPat GhcPs) -> LPat GhcPs
munge :: Char -> (Bool, LPat GhcPs) -> LPat GhcPs
munge Char
_ (Bool
True, LPat GhcPs
p) = LPat GhcPs
p
munge Char
ident (Bool
False, L ploc _) = SrcSpan -> Pat GhcPs -> Located (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
ploc (XVarPat GhcPs -> Located (IdP GhcPs) -> Pat GhcPs
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat NoExtField
XVarPat GhcPs
noExtField (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
ploc (RdrName -> Located RdrName) -> RdrName -> Located RdrName
forall a b. (a -> b) -> a -> b
$ OccName -> RdrName
mkRdrUnqual (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ String -> OccName
mkVarOcc [Char
ident]))