{-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-}

{-
    Find and match:

    mapM, foldM, forM, replicateM, sequence, zipWithM
    not at the last line of a do statement, or to the left of >>

    Use let x = y instead of x <- return y, unless x is contained
    within y, or bound more than once in that do block.

<TEST>
yes = do mapM print a; return b -- mapM_ print a
yes = do _ <- mapM print a; return b -- mapM_ print a
no = mapM print a
no = do foo ; mapM print a
yes = do (bar+foo) -- (bar+foo)
no = do bar ; foo
yes = do bar; a <- foo; return a -- do bar; foo
no = do bar; a <- foo; return b
yes = do x <- bar; x -- do join bar
no = do x <- bar; x; x
yes = do x <- bar; return (f x) -- do f <$> bar
yes = do x <- bar; return $ f x -- do f <$> bar
yes = do x <- bar; pure $ f x -- do f <$> bar
yes = do x <- bar; return $ f (g x) -- do f . g <$> bar
yes = do x <- bar; return (f $ g x) -- do f . g <$> bar
yes = do x <- bar $ baz; return (f $ g x)
no = do x <- bar; return (f x x)
{-# LANGUAGE RecursiveDo #-}; no = mdo hook <- mkTrigger pat (act >> rmHook hook) ; return hook
yes = do x <- return y; foo x -- @Suggestion do let x = y; foo x
yes = do x <- return $ y + z; foo x -- do let x = y + z; foo x
no = do x <- return x; foo x
no = do x <- return y; x <- return y; foo x
yes = do forM files $ \x -> return (); return () -- forM_ files $ \x -> return ()
yes = do if a then forM x y else return (); return 12 -- forM_ x y
yes = do case a of {_ -> forM x y; x:xs -> foo xs}; return () -- forM_ x y
foldM_ f a xs = foldM f a xs >> return ()
folder f a xs = foldM f a xs >> return () -- foldM_ f a xs
folder f a xs = foldM f a xs >>= \_ -> return () -- foldM_ f a xs
yes = mapM async ds >>= mapM wait >> return () -- mapM async ds >>= mapM_ wait
main = "wait" ~> do f a $ sleep 10
main = f $ do g a $ sleep 10 -- g a $ sleep 10
main = do f a $ sleep 10 -- f a $ sleep 10
main = do foo x; return 3; bar z -- do foo x; bar z
main = void $ forM_ f xs -- forM_ f xs
main = void $ forM f xs -- void $ forM_ f xs
main = do _ <- forM_ f xs; bar -- do forM_ f xs; bar
main = do bar; forM_ f xs; return () -- do bar; forM_ f xs
main = do a; when b c; return () -- do a; when b c
</TEST>
-}


module Hint.Monad(monadHint) where

import Control.Applicative
import Data.Tuple.Extra
import Data.Maybe
import Data.List.Extra
import Hint.Type
import Refact.Types
import qualified Refact.Types as R
import Prelude


badFuncs :: [[Char]]
badFuncs = ["mapM","foldM","forM","replicateM","sequence","zipWithM","traverse","for","sequenceA"]
unitFuncs :: [[Char]]
unitFuncs = ["when","unless","void"]


monadHint :: DeclHint
monadHint :: DeclHint
monadHint _ _ d :: Decl_
d = ((Maybe (Int, Exp_), Exp_) -> [Idea])
-> [(Maybe (Int, Exp_), Exp_)] -> [Idea]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Decl_ -> (Maybe (Int, Exp_), Exp_) -> [Idea]
monadExp Decl_
d) ([(Maybe (Int, Exp_), Exp_)] -> [Idea])
-> [(Maybe (Int, Exp_), Exp_)] -> [Idea]
forall a b. (a -> b) -> a -> b
$ Decl_ -> [(Maybe (Int, Exp_), Exp_)]
forall a. Data a => a -> [(Maybe (Int, Exp_), Exp_)]
universeParentExp Decl_
d

monadExp :: Decl_ -> (Maybe (Int, Exp_), Exp_) -> [Idea]
monadExp :: Decl_ -> (Maybe (Int, Exp_), Exp_) -> [Idea]
monadExp (Decl_ -> [Char]
forall a. Named a => a -> [Char]
fromNamed -> [Char]
decl) (parent :: Maybe (Int, Exp_)
parent, x :: Exp_
x) = case Exp_
x of
        (Exp_ -> App2
forall a b. View a b => a -> b
view -> App2 op :: Exp_
op x1 :: Exp_
x1 x2 :: Exp_
x2) | Exp_
op Exp_ -> [Char] -> Bool
forall a. Named a => a -> [Char] -> Bool
~= ">>" -> Exp_ -> [Idea]
f Exp_
x1
        (Exp_ -> App2
forall a b. View a b => a -> b
view -> App2 op :: Exp_
op x1 :: Exp_
x1 (Exp_ -> LamConst1
forall a b. View a b => a -> b
view -> LamConst1 _)) | Exp_
op Exp_ -> [Char] -> Bool
forall a. Named a => a -> [Char] -> Bool
~= ">>=" -> Exp_ -> [Idea]
f Exp_
x1
        App an :: S
