{-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-}
module Hint.Monad(monadHint) where
import Control.Applicative
import Data.Tuple.Extra
import Data.Maybe
import Data.List
import Hint.Type
import Refact.Types
import qualified Refact.Types as R
import Prelude
badFuncs = ["mapM","foldM","forM","replicateM","sequence","zipWithM","traverse","for","sequenceA"]
monadHint :: DeclHint
monadHint _ _ d = concatMap (monadExp d) $ universeParentExp d
monadExp :: Decl_ -> (Maybe (Int, Exp_), Exp_) -> [Idea]
monadExp decl (parent, x) = case x of
(view -> App2 op x1 x2) | op ~= ">>" -> f x1
(view -> App2 op x1 (view -> LamConst1 _)) | op ~= ">>=" -> f x1
Do _ xs -> [warn "Redundant return" x (Do an y) rs | Just (y, rs) <- [monadReturn xs]] ++
[warn "Use join" x (Do an y) rs | Just (y, rs) <- [monadJoin xs ['a'..'z']]] ++
[warn "Use <$>" x (Do an y) rs | Just (y, rs) <- [monadFmap xs]] ++
[warn "Redundant do" x y [Replace Expr (toSS x) [("y", toSS y)] "y"]
| [Qualifier _ y] <- [xs], not $ doOperator parent y] ++
[suggest "Use let" x (Do an y) rs | Just (y, rs) <- [monadLet xs]] ++
concat [f x | Qualifier _ x <- init xs] ++
concat [f x | Generator _ (PWildCard _) x <- init xs]
_ -> []
where
f x = [warn ("Use " ++ name) x y r | Just (name,y, r) <- [monadCall x], fromNamed decl /= name]
doOperator (Just (1, InfixApp _ _ op _)) InfixApp{} | not $ isDol op = True
doOperator _ _ = False
middle :: (b -> d) -> (a, b, c) -> (a, d, c)
middle f (a,b,c) = (a, f b, c)
monadCall :: Exp_ -> Maybe (String,Exp_, [Refactoring R.SrcSpan])
monadCall (Paren l x) = middle (Paren l) <$> monadCall x
monadCall (App l x y) = middle (\x -> App l x y) <$> monadCall x
monadCall (InfixApp l x op y)
| isDol op = middle (\x -> InfixApp l x op y) <$> monadCall x
| op ~= ">>=" = middle (InfixApp l x op) <$> monadCall y
monadCall (replaceBranches -> (bs@(_:_), gen)) | all isJust res
= Just ("Use simple functions", gen $ map (\(Just (a,b,c)) -> b) res, rs)
where res = map monadCall bs
rs = concatMap (\(Just (a,b,c)) -> c) res
monadCall x | x2:_ <- filter (x ~=) badFuncs = let x3 = x2 ++ "_" in Just (x3, toNamed x3, [Replace Expr (toSS x) [] x3])
monadCall _ = Nothing
monadFmap :: [Stmt S] -> Maybe ([Stmt S], [Refactoring R.SrcSpan])
monadFmap (reverse -> q@(Qualifier _ (let go (App _ f x) = first (f:) $ go (fromParen x)
go (InfixApp _ f (isDol -> True) x) = first (f:) $ go x
go x = ([], x)
in go -> (ret:f:fs, view -> Var_ v))):g@(Generator _ (view -> PVar_ u) x):rest)
| isReturn ret, notDol x, u == v, null rest, v `notElem` vars (f:fs)
= Just (reverse (Qualifier an (InfixApp an (foldl' (flip (InfixApp an) (toNamed ".")) f fs) (toNamed "<$>") x):rest),
[Replace Stmt (toSS g) (("x", toSS x):zip vs (toSS <$> f:fs)) (intercalate " . " (take (length fs + 1) vs) ++ " <$> x"), Delete Stmt (toSS q)])
where vs = ('f':) . show <$> [0..]
notDol (InfixApp _ _ op _) = not $ isDol op
notDol _ = True
monadFmap _ = Nothing
monadReturn :: [Stmt S] -> Maybe ([Stmt S], [Refactoring R.SrcSpan])
monadReturn (reverse -> q@(Qualifier _ (App _ ret (Var _ v))):g@(Generator _ (PVar _ p) x):rest)
| isReturn ret, fromNamed v == fromNamed p
= Just (reverse (Qualifier an x : rest),
[Replace Stmt (toSS g) [("x", toSS x)] "x", Delete Stmt (toSS q)])
monadReturn _ = Nothing
monadJoin :: [Stmt S] -> String -> Maybe ([Stmt S], [Refactoring R.SrcSpan])
monadJoin (g@(Generator _ (view -> PVar_ p) x):q@(Qualifier _ (view -> Var_ v)):xs) (c:cs)
| p == v && v `notElem` varss xs
= Just . f $ fromMaybe def (monadJoin xs cs)
where
gen expr = Qualifier (ann x) (rebracket1 $ App an (toNamed "join") expr)
def = (xs, [])
f (ss, rs) = (s:ss, r ++ rs)
s = gen x
r = [Replace Stmt (toSS g) [("x", toSS x)] "join x", Delete Stmt (toSS q)]
monadJoin (x:xs) cs = first (x:) <$> monadJoin xs cs
monadJoin [] _ = Nothing
monadLet :: [Stmt S] -> Maybe ([Stmt S], [Refactoring R.SrcSpan])
monadLet xs = if null rs then Nothing else Just (ys, rs)
where
(ys, catMaybes -> rs) = unzip $ map mkLet xs
vs = concatMap pvars [p | Generator _ p _ <- xs]
mkLet g@(Generator _ v@(view -> PVar_ p) (fromRet -> Just y))
| p `notElem` vars y, p `notElem` delete p vs
= (template (toNamed p) y, Just refact)
where
refact = Replace Stmt (toSS g) [("lhs", toSS v), ("rhs", toSS y)]
(prettyPrint $ template (toNamed "lhs") (toNamed "rhs"))
mkLet x = (x, Nothing)
template lhs rhs = LetStmt an $ BDecls an [PatBind an lhs (UnGuardedRhs an rhs) Nothing]
fromRet (Paren _ x) = fromRet x
fromRet (InfixApp _ x y z) | opExp y ~= "$" = fromRet $ App an x z
fromRet (App _ x y) | isReturn x = Just y
fromRet _ = Nothing