{-# LANGUAGE ViewPatterns, PatternGuards #-} {- Improve the structure of code yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e x `yes` y = if a then b else if c then d else e -- x `yes` y ; | a = b ; | c = d ; | otherwise = e no x y = if a then b else c -- foo b | c <- f b = c -- foo (f -> c) = c -- foo x y b z | c:cs <- f g b = c -- foo x y (f g -> c:cs) z = c foo b | c <- f b = c + b foo b | c <- f b = c where f = here foo b | c <- f b = c where foo = b foo b | c <- f b = c \ | c <- f b = c foo x = yes x x where yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e foo x | otherwise = y -- foo x = y foo x = x + x where -- foo x = x + x foo x | a = b | True = d -- foo x | a = b ; | otherwise = d foo (Bar _ _ _ _) = x -- Bar{} foo (Bar _ x _ _) = x foo (Bar _ _) = x foo = case f v of _ -> x -- x foo = case v of v -> x -- x foo = case v of z -> z foo = case v of _ | False -> x foo = case v of !True -> x -- True foo = case v of !(Just x) -> x -- (Just x) foo = case v of !(x : xs) -> x -- (x:xs) foo = case v of !1 -> x -- 1 foo = case v of !x -> x foo = case v of !(I# x) -> y -- (I# x) foo = let ~x = 1 in y -- x foo = let ~(x:xs) = y in z foo = let !x = undefined in y foo = let !(I# x) = 4 in x foo = let !(Just x) = Nothing in 3 foo = 1 where f !False = 2 -- False foo = 1 where !False = True foo = 1 where g (Just !True) = Nothing -- True foo = 1 where Just !True = Nothing foo otherwise = 1 -- _ foo ~x = y -- x {-# LANGUAGE Strict #-} foo ~x = y foo !(x, y) = x -- (x, y) foo ![x] = x -- [x] foo !Bar { bar = x } = x -- Bar { bar = x } l !(() :: ()) = x -- (() :: ()) -} module Hint.Pattern(patternHint) where import Hint.Type import Data.Function import Data.List.Extra import Data.Tuple import Data.Maybe import Data.Either import Refact.Types hiding (RType(Pattern, Match)) import qualified Refact.Types as R (RType(Pattern, Match), SrcSpan) patternHint :: DeclHint patternHint _ modu x = concatMap (uncurry hints . swap) (asPattern x) ++ -- PatBind (used in Let and Where) contains lazy-by-default patterns, everything else is strict concatMap (patHint strict False) (universeBi [p | PatBind _ p _ _ <- universe x]) ++ concatMap (patHint strict True) (universeBi \$ transform noPatBind x) ++ concatMap expHint (universeBi x) where noPatBind (PatBind a _ b c) = PatBind a (PWildCard a) b c noPatBind x = x strict = "Strict" `elem` [n | LanguagePragma _ ns <- modulePragmas modu, Ident _ n <- ns] hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea] hints gen (Pattern l rtype pat (UnGuardedRhs d bod) bind) | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GuardedRhss d guards) bind) [refactoring]] where rawGuards = asGuards bod mkGuard a = GuardedRhs an [Qualifier an a] guards = map (uncurry mkGuard) rawGuards (lhs, rhs) = unzip rawGuards mkTemplate c ps = -- Check if the expression has been injected or is natural let checkAn p v = if ann p == an then Left p else Right ( c ++ [v], toSS p) in zipWith checkAn ps ['1' .. '9'] patSubts = case pat of [p] -> [Left p] -- Substitution doesn't work properly for PatBinds -- This will probably produce -- unexpected results if the pattern -- contains any template variables ps -> mkTemplate "p100" ps guardSubts = mkTemplate "g100" lhs exprSubts = mkTemplate "e100" rhs templateGuards = zipWith (mkGuard `on` toString) guardSubts exprSubts toString (Left e) = e toString (Right (v, _)) = toNamed v template = fromMaybe "" \$ ideaTo (gen "" (Pattern l rtype (map toString patSubts) (GuardedRhss d templateGuards) bind) []) f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)] f = rights refactoring = Replace rtype (toRefactSrcSpan \$ srcInfoSpan l) (f patSubts ++ f guardSubts ++ f exprSubts) template {- -- Do not suggest view patterns, they aren't something everyone likes sufficiently hints gen (Pattern pats (GuardedRhss _ [GuardedRhs _ [Generator _ pat (App _ op (view -> Var_ p))] bod]) bind) | Just i <- findIndex (=~= (toNamed p :: Pat_)) pats , p `notElem` (vars bod ++ vars bind) , vars op `disjoint` decsBind, pvars pats `disjoint` vars op, pvars pat `disjoint` pvars pats = [gen "Use view patterns" \$ Pattern (take i pats ++ [PParen an \$ PViewPat an op pat] ++ drop (i+1) pats) (UnGuardedRhs an bod) bind] where decsBind = nub \$ concatMap declBind \$ childrenBi bind -} hints gen (Pattern l t pats (GuardedRhss _ [GuardedRhs _ [test] bod]) bind) | prettyPrint test `elem` ["otherwise","True"] = [gen "Redundant guard" (Pattern l t pats (UnGuardedRhs an bod) bind) [Delete Stmt (toSS test)]] hints gen (Pattern l t pats bod (Just bind)) | f bind = [gen "Redundant where" (Pattern l t pats bod Nothing) []] where f (BDecls _ x) = null x f (IPBinds _ x) = null x hints gen (Pattern l t pats (GuardedRhss _ (unsnoc -> Just (gs, GuardedRhs _ [test] bod))) bind) | prettyPrint test == "True" = [gen "Use otherwise" (Pattern l t pats (GuardedRhss an \$ gs ++ [GuardedRhs an [Qualifier an \$ toNamed "otherwise"] bod]) bind) [Replace Expr (toSS test) [] "otherwise"]] hints _ _ = [] asGuards :: Exp_ -> [(Exp S, Exp S)] asGuards (Paren _ x) = asGuards x asGuards (If _ a b c) = (a, b) : asGuards c asGuards x = [(toNamed "otherwise", x)] data Pattern = Pattern S R.RType [Pat_] (Rhs S) (Maybe (Binds S)) -- Invariant: Number of patterns may not change asPattern :: Decl_ -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)] asPattern x = concatMap decl (universeBi x) ++ concatMap alt (universeBi x) where decl o@(PatBind a pat rhs bind) = [(Pattern a Bind [pat] rhs bind, \msg (Pattern _ _ [pat] rhs bind) rs -> suggest msg o (PatBind a pat rhs bind) rs)] decl (FunBind _ xs) = map match xs decl _ = [] match o@(Match a b pat rhs bind) = (Pattern a R.Match pat rhs bind, \msg (Pattern _ _ pat rhs bind) rs -> suggest msg o (Match a b pat rhs bind) rs) match o@(InfixMatch a p b ps rhs bind) = (Pattern a R.Match (p:ps) rhs bind, \msg (Pattern _ _ (p:ps) rhs bind) rs -> suggest msg o (InfixMatch a p b ps rhs bind) rs) alt o@(Alt a pat rhs bind) = [(Pattern a R.Match [pat] rhs bind, \msg (Pattern _ _ [pat] rhs bind) rs -> suggest msg o (Alt a pat rhs bind) [])] -- First Bool is if Strict is a language extension -- Second Bool is if this pattern in this context is going to be evaluated strictly patHint :: Bool -> Bool -> Pat_ -> [Idea] patHint lang strict o@(PApp _ name args) | length args >= 3 && all isPWildCard args = [suggest "Use record patterns" o (PRec an name []) [Replace R.Pattern (toSS o) [] (prettyPrint \$ PRec an name [])] ] patHint lang strict o@(PVar _ v) | prettyPrint v == "otherwise" = [warn "Used otherwise as a pattern" o (PWildCard an) []] patHint lang strict o@(PBangPat _ x) | strict, f x = [warn "Redundant bang pattern" o x [r]] where f (PParen _ x) = f x f (PAsPat _ _ x) = f x f PLit{} = True f PApp{} = True f PInfixApp{} = True f PTuple{} = True f PList{} = True f PRec{} = True f (PatTypeSig _ x _) = f x f _ = False r = Replace R.Pattern (toSS o) [("x", toSS x)] "x" patHint False strict o@(PIrrPat _ x) | f x = [warn "Redundant irrefutable pattern" o x [r]] where f (PParen _ x) = f x f (PAsPat _ _ x) = f x f PWildCard{} = True f PVar{} = True f _ = False r = Replace R.Pattern (toSS o) [("x", toSS x)] "x" patHint _ _ _ = [] expHint :: Exp_ -> [Idea] expHint o@(Case _ _ [Alt _ PWildCard{} (UnGuardedRhs _ e) Nothing]) = [suggest "Redundant case" o e [r]] where r = Replace Expr (toSS o) [("x", toSS e)] "x" expHint o@(Case _ (Var _ x) [Alt _ (PVar _ y) (UnGuardedRhs _ e) Nothing]) | x =~= UnQual an y = [suggest "Redundant case" o e [r]] where r = Replace Expr (toSS o) [("x", toSS e)] "x" expHint _ = []