an op :: Exp_
op x :: Exp_
x | Exp_
op Exp_ -> [Char] -> Bool
forall a. Named a => a -> [Char] -> Bool
~= "void" -> (Exp_ -> Exp_) -> Exp_ -> [Idea]
seenVoid (S -> Exp_ -> Exp_ -> Exp_
forall l. l -> Exp l -> Exp l -> Exp l
App S
an Exp_
op) Exp_
x
        InfixApp an :: S
an op :: Exp_
op dol :: QOp S
dol x :: Exp_
x | Exp_
op Exp_ -> [Char] -> Bool
forall a. Named a => a -> [Char] -> Bool
~= "void", QOp S -> Bool
isDol QOp S
dol -> (Exp_ -> Exp_) -> Exp_ -> [Idea]
seenVoid (S -> Exp_ -> QOp S -> Exp_ -> Exp_
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
InfixApp S
an Exp_
op QOp S
dol) Exp_
x
        Do an :: S
an [Qualifier _ y :: Exp_
y] -> [[Char] -> Exp_ -> Exp_ -> [Refactoring SrcSpan] -> Idea
forall (ast :: * -> *) a.
(Annotated ast, Pretty a, Pretty (ast S)) =>
[Char] -> ast S -> a -> [Refactoring SrcSpan] -> Idea
warn "Redundant do" Exp_
x Exp_
y [RType
-> SrcSpan -> [([Char], SrcSpan)] -> [Char] -> Refactoring SrcSpan
forall a. RType -> a -> [([Char], a)] -> [Char] -> Refactoring a
Replace RType
Expr (Exp_ -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS Exp_
x) [("y", Exp_ -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS Exp_
y)] "y"] | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe (Int, Exp_) -> Exp_ -> Bool
forall a l. (Eq a, Num a) => Maybe (a, Exp_) -> Exp l -> Bool
doOperator Maybe (Int, Exp_)
parent Exp_
y]
        Do an :: S
an xs :: [Stmt S]
xs ->
            ([Stmt S] -> Exp_) -> [Stmt S] -> [Idea]
monadSteps (S -> [Stmt S] -> Exp_
forall l. l -> [Stmt l] -> Exp l
Do S
an) [Stmt S]
xs [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++
            [[Char] -> Exp_ -> Exp_ -> [Refactoring SrcSpan] -> Idea
forall (ast :: * -> *) a.
(Annotated ast, Pretty a, Pretty (ast S)) =>
[Char] -> ast S -> a -> [Refactoring SrcSpan] -> Idea
suggest "Use let" Exp_
x (S -> [Stmt S] -> Exp_
forall l. l -> [Stmt l] -> Exp l
Do S
an [Stmt S]
y) [Refactoring SrcSpan]
rs | Just (y :: [Stmt S]
y, rs :: [Refactoring SrcSpan]
rs) <- [[Stmt S] -> Maybe ([Stmt S], [Refactoring SrcSpan])
monadLet [Stmt S]
xs]] [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++
            [[Idea]] -> [Idea]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Exp_ -> [Idea]
f Exp_
x | Qualifier _ x :: Exp_
x <- [Stmt S] -> [Stmt S]
forall a. [a] -> [a]
init [Stmt S]
xs] [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++
            [[Idea]] -> [Idea]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Exp_ -> [Idea]
f Exp_
x | Generator _ (PWildCard _) x :: Exp_
x <- [Stmt S] -> [Stmt S]
forall a. [a] -> [a]
init [Stmt S]
xs]
        _ -> []
    where
        f :: Exp_ -> [Idea]
f = [Char] -> (Exp_ -> Exp_) -> Exp_ -> [Idea]
monadNoResult [Char]
decl Exp_ -> Exp_
forall a. a -> a
id
        seenVoid :: (Exp_ -> Exp_) -> Exp_ -> [Idea]
seenVoid wrap :: Exp_ -> Exp_
wrap x :: Exp_
x = [Char] -> (Exp_ -> Exp_) -> Exp_ -> [Idea]
monadNoResult [Char]
decl Exp_ -> Exp_
wrap Exp_
x [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++ [[Char] -> Exp_ -> Exp_ -> [Refactoring SrcSpan] -> Idea
forall (ast :: * -> *) a.
(Annotated ast, Pretty a, Pretty (ast S)) =>
[Char] -> ast S -> a -> [Refactoring SrcSpan] -> Idea
warn "Redundant void" (Exp_ -> Exp_
wrap Exp_
x) Exp_
x [] | Exp_ -> Bool
returnsUnit Exp_
x]



-- Sometimes people write a * do a + b, to avoid brackets
doOperator :: Maybe (a, Exp_) -> Exp l -> Bool
doOperator (Just (1, InfixApp _ _ op :: QOp S
op _)) InfixApp{} | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ QOp S -> Bool
isDol QOp S
op = Bool
True
doOperator _ _ = Bool
False


returnsUnit :: Exp_ -> Bool
returnsUnit :: Exp_ -> Bool
returnsUnit (Paren _ x :: Exp_
x) = Exp_ -> Bool
returnsUnit Exp_
x
returnsUnit (App _ x :: Exp_
x _) = Exp_ -> Bool
returnsUnit Exp_
x
returnsUnit (InfixApp _ x :: Exp_
x op :: QOp S
op _) | QOp S -> Bool
isDol QOp S
op = Exp_ -> Bool
returnsUnit Exp_
x
returnsUnit (Var _ x :: QName S
x) = ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (QName S
x QName S -> [Char] -> Bool
forall a. Named a => a -> [Char] -> Bool
~=) ([[Char]] -> Bool) -> [[Char]] -> Bool
forall a b. (a -> b) -> a -> b
$ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ "_") [[Char]]
badFuncs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
unitFuncs
returnsUnit _ = Bool
False


-- see through Paren and down if/case etc
-- return the name to use in the hint, and the revised expression
monadNoResult :: String -> (Exp_ -> Exp_) -> Exp_ -> [Idea]
monadNoResult :: [Char] -> (Exp_ -> Exp_) -> Exp_ -> [Idea]
monadNoResult inside :: [Char]
inside wrap :: Exp_ -> Exp_
wrap (Paren l :: S
l x :: Exp_
x) = [Char] -> (Exp_ -> Exp_) -> Exp_ -> [Idea]
monadNoResult [Char]
inside (Exp_ -> Exp_
wrap (Exp_ -> Exp_) -> (Exp_ -> Exp_) -> Exp_ -> Exp_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S -> Exp_ -> Exp_
forall l. l -> Exp l -> Exp l
Paren S
l) Exp_
x
monadNoResult inside :: [Char]
inside wrap :: Exp_ -> Exp_
wrap (App l :: S
l x :: Exp_
x y :: Exp_
y) = [Char] -> (Exp_ -> Exp_) -> Exp_ -> [Idea]
monadNoResult [Char]
inside (\x :: Exp_
x -> Exp_ -> Exp_
wrap (Exp_ -> Exp_) -> Exp_ -> Exp_
forall a b. (a -> b) -> a -> b
$ S -> Exp_ -> Exp_ -> Exp_
forall l. l -> Exp l -> Exp l -> Exp l
App S
l Exp_
x Exp_
y) Exp_
x
monadNoResult inside :: [Char]
inside wrap :: Exp_ -> Exp_
wrap (InfixApp l :: S
l x :: Exp_
x op :: QOp S
op y :: Exp_
y)
    | QOp S -> Bool
isDol QOp S
op = [Char] -> (Exp_ -> Exp_) -> Exp_ -> [Idea]
monadNoResult [Char]
inside (\x :: Exp_
x -> Exp_ -> Exp_
wrap (Exp_ -> Exp_) -> Exp_ -> Exp_
forall a b. (a -> b) -> a -> b
$ S -> Exp_ -> QOp S -> Exp_ -> Exp_
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
InfixApp S
l Exp_
x QOp S
op Exp_
y) Exp_
x
    | QOp S
op QOp S -> [Char] -> Bool
forall a. Named a => a -> [Char] -> Bool
~= ">>=" = [Char] -> (Exp_ -> Exp_) -> Exp_ -> [Idea]
monadNoResult [Char]
inside (Exp_ -> Exp_
wrap (Exp_ -> Exp_) -> (Exp_ -> Exp_) -> Exp_ -> Exp_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S -> Exp_ -> QOp S -> Exp_ -> Exp_
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
InfixApp S
l Exp_
x QOp S
op) Exp_
y
monadNoResult inside :: [Char]
inside wrap :: Exp_ -> Exp_
wrap x :: Exp_
x
    | x2 :: [Char]
x2:_ <- ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Exp_
x Exp_ -> [Char] -> Bool
forall a. Named a => a -> [Char] -> Bool
~=) [[Char]]
badFuncs
    , let x3 :: [Char]
x3 = [Char]
x2 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ "_"
    = [[Char] -> Exp_ -> Exp_ -> [Refactoring SrcSpan] -> Idea
forall (ast :: * -> *) a.
(Annotated ast, Pretty a, Pretty (ast S)) =>
[Char] -> ast S -> a -> [Refactoring SrcSpan] -> Idea
warn ("Use " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x3) (Exp_ -> Exp_
wrap Exp_
x) (Exp_ -> Exp_
wrap (Exp_ -> Exp_) -> Exp_ -> Exp_
forall a b. (a -> b) -> a -> b
$ [Char] -> Exp_
forall a. Named a => [Char] -> a
toNamed [Char]
x3) [RType
-> SrcSpan -> [([Char], SrcSpan)] -> [Char] -> Refactoring SrcSpan
forall a. RType -> a -> [([Char], a)] -> [Char] -> Refactoring a
Replace RType
Expr (Exp_ -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS Exp_
x) [] [Char]
x3] | [Char]
inside [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
x3]
monadNoResult inside :: [Char]
inside wrap :: Exp_ -> Exp_
wrap (Exp_ -> ([Exp_], [Exp_] -> Exp_)
forall s. Exp s -> ([Exp s], [Exp s] -> Exp s)
replaceBranches -> (bs :: [Exp_]
bs, rewrap :: [Exp_] -> Exp_
rewrap)) =
    (Idea -> Idea) -> [Idea] -> [Idea]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: Idea
x -> Idea
x{ideaNote :: [Note]
ideaNote=[Note] -> [Note]
forall a. Ord a => [a] -> [a]
nubOrd ([Note] -> [Note]) -> [Note] -> [Note]
forall a b. (a -> b) -> a -> b
$ [Char] -> Note
Note "May require adding void to other branches" Note -> [Note] -> [Note]
forall a. a -> [a] -> [a]
: Idea -> [Note]
ideaNote Idea
x}) ([Idea] -> [Idea]) -> [Idea] -> [Idea]
forall a b. (a -> b) -> a -> b
$ [[Idea]] -> [Idea]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [[Char] -> (Exp_ -> Exp_) -> Exp_ -> [Idea]
monadNoResult [Char]
inside Exp_ -> Exp_
forall a. a -> a
id Exp_
b | Exp_
b <- [Exp_]
bs]


monadStep :: ([Stmt S] -> Exp_) -> [Stmt S] -> [Idea]

-- do return x; $2 ==> do $2
monadStep :: ([Stmt S] -> Exp_) -> [Stmt S] -> [Idea]
monadStep wrap :: [Stmt S] -> Exp_
wrap o :: [Stmt S]
o@(Qualifier _ (Exp_ -> Maybe ([Char], Exp_)
fromRet -> Just (ret :: [Char]
ret, _)):x :: Stmt S
x:xs :: [Stmt S]
xs) =
    [[Char] -> Exp_ -> Exp_ -> [Refactoring SrcSpan] -> Idea
forall (ast :: * -> *) a.
(Annotated ast, Pretty a, Pretty (ast S)) =>
[Char] -> ast S -> a -> [Refactoring SrcSpan] -> Idea
warn ("Redundant " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ret) ([Stmt S] -> Exp_
wrap [Stmt S]
o) ([Stmt S] -> Exp_
wrap ([Stmt S] -> Exp_) -> [Stmt S] -> Exp_
forall a b. (a -> b) -> a -> b
$ Stmt S
xStmt S -> [Stmt S] -> [Stmt S]
forall a. a -> [a] -> [a]
:[Stmt S]
xs) [RType -> SrcSpan -> Refactoring SrcSpan
forall a. RType -> a -> Refactoring a
Delete RType
Stmt (Stmt S -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS ([Stmt S] -> Stmt S
forall a. [a] -> a
head [Stmt S]
o))]]

-- do a <- $1; return a ==> do $1
monadStep wrap :: [Stmt S] -> Exp_
wrap o :: [Stmt S]
o@[g :: Stmt S
g@(Generator _ (PVar _ p :: Name S
p) x :: Exp_
x), q :: Stmt S
q@(Qualifier _ (Exp_ -> Maybe ([Char], Exp_)
fromRet -> Just (ret :: [Char]
ret, Var _ v :: QName S
v)))]
    | QName S -> [Char]
forall a. Named a => a -> [Char]
fromNamed QName S
v [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Name S -> [Char]
forall a. Named a => a -> [Char]
fromNamed Name S
p
    = [[Char] -> Exp_ -> Exp_ -> [Refactoring SrcSpan] -> Idea
forall (ast :: * -> *) a.
(Annotated ast, Pretty a, Pretty (ast S)) =>
[Char] -> ast S -> a -> [Refactoring SrcSpan] -> Idea
warn ("Redundant " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ret) ([Stmt S] -> Exp_
wrap [Stmt S]
o) ([Stmt S] -> Exp_
wrap [S -> Exp_ -> Stmt S
forall l. l -> Exp l -> Stmt l
Qualifier S
an Exp_
x])
            [RType
-> SrcSpan -> [([Char], SrcSpan)] -> [Char] -> Refactoring SrcSpan
forall a. RType -> a -> [([Char], a)] -> [Char] -> Refactoring a
Replace RType
Stmt (Stmt S -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS Stmt S
g) [("x", Exp_ -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS Exp_
x)] "x", RType -> SrcSpan -> Refactoring SrcSpan
forall a. RType -> a -> Refactoring a
Delete RType
Stmt (Stmt S -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS Stmt S
q)]]

-- do x <- $1; x; $2  ==> do join $1; $2
monadStep wrap :: [Stmt S] -> Exp_
wrap o :: [Stmt S]
o@(g :: Stmt S
g@(Generator _ (Pat S -> PVar_
forall a b. View a b => a -> b
view -> PVar_ p :: [Char]
p) x :: Exp_
x):q :: Stmt S
q@(Qualifier _ (Exp_ -> Var_
forall a b. View a b => a -> b
view -> Var_ v :: [Char]
v)):xs :: [Stmt S]
xs)
    | [Char]
p [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
v Bool -> Bool -> Bool
&& [Char]
v [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Stmt S] -> [[Char]]
forall a. AllVars a => a -> [[Char]]
varss [Stmt S]
xs
    = [[Char] -> Exp_ -> Exp_ -> [Refactoring SrcSpan] -> Idea
forall (ast :: * -> *) a.
(Annotated ast, Pretty a, Pretty (ast S)) =>
[Char] -> ast S -> a -> [Refactoring SrcSpan] -> Idea
warn "Use join" ([Stmt S] -> Exp_
wrap [Stmt S]
o) ([Stmt S] -> Exp_
wrap ([Stmt S] -> Exp_) -> [Stmt S] -> Exp_
forall a b. (a -> b) -> a -> b
$ S -> Exp_ -> Stmt S
forall l. l -> Exp l -> Stmt l
Qualifier S
an (Exp_ -> Exp_
forall l. (Data l, Default l) => Exp l -> Exp l
rebracket1 (Exp_ -> Exp_) -> Exp_ -> Exp_
forall a b. (a -> b) -> a -> b
$ S -> Exp_ -> Exp_ -> Exp_
forall l. l -> Exp l -> Exp l -> Exp l
App S
an ([Char] -> Exp_
forall a. Named a => [Char] -> a
toNamed "join") Exp_
x)Stmt S -> [Stmt S] -> [Stmt S]
forall a. a -> [a] -> [a]
:[Stmt S]
xs) [Refactoring SrcSpan]
r]
    where r :: [Refactoring SrcSpan]
r = [RType
-> SrcSpan -> [([Char], SrcSpan)] -> [Char] -> Refactoring SrcSpan
forall a. RType -> a -> [([Char], a)] -> [Char] -> Refactoring a
Replace RType
Stmt (Stmt S -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS Stmt S
g) [("x", Exp_ -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS Exp_
x)] "join x", RType -> SrcSpan -> Refactoring SrcSpan
forall a. RType -> a -> Refactoring a
Delete RType
Stmt (Stmt S -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS Stmt S
q)]

-- do _ <- <return ()>; $1 ==> do <return ()>; $1
monadStep wrap :: [Stmt S] -> Exp_
wrap o :: [Stmt S]
o@(Generator an :: S
an PWildCard{} x :: Exp_
x:rest :: [Stmt S]
rest)
    | Exp_ -> Bool
returnsUnit Exp_
x
    = [[Char] -> Exp_ -> Exp_ -> [Refactoring SrcSpan] -> Idea
forall (ast :: * -> *) a.
(Annotated ast, Pretty a, Pretty (ast S)) =>
[Char] -> ast S -> a -> [Refactoring SrcSpan] -> Idea
warn "Redundant variable capture" ([Stmt S] -> Exp_
wrap [Stmt S]
o) ([Stmt S] -> Exp_
wrap ([Stmt S] -> Exp_) -> [Stmt S] -> Exp_
forall a b. (a -> b) -> a -> b
$ S -> Exp_ -> Stmt S
forall l. l -> Exp l -> Stmt l
Qualifier S
an Exp_
x Stmt S -> [Stmt S] -> [Stmt S]
forall a. a -> [a] -> [a]
: [Stmt S]
rest) []]

-- do <return ()>; return ()
monadStep wrap :: [Stmt S] -> Exp_
wrap o :: [Stmt S]
o@[Qualifier an :: S
an x :: Exp_
x, Qualifier _ (Exp_ -> Maybe ([Char], Exp_)
fromRet -> Just (ret :: [Char]
ret, unit :: Exp_
unit))]
    | Exp_ -> Bool
returnsUnit Exp_
x, Exp_
unit Exp_ -> [Char] -> Bool
forall a. Named a => a -> [Char] -> Bool
~= "()"
    = [[Char] -> Exp_ -> Exp_ -> [Refactoring SrcSpan] -> Idea
forall (ast :: * -> *) a.
(Annotated ast, Pretty a, Pretty (ast S)) =>
[Char] -> ast S -> a -> [Refactoring SrcSpan] -> Idea
warn ("Redundant " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ret) ([Stmt S] -> Exp_
wrap [Stmt S]
o) ([Stmt S] -> Exp_
wrap ([Stmt S] -> Exp_) -> [Stmt S] -> Exp_
forall a b. (a -> b) -> a -> b
$ Int -> [Stmt S] -> [Stmt S]
forall a. Int -> [a] -> [a]
take 1 [Stmt S]
o) []]

-- do x <- $1; return $ f $ g x ==> f . g <$> x
monadStep wrap :: [Stmt S] -> Exp_
wrap
    o :: [Stmt S]
o@[g :: Stmt S
g@(Generator _ (Pat S -> PVar_
forall a b. View a b => a -> b
view -> PVar_ u :: [Char]
u) x :: Exp_
x)
      ,q :: Stmt S
q@(Qualifier _ (Exp_ -> ([Exp_], Exp_)
fromApplies -> (ret :: Exp_
ret:f :: Exp_
f:fs :: [Exp_]
fs, Exp_ -> Var_
forall a b. View a b => a -> b
view -> Var_ v :: [Char]
v)))]
        | Exp_ -> Bool
isReturn Exp_
ret, Exp_ -> Bool
notDol Exp_
x, [Char]
u [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
v, [Exp_] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp_]
fs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 3, (Exp_ -> Bool) -> [Exp_] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Exp_ -> Bool
isSimple (Exp_
fExp_ -> [Exp_] -> [Exp_]
forall a. a -> [a] -> [a]
:[Exp_]
fs), [Char]
v [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Exp_] -> [[Char]]
forall a. FreeVars a => a -> [[Char]]
vars (Exp_
fExp_ -> [Exp_] -> [Exp_]
forall a. a -> [a] -> [a]
:[Exp_]
fs)
        = [[Char] -> Exp_ -> Exp_ -> [Refactoring SrcSpan] -> Idea
forall (ast :: * -> *) a.
(Annotated ast, Pretty a, Pretty (ast S)) =>
[Char] -> ast S -> a -> [Refactoring SrcSpan] -> Idea
warn "Use <$>" ([Stmt S] -> Exp_
wrap [Stmt S]
o) ([Stmt S] -> Exp_
wrap [S -> Exp_ -> Stmt S
forall l. l -> Exp l -> Stmt l
Qualifier S
an (S -> Exp_ -> QOp S -> Exp_ -> Exp_
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
InfixApp S
an ((Exp_ -> Exp_ -> Exp_) -> Exp_ -> [Exp_] -> Exp_
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Exp_ -> QOp S -> Exp_ -> Exp_) -> QOp S -> Exp_ -> Exp_ -> Exp_
forall a b c. (a -> b -> c) -> b -> a -> c
flip (S -> Exp_ -> QOp S -> Exp_ -> Exp_
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
InfixApp S
an) ([Char] -> QOp S
forall a. Named a => [Char] -> a
toNamed ".")) Exp_
f [Exp_]
fs) ([Char] -> QOp S
forall a. Named a => [Char] -> a
toNamed "<$>") Exp_
x)])
            [RType
-> SrcSpan -> [([Char], SrcSpan)] -> [Char] -> Refactoring SrcSpan
forall a. RType -> a -> [([Char], a)] -> [Char] -> Refactoring a
Replace RType
Stmt (Stmt S -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS Stmt S
g) (("x", Exp_ -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS Exp_
x)([Char], SrcSpan) -> [([Char], SrcSpan)] -> [([Char], SrcSpan)]
forall a. a -> [a] -> [a]
:[[Char]] -> [SrcSpan] -> [([Char], SrcSpan)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Char]]
vs (Exp_ -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS (Exp_ -> SrcSpan) -> [Exp_] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp_
fExp_ -> [Exp_] -> [Exp_]
forall a. a -> [a] -> [a]
:[Exp_]
fs)) ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate " . " (Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
take ([Exp_] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp_]
fs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) [[Char]]
vs) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ " <$> x"), RType -> SrcSpan -> Refactoring SrcSpan
forall a. RType -> a -> Refactoring a
Delete RType
Stmt (Stmt S -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS Stmt S
q)]]
    where
        isSimple :: Exp_ -> Bool
isSimple (Exp_ -> [Exp_]
fromApps -> [Exp_]
xs) = (Exp_ -> Bool) -> [Exp_] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Exp_ -> Bool
forall a. Brackets a => a -> Bool
isAtom (Exp_
xExp_ -> [Exp_] -> [Exp_]
forall a. a -> [a] -> [a]
:[Exp_]
xs)
        vs :: [[Char]]
vs = ('f'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([Char] -> [Char]) -> (Integer -> [Char]) -> Integer -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> [Char]
forall a. Show a => a -> [Char]
show (Integer -> [Char]) -> [Integer] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [0..]
        notDol :: Exp_ -> Bool
notDol (InfixApp _ _ op :: QOp S
op _) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ QOp S -> Bool
isDol QOp S
op
        notDol _ = Bool
True

monadStep _ _ = []

-- Suggest removing a return
monadSteps :: ([Stmt S] -> Exp_) -> [Stmt S] -> [Idea]
monadSteps :: ([Stmt S] -> Exp_) -> [Stmt S] -> [Idea]
monadSteps wrap :: [Stmt S] -> Exp_
wrap (x :: Stmt S
x:xs :: [Stmt S]
xs) = ([Stmt S] -> Exp_) -> [Stmt S] -> [Idea]
monadStep [Stmt S] -> Exp_
wrap (Stmt S
xStmt S -> [Stmt S] -> [Stmt S]
forall a. a -> [a] -> [a]
:[Stmt S]
xs) [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++ ([Stmt S] -> Exp_) -> [Stmt S] -> [Idea]
monadSteps ([Stmt S] -> Exp_
wrap ([Stmt S] -> Exp_) -> ([Stmt S] -> [Stmt S]) -> [Stmt S] -> Exp_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stmt S
x Stmt S -> [Stmt S] -> [Stmt S]
forall a. a -> [a] -> [a]
:)) [Stmt S]
xs
monadSteps _ _ = []


-- | do ...; x <- return y; ... ==> do ...; let x = y; ...
monadLet :: [Stmt S] -> Maybe ([Stmt S], [Refactoring R.SrcSpan])
monadLet :: [Stmt S] -> Maybe ([Stmt S], [Refactoring SrcSpan])
monadLet xs :: [Stmt S]
xs = if [Refactoring SrcSpan] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Refactoring SrcSpan]
rs then Maybe ([Stmt S], [Refactoring SrcSpan])
forall a. Maybe a
Nothing else ([Stmt S], [Refactoring SrcSpan])
-> Maybe ([Stmt S], [Refactoring SrcSpan])
forall a. a -> Maybe a
Just ([Stmt S]
ys, [Refactoring SrcSpan]
rs)
    where
        (ys :: [Stmt S]
ys, [Maybe (Refactoring SrcSpan)] -> [Refactoring SrcSpan]
forall a. [Maybe a] -> [a]
catMaybes -> [Refactoring SrcSpan]
rs) = [(Stmt S, Maybe (Refactoring SrcSpan))]
-> ([Stmt S], [Maybe (Refactoring SrcSpan)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Stmt S, Maybe (Refactoring SrcSpan))]
 -> ([Stmt S], [Maybe (Refactoring SrcSpan)]))
-> [(Stmt S, Maybe (Refactoring SrcSpan))]
-> ([Stmt S], [Maybe (Refactoring SrcSpan)])
forall a b. (a -> b) -> a -> b
$ (Stmt S -> (Stmt S, Maybe (Refactoring SrcSpan)))
-> [Stmt S] -> [(Stmt S, Maybe (Refactoring SrcSpan))]
forall a b. (a -> b) -> [a] -> [b]
map Stmt S -> (Stmt S, Maybe (Refactoring SrcSpan))
mkLet [Stmt S]
xs
        vs :: [[Char]]
vs = (Pat S -> [[Char]]) -> [Pat S] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pat S -> [[Char]]
forall a. AllVars a => a -> [[Char]]
pvars [Pat S
p | Generator _ p :: Pat S
p _ <- [Stmt S]
xs]
        mkLet :: Stmt S -> (Stmt S, Maybe (Refactoring SrcSpan))
mkLet g :: Stmt S
g@(Generator _ v :: Pat S
v@(Pat S -> PVar_
forall a b. View a b => a -> b
view -> PVar_ p :: [Char]
p) (Exp_ -> Maybe ([Char], Exp_)
fromRet -> Just (_, y :: Exp_
y)))
            | [Char]
p [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Exp_ -> [[Char]]
forall a. FreeVars a => a -> [[Char]]
vars Exp_
y, [Char]
p [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char] -> [[Char]] -> [[Char]]
forall a. Eq a => a -> [a] -> [a]
delete [Char]
p [[Char]]
vs
            = (Pat S -> Exp_ -> Stmt S
template ([Char] -> Pat S
forall a. Named a => [Char] -> a
toNamed [Char]
p) Exp_
y, Refactoring SrcSpan -> Maybe (Refactoring SrcSpan)
forall a. a -> Maybe a
Just Refactoring SrcSpan
refact)
         where
            refact :: Refactoring SrcSpan
refact = RType
-> SrcSpan -> [([Char], SrcSpan)] -> [Char] -> Refactoring SrcSpan
forall a. RType -> a -> [([Char], a)] -> [Char] -> Refactoring a
Replace RType
Stmt (Stmt S -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS Stmt S
g) [("lhs", Pat S -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS Pat S
v), ("rhs", Exp_ -> SrcSpan
forall (a :: * -> *). Annotated a => a S -> SrcSpan
toSS Exp_
y)]
                      (Stmt S -> [Char]
forall a. Pretty a => a -> [Char]
prettyPrint (Stmt S -> [Char]) -> Stmt S -> [Char]
forall a b. (a -> b) -> a -> b
$ Pat S -> Exp_ -> Stmt S
template ([Char] -> Pat S
forall a. Named a => [Char] -> a
toNamed "lhs") ([Char] -> Exp_
forall a. Named a => [Char] -> a
toNamed "rhs"))
        mkLet x :: Stmt S
x = (Stmt S
x, Maybe (Refactoring SrcSpan)
forall a. Maybe a
Nothing)
        template :: Pat S -> Exp_ -> Stmt S
template lhs :: Pat S
lhs rhs :: Exp_
rhs = S -> Binds S -> Stmt S
forall l. l -> Binds l -> Stmt l
LetStmt S
an (Binds S -> Stmt S) -> Binds S -> Stmt S
forall a b. (a -> b) -> a -> b
$ S -> [Decl_] -> Binds S
forall l. l -> [Decl l] -> Binds l
BDecls S
an [S -> Pat S -> Rhs S -> Maybe (Binds S) -> Decl_
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l
PatBind S
an Pat S
lhs (S -> Exp_ -> Rhs S
forall l. l -> Exp l -> Rhs l
UnGuardedRhs S
an Exp_
rhs) Maybe (Binds S)
forall a. Maybe a
Nothing]


fromApplies :: Exp_ -> ([Exp_], Exp_)
fromApplies :: Exp_ -> ([Exp_], Exp_)
fromApplies (App _ f :: Exp_
f x :: Exp_
x) = ([Exp_] -> [Exp_]) -> ([Exp_], Exp_) -> ([Exp_], Exp_)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (Exp_
fExp_ -> [Exp_] -> [Exp_]
forall a. a -> [a] -> [a]
:) (([Exp_], Exp_) -> ([Exp_], Exp_))
-> ([Exp_], Exp_) -> ([Exp_], Exp_)
forall a b. (a -> b) -> a -> b
$ Exp_ -> ([Exp_], Exp_)
fromApplies (Exp_ -> Exp_
fromParen Exp_
x)
fromApplies (InfixApp _ f :: Exp_
f (QOp S -> Bool
isDol -> Bool
True) x :: Exp_
x) = ([Exp_] -> [Exp_]) -> ([Exp_], Exp_) -> ([Exp_], Exp_)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (Exp_
fExp_ -> [Exp_] -> [Exp_]
forall a. a -> [a] -> [a]
:) (([Exp_], Exp_) -> ([Exp_], Exp_))
-> ([Exp_], Exp_) -> ([Exp_], Exp_)
forall a b. (a -> b) -> a -> b
$ Exp_ -> ([Exp_], Exp_)
fromApplies Exp_
x
fromApplies x :: Exp_
x = ([], Exp_
x)


-- | Match @return x@ to @Just x@.
fromRet :: Exp_ -> Maybe (String, Exp_)
fromRet :: Exp_ -> Maybe ([Char], Exp_)
fromRet (Paren _ x :: Exp_
x) = Exp_ -> Maybe ([Char], Exp_)
fromRet Exp_
x
fromRet (InfixApp _ x :: Exp_
x y :: QOp S
y z :: Exp_
z) | QOp S -> Exp_
opExp QOp S
y Exp_ -> [Char] -> Bool
forall a. Named a => a -> [Char] -> Bool
~= "$" = Exp_ -> Maybe ([Char], Exp_)
fromRet (Exp_ -> Maybe ([Char], Exp_)) -> Exp_ -> Maybe ([Char], Exp_)
forall a b. (a -> b) -> a -> b
$ S -> Exp_ -> Exp_ -> Exp_
forall l. l -> Exp l -> Exp l -> Exp l
App S
an Exp_
x Exp_
z
fromRet (App _ x :: Exp_
x y :: Exp_
y) | Exp_ -> Bool
isReturn Exp_
x = ([Char], Exp_) -> Maybe ([Char], Exp_)
forall a. a -> Maybe a
Just (Exp_ -> [Char]
forall a. Pretty a => a -> [Char]
prettyPrint Exp_
x, Exp_
y)
fromRet _ = Maybe ([Char], Exp_)
forall a. Maybe a
Nothing