{-# 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 = print do 17 + 25
main = print do 17 -- 17
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 -- forM_ f xs
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 Hint.Type(DeclHint',Idea,ideaNote,warn',toSS',suggest',Note(Note))

import HsSyn
import SrcLoc
import BasicTypes
import TcEvidence
import RdrName
import OccName
import Bag
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import GHC.Util

import Data.Tuple.Extra
import Data.Maybe
import Data.List.Extra
import Refact.Types hiding (Match)
import qualified Refact.Types as R

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

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

monadExp :: LHsDecl GhcPs -> (Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs) -> [Idea]
monadExp :: LHsDecl GhcPs
-> (Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs) -> [Idea]
monadExp (LHsDecl GhcPs -> Maybe String
declName -> Maybe String
decl) (parent :: Maybe (Int, LHsExpr GhcPs)
parent, x :: LHsExpr GhcPs
x) =
  case LHsExpr GhcPs
x of
    (LHsExpr GhcPs -> App2'
forall a b. View' a b => a -> b
view' -> App2' op :: LHsExpr GhcPs
op x1 :: LHsExpr GhcPs
x1 x2 :: LHsExpr GhcPs
x2) | String -> LHsExpr GhcPs -> Bool
isTag ">>" LHsExpr GhcPs
op -> LHsExpr GhcPs -> [Idea]
f LHsExpr GhcPs
x1
    (LHsExpr GhcPs -> App2'
forall a b. View' a b => a -> b
view' -> App2' op :: LHsExpr GhcPs
op x1 :: LHsExpr GhcPs
x1 (LHsExpr GhcPs -> LamConst1'
forall a b. View' a b => a -> b
view' -> LamConst1' _)) | String -> LHsExpr GhcPs -> Bool
isTag ">>=" LHsExpr GhcPs
op -> LHsExpr GhcPs -> [Idea]
f LHsExpr GhcPs
x1
    (LL l :: SrcSpan
l (HsApp _ op x)) | String -> LHsExpr GhcPs -> Bool
isTag "void" LHsExpr GhcPs
op -> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
seenVoid (SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (HsExpr GhcPs -> LHsExpr GhcPs)
-> (LHsExpr GhcPs -> HsExpr GhcPs)
-> LHsExpr GhcPs
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExt
XApp GhcPs
noExt LHsExpr GhcPs
op) LHsExpr GhcPs
x
    (LL l :: SrcSpan
l (OpApp _ op dol x)) | String -> LHsExpr GhcPs -> Bool
isTag "void" LHsExpr GhcPs
op, LHsExpr GhcPs -> Bool
isDol LHsExpr GhcPs
dol -> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
seenVoid (SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (HsExpr GhcPs -> LHsExpr GhcPs)
-> (LHsExpr GhcPs -> HsExpr GhcPs)
-> LHsExpr GhcPs
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp NoExt
XOpApp GhcPs
noExt LHsExpr GhcPs
op LHsExpr GhcPs
dol) LHsExpr GhcPs
x
    (LL loc :: SrcSpan
loc (HsDo _ _ (LL _ [LL _ (BodyStmt _ y _ _ )]))) -> [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' "Redundant do" LHsExpr GhcPs
x LHsExpr GhcPs
y [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr (LHsExpr GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' LHsExpr GhcPs
x) [("y", LHsExpr GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' LHsExpr GhcPs
y)] "y"] | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool
forall a.
(Eq a, Num a) =>
Maybe (a, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool
doOperator Maybe (Int, LHsExpr GhcPs)
parent LHsExpr GhcPs
y]
    (LL loc :: SrcSpan
loc (HsDo _ DoExpr (L _ xs))) ->
      ([ExprLStmt GhcPs] -> LHsExpr GhcPs) -> [ExprLStmt GhcPs] -> [Idea]
monadSteps (SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (HsExpr GhcPs -> LHsExpr GhcPs)
-> ([ExprLStmt GhcPs] -> HsExpr GhcPs)
-> [ExprLStmt GhcPs]
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XDo GhcPs
-> HsStmtContext Name -> Located [ExprLStmt GhcPs] -> HsExpr GhcPs
forall p.
XDo p -> HsStmtContext Name -> Located [ExprLStmt p] -> HsExpr p
HsDo NoExt
XDo GhcPs
noExt HsStmtContext Name
forall id. HsStmtContext id
DoExpr (Located [ExprLStmt GhcPs] -> HsExpr GhcPs)
-> ([ExprLStmt GhcPs] -> Located [ExprLStmt GhcPs])
-> [ExprLStmt GhcPs]
-> HsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ExprLStmt GhcPs] -> Located [ExprLStmt GhcPs]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc) [ExprLStmt GhcPs]
xs [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++
      [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' "Use let" LHsExpr GhcPs
x (SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XDo GhcPs
-> HsStmtContext Name -> Located [ExprLStmt GhcPs] -> HsExpr GhcPs
forall p.
XDo p -> HsStmtContext Name -> Located [ExprLStmt p] -> HsExpr p
HsDo NoExt
XDo GhcPs
noExt HsStmtContext Name
forall id. HsStmtContext id
DoExpr (SrcSpanLess (Located [ExprLStmt GhcPs])
-> Located [ExprLStmt GhcPs]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [ExprLStmt GhcPs]
SrcSpanLess (Located [ExprLStmt GhcPs])
y)) :: LHsExpr GhcPs) [Refactoring SrcSpan]
rs | Just (y :: [ExprLStmt GhcPs]
y, rs :: [Refactoring SrcSpan]
rs) <- [[ExprLStmt GhcPs]
-> Maybe ([ExprLStmt GhcPs], [Refactoring SrcSpan])
monadLet [ExprLStmt GhcPs]
xs]] [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++
      [[Idea]] -> [Idea]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [LHsExpr GhcPs -> [Idea]
f LHsExpr GhcPs
x | (LL _ (BodyStmt _ x _ _)) <- [ExprLStmt GhcPs] -> [ExprLStmt GhcPs]
forall a. [a] -> [a]
init [ExprLStmt GhcPs]
xs] [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++
      [[Idea]] -> [Idea]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [LHsExpr GhcPs -> [Idea]
f LHsExpr GhcPs
x | (LL _ (BindStmt _ (LL _ WildPat{}) x _ _)) <- [ExprLStmt GhcPs] -> [ExprLStmt GhcPs]
forall a. [a] -> [a]
init [ExprLStmt GhcPs]
xs]
    _ -> []
  where
    f :: LHsExpr GhcPs -> [Idea]
f = String
-> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
monadNoResult (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "" Maybe String
decl) LHsExpr GhcPs -> LHsExpr GhcPs
forall a. a -> a
id
    seenVoid :: (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
seenVoid wrap :: LHsExpr GhcPs -> LHsExpr GhcPs
wrap x :: LHsExpr GhcPs
x = String
-> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
monadNoResult (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "" Maybe String
decl) LHsExpr GhcPs -> LHsExpr GhcPs
wrap LHsExpr GhcPs
x [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++ [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' "Redundant void" (LHsExpr GhcPs -> LHsExpr GhcPs
wrap LHsExpr GhcPs
x) LHsExpr GhcPs
x [] | LHsExpr GhcPs -> Bool
returnsUnit LHsExpr GhcPs
x]

-- Sometimes people write 'a * do a + b', to avoid brackets.
-- or using BlockArguments they can write 'a do a b'
doOperator :: (Eq a, Num a) => Maybe (a, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool
doOperator :: Maybe (a, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool
doOperator (Just (2, LL _ (OpApp _ _ op _ )))  (LL _ OpApp {}) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Bool
isDol LHsExpr GhcPs
op = Bool
True
doOperator (Just (1, LL _ HsApp{})) b :: LHsExpr GhcPs
b | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Bool
forall a. Brackets' a => a -> Bool
isAtom' LHsExpr GhcPs
b = Bool
True
doOperator _ _ = Bool
False

returnsUnit :: LHsExpr GhcPs -> Bool
returnsUnit :: LHsExpr GhcPs -> Bool
returnsUnit (LL _ (HsPar _ x)) = LHsExpr GhcPs -> Bool
returnsUnit LHsExpr GhcPs
x
returnsUnit (LL _ (HsApp _ x _)) = LHsExpr GhcPs -> Bool
returnsUnit LHsExpr GhcPs
x
returnsUnit (LL _ (OpApp _ x op _)) | LHsExpr GhcPs -> Bool
isDol LHsExpr GhcPs
op = LHsExpr GhcPs -> Bool
returnsUnit LHsExpr GhcPs
x
returnsUnit (LL _ (HsVar _ (L _ x))) = OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
IdP GhcPs
x) String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a. [a] -> [a] -> [a]
++ "_") [String]
badFuncs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
unitFuncs
returnsUnit _ = Bool
False

-- See through HsPar, and down HsIf/HsCase, return the name to use in
-- the hint, and the revised expression.
monadNoResult :: String -> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
monadNoResult :: String
-> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
monadNoResult inside :: String
inside wrap :: LHsExpr GhcPs -> LHsExpr GhcPs
wrap (LL l :: SrcSpan
l (HsPar _ x)) = String
-> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
monadNoResult String
inside (LHsExpr GhcPs -> LHsExpr GhcPs
wrap (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (HsExpr GhcPs -> LHsExpr GhcPs)
-> (LHsExpr GhcPs -> HsExpr GhcPs)
-> LHsExpr GhcPs
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExt
XPar GhcPs
noExt) LHsExpr GhcPs
x
monadNoResult inside :: String
inside wrap :: LHsExpr GhcPs -> LHsExpr GhcPs
wrap (LL l :: SrcSpan
l (HsApp _ x y)) = String
-> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
monadNoResult String
inside (\x :: LHsExpr GhcPs
x -> LHsExpr GhcPs -> LHsExpr GhcPs
wrap (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExt
XApp GhcPs
noExt LHsExpr GhcPs
x LHsExpr GhcPs
y)) LHsExpr GhcPs
x
monadNoResult inside :: String
inside wrap :: LHsExpr GhcPs -> LHsExpr GhcPs
wrap (LL l :: SrcSpan
l (OpApp _ x tag@(LL _ (HsVar _ (L _ op))) y))
    | LHsExpr GhcPs -> Bool
isDol LHsExpr GhcPs
tag = String
-> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
monadNoResult String
inside (\x :: LHsExpr GhcPs
x -> LHsExpr GhcPs -> LHsExpr GhcPs
wrap (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp NoExt
XOpApp GhcPs
noExt LHsExpr GhcPs
x LHsExpr GhcPs
tag LHsExpr GhcPs
y)) LHsExpr GhcPs
x
    | OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
IdP GhcPs
op) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ">>=" = String
-> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
monadNoResult String
inside (LHsExpr GhcPs -> LHsExpr GhcPs
wrap (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (HsExpr GhcPs -> LHsExpr GhcPs)
-> (LHsExpr GhcPs -> HsExpr GhcPs)
-> LHsExpr GhcPs
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp NoExt
XOpApp GhcPs
noExt LHsExpr GhcPs
x LHsExpr GhcPs
tag) LHsExpr GhcPs
y
monadNoResult inside :: String
inside wrap :: LHsExpr GhcPs -> LHsExpr GhcPs
wrap x :: LHsExpr GhcPs
x
    | x2 :: String
x2 : _ <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> LHsExpr GhcPs -> Bool
`isTag` LHsExpr GhcPs
x) [String]
badFuncs
    , let x3 :: String
x3 = String
x2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "_"
    = [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' ("Use " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x3) (LHsExpr GhcPs -> LHsExpr GhcPs
wrap LHsExpr GhcPs
x) (LHsExpr GhcPs -> LHsExpr GhcPs
wrap (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsExpr GhcPs
strToVar String
x3) [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr (LHsExpr GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' LHsExpr GhcPs
x) [] String
x3] | String
inside String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
x3]
monadNoResult inside :: String
inside wrap :: LHsExpr GhcPs -> LHsExpr GhcPs
wrap (LHsExpr GhcPs
-> ([LHsExpr GhcPs], [LHsExpr GhcPs] -> LHsExpr GhcPs)
replaceBranches' -> (bs :: [LHsExpr GhcPs]
bs, rewrap :: [LHsExpr GhcPs] -> LHsExpr GhcPs
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
$ String -> 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
        [String
-> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]
monadNoResult String
inside LHsExpr GhcPs -> LHsExpr GhcPs
forall a. a -> a
id LHsExpr GhcPs
b | LHsExpr GhcPs
b <- [LHsExpr GhcPs]
bs]

monadStep :: ([ExprLStmt GhcPs] -> LHsExpr GhcPs)
           -> [ExprLStmt GhcPs] -> [Idea]

-- Rewrite 'do return x; $2' as 'do $2'.
monadStep :: ([ExprLStmt GhcPs] -> LHsExpr GhcPs) -> [ExprLStmt GhcPs] -> [Idea]
monadStep wrap :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap os :: [ExprLStmt GhcPs]
os@(o :: ExprLStmt GhcPs
o@(LL _ (BodyStmt _ (fromRet -> Just (ret, _)) _ _ )) : xs :: [ExprLStmt GhcPs]
xs@(_:_))
  = [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' ("Redundant " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ret) ([ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap [ExprLStmt GhcPs]
os) ([ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap [ExprLStmt GhcPs]
xs) [RType -> SrcSpan -> Refactoring SrcSpan
forall a. RType -> a -> Refactoring a
Delete RType
Stmt (ExprLStmt GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' ExprLStmt GhcPs
o)]]

-- Rewrite 'do a <- $1; return a' as 'do $1'.
monadStep wrap :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap o :: [ExprLStmt GhcPs]
o@[ g :: ExprLStmt GhcPs
g@(LL _ (BindStmt _ (LL _ (VarPat _ (L _ p))) x _ _ ))
                  , q :: ExprLStmt GhcPs
q@(LL _ (BodyStmt _ (fromRet -> Just (ret, LL _ (HsVar _ (L _ v)))) _ _))]
  | OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
IdP GhcPs
p) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
IdP GhcPs
v)
  = [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' ("Redundant " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ret) ([ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap [ExprLStmt GhcPs]
o) ([ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap [SrcSpanLess (ExprLStmt GhcPs) -> ExprLStmt GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (ExprLStmt GhcPs) -> ExprLStmt GhcPs)
-> SrcSpanLess (ExprLStmt GhcPs) -> ExprLStmt GhcPs
forall a b. (a -> b) -> a -> b
$ XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
-> LHsExpr GhcPs
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt NoExt
XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
noExt LHsExpr GhcPs
x SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr])
      [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Stmt (ExprLStmt GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' ExprLStmt GhcPs
g) [("x", LHsExpr GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' LHsExpr GhcPs
x)] "x", RType -> SrcSpan -> Refactoring SrcSpan
forall a. RType -> a -> Refactoring a
Delete RType
Stmt (ExprLStmt GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' ExprLStmt GhcPs
q)]]

-- Suggest to use join. Rewrite 'do x <- $1; x; $2' as 'do join $1; $2'.
monadStep wrap :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap o :: [ExprLStmt GhcPs]
o@(g :: ExprLStmt GhcPs
g@(LL _ (BindStmt _ (view' -> PVar_' p) x _ _)):q :: ExprLStmt GhcPs
q@(LL _ (BodyStmt _ (view' -> Var_' v) _ _)):xs :: [ExprLStmt GhcPs]
xs)
  | String
p String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v Bool -> Bool -> Bool
&& String
v String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ExprLStmt GhcPs] -> [String]
forall a. AllVars' a => a -> [String]
varss' [ExprLStmt GhcPs]
xs
  = let app :: LHsExpr GhcPs
app = 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
$ XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExt
XApp GhcPs
noExt (String -> LHsExpr GhcPs
strToVar "join") LHsExpr GhcPs
x
        body :: ExprLStmt GhcPs
body = SrcSpanLess (ExprLStmt GhcPs) -> ExprLStmt GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (ExprLStmt GhcPs) -> ExprLStmt GhcPs)
-> SrcSpanLess (ExprLStmt GhcPs) -> ExprLStmt GhcPs
forall a b. (a -> b) -> a -> b
$ XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
-> LHsExpr GhcPs
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt NoExt
XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
noExt (LHsExpr GhcPs -> LHsExpr GhcPs
rebracket1' LHsExpr GhcPs
app) SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr
        stmts :: [ExprLStmt GhcPs]
stmts = ExprLStmt GhcPs
body ExprLStmt GhcPs -> [ExprLStmt GhcPs] -> [ExprLStmt GhcPs]
forall a. a -> [a] -> [a]
: [ExprLStmt GhcPs]
xs
    in [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' "Use join" ([ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap [ExprLStmt GhcPs]
o) ([ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap [ExprLStmt GhcPs]
stmts) [Refactoring SrcSpan]
r]
  where r :: [Refactoring SrcSpan]
r = [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Stmt (ExprLStmt GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' ExprLStmt GhcPs
g) [("x", LHsExpr GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' LHsExpr GhcPs
x)] "join x", RType -> SrcSpan -> Refactoring SrcSpan
forall a. RType -> a -> Refactoring a
Delete RType
Stmt (ExprLStmt GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' ExprLStmt GhcPs
q)]

-- Redundant variable capture. Rewrite 'do _ <- <return ()>; $1' as
-- 'do <return ()>; $1'.
monadStep wrap :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap (o :: ExprLStmt GhcPs
o@(LL loc :: SrcSpan
loc (BindStmt _ p x _ _)) : rest :: [ExprLStmt GhcPs]
rest)
    | Pat GhcPs -> Bool
isPWildCard' Pat GhcPs
p, LHsExpr GhcPs -> Bool
returnsUnit LHsExpr GhcPs
x
    = let body :: ExprLStmt GhcPs
body = SrcSpan -> SrcSpanLess (ExprLStmt GhcPs) -> ExprLStmt GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SrcSpanLess (ExprLStmt GhcPs) -> ExprLStmt GhcPs)
-> SrcSpanLess (ExprLStmt GhcPs) -> ExprLStmt GhcPs
forall a b. (a -> b) -> a -> b
$ XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
-> LHsExpr GhcPs
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt NoExt
XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
noExt LHsExpr GhcPs
x SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr :: ExprLStmt GhcPs
      in [String
-> ExprLStmt GhcPs
-> ExprLStmt GhcPs
-> [Refactoring SrcSpan]
-> Idea
forall a b.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
String -> a -> b -> [Refactoring SrcSpan] -> Idea
warn' "Redundant variable capture" ExprLStmt GhcPs
o ExprLStmt GhcPs
body []]

-- Redundant unit return : 'do <return ()>; return ()'.
monadStep
  wrap :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap o :: [ExprLStmt GhcPs]
o@[ LL _ (BodyStmt _ x _ _)
         , LL _ (BodyStmt _ (fromRet -> Just (ret, LL _ (HsVar _ (L _ unit)))) _ _)]
     | LHsExpr GhcPs -> Bool
returnsUnit LHsExpr GhcPs
x, OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
IdP GhcPs
unit) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "()"
  = [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' ("Redundant " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ret) ([ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap [ExprLStmt GhcPs]
o) ([ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap ([ExprLStmt GhcPs] -> LHsExpr GhcPs)
-> [ExprLStmt GhcPs] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ Int -> [ExprLStmt GhcPs] -> [ExprLStmt GhcPs]
forall a. Int -> [a] -> [a]
take 1 [ExprLStmt GhcPs]
o) []]

-- Rewrite 'do x <- $1; return $ f $ g x' as 'f . g <$> x'
monadStep wrap :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap
  o :: [ExprLStmt GhcPs]
o@[g :: ExprLStmt GhcPs
g@(LL _ (BindStmt _ (view' -> PVar_' u) x _ _))
    , q :: ExprLStmt GhcPs
q@(LL _ (BodyStmt _ (fromApplies -> (ret:f:fs, view' -> Var_' v)) _ _))]
  | LHsExpr GhcPs -> Bool
isReturn LHsExpr GhcPs
ret, LHsExpr GhcPs -> Bool
notDol LHsExpr GhcPs
x, String
u String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v, [LHsExpr GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsExpr GhcPs]
fs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 3, (LHsExpr GhcPs -> Bool) -> [LHsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LHsExpr GhcPs -> Bool
isSimple (LHsExpr GhcPs
f LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
: [LHsExpr GhcPs]
fs), String
v 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
f LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
: [LHsExpr GhcPs]
fs)
  =
      [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' "Use <$>" ([ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap [ExprLStmt GhcPs]
o) ([ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap [SrcSpanLess (ExprLStmt GhcPs) -> ExprLStmt GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (ExprLStmt GhcPs) -> ExprLStmt GhcPs)
-> SrcSpanLess (ExprLStmt GhcPs) -> ExprLStmt GhcPs
forall a b. (a -> b) -> a -> b
$ XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
-> LHsExpr GhcPs
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt NoExt
XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
noExt (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
$ XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp NoExt
XOpApp GhcPs
noExt ((LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\acc :: LHsExpr GhcPs
acc e :: LHsExpr GhcPs
e -> 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
$ XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp NoExt
XOpApp GhcPs
noExt LHsExpr GhcPs
acc (String -> LHsExpr GhcPs
strToVar ".") LHsExpr GhcPs
e) LHsExpr GhcPs
f [LHsExpr GhcPs]
fs) (String -> LHsExpr GhcPs
strToVar "<$>") LHsExpr GhcPs
x) SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr])
      [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Stmt (ExprLStmt GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' ExprLStmt GhcPs
g) (("x", LHsExpr GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' LHsExpr GhcPs
x)(String, SrcSpan) -> [(String, SrcSpan)] -> [(String, SrcSpan)]
forall a. a -> [a] -> [a]
:[String] -> [SrcSpan] -> [(String, SrcSpan)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
vs (LHsExpr GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' (LHsExpr GhcPs -> SrcSpan) -> [LHsExpr GhcPs] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcPs
fLHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
:[LHsExpr GhcPs]
fs)) (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate " . " (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take ([LHsExpr GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsExpr GhcPs]
fs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) [String]
vs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ " <$> x"), RType -> SrcSpan -> Refactoring SrcSpan
forall a. RType -> a -> Refactoring a
Delete RType
Stmt (ExprLStmt GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' ExprLStmt GhcPs
q)]]
  where
    isSimple :: LHsExpr GhcPs -> Bool
isSimple (LHsExpr GhcPs -> [LHsExpr GhcPs]
fromApps' -> [LHsExpr GhcPs]
xs) = (LHsExpr GhcPs -> Bool) -> [LHsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LHsExpr GhcPs -> Bool
forall a. Brackets' a => a -> Bool
isAtom' (LHsExpr GhcPs
x LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
: [LHsExpr GhcPs]
xs)
    vs :: [String]
vs = ('f'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Integer -> String) -> Integer -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> [Integer] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [0..]

    notDol :: LHsExpr GhcPs -> Bool
    notDol :: LHsExpr GhcPs -> Bool
notDol (LL _ (OpApp _ _ op _)) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Bool
isDol LHsExpr GhcPs
op
    notDol _ = Bool
True

monadStep _ _ = []

-- Suggest removing a return
monadSteps :: ([ExprLStmt GhcPs] -> LHsExpr GhcPs) -> [ExprLStmt GhcPs] -> [Idea]
monadSteps :: ([ExprLStmt GhcPs] -> LHsExpr GhcPs) -> [ExprLStmt GhcPs] -> [Idea]
monadSteps wrap :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap (x :: ExprLStmt GhcPs
x : xs :: [ExprLStmt GhcPs]
xs) = ([ExprLStmt GhcPs] -> LHsExpr GhcPs) -> [ExprLStmt GhcPs] -> [Idea]
monadStep [ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap (ExprLStmt GhcPs
x ExprLStmt GhcPs -> [ExprLStmt GhcPs] -> [ExprLStmt GhcPs]
forall a. a -> [a] -> [a]
: [ExprLStmt GhcPs]
xs) [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++ ([ExprLStmt GhcPs] -> LHsExpr GhcPs) -> [ExprLStmt GhcPs] -> [Idea]
monadSteps ([ExprLStmt GhcPs] -> LHsExpr GhcPs
wrap ([ExprLStmt GhcPs] -> LHsExpr GhcPs)
-> ([ExprLStmt GhcPs] -> [ExprLStmt GhcPs])
-> [ExprLStmt GhcPs]
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExprLStmt GhcPs
x ExprLStmt GhcPs -> [ExprLStmt GhcPs] -> [ExprLStmt GhcPs]
forall a. a -> [a] -> [a]
:)) [ExprLStmt GhcPs]
xs
monadSteps _ _ = []

-- | Rewrite 'do ...; x <- return y; ...' as 'do ...; let x = y; ...'.
monadLet :: [ExprLStmt GhcPs] -> Maybe ([ExprLStmt GhcPs], [Refactoring R.SrcSpan])
monadLet :: [ExprLStmt GhcPs]
-> Maybe ([ExprLStmt GhcPs], [Refactoring SrcSpan])
monadLet xs :: [ExprLStmt GhcPs]
xs = if [Refactoring SrcSpan] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Refactoring SrcSpan]
rs then Maybe ([ExprLStmt GhcPs], [Refactoring SrcSpan])
forall a. Maybe a
Nothing else ([ExprLStmt GhcPs], [Refactoring SrcSpan])
-> Maybe ([ExprLStmt GhcPs], [Refactoring SrcSpan])
forall a. a -> Maybe a
Just ([ExprLStmt GhcPs]
ys, [Refactoring SrcSpan]
rs)
  where
    (ys :: [ExprLStmt GhcPs]
ys, [Maybe (Refactoring SrcSpan)] -> [Refactoring SrcSpan]
forall a. [Maybe a] -> [a]
catMaybes -> [Refactoring SrcSpan]
rs) = [(ExprLStmt GhcPs, Maybe (Refactoring SrcSpan))]
-> ([ExprLStmt GhcPs], [Maybe (Refactoring SrcSpan)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(ExprLStmt GhcPs, Maybe (Refactoring SrcSpan))]
 -> ([ExprLStmt GhcPs], [Maybe (Refactoring SrcSpan)]))
-> [(ExprLStmt GhcPs, Maybe (Refactoring SrcSpan))]
-> ([ExprLStmt GhcPs], [Maybe (Refactoring SrcSpan)])
forall a b. (a -> b) -> a -> b
$ (ExprLStmt GhcPs -> (ExprLStmt GhcPs, Maybe (Refactoring SrcSpan)))
-> [ExprLStmt GhcPs]
-> [(ExprLStmt GhcPs, Maybe (Refactoring SrcSpan))]
forall a b. (a -> b) -> [a] -> [b]
map ExprLStmt GhcPs -> (ExprLStmt GhcPs, Maybe (Refactoring SrcSpan))
mkLet [ExprLStmt GhcPs]
xs
    vs :: [String]
vs = (Pat GhcPs -> [String]) -> [Pat GhcPs] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pat GhcPs -> [String]
forall a. AllVars' a => a -> [String]
pvars' [Pat GhcPs
p | (LL _ (BindStmt _ p _ _ _)) <- [ExprLStmt GhcPs]
xs]

    mkLet :: ExprLStmt GhcPs -> (ExprLStmt GhcPs, Maybe (Refactoring R.SrcSpan))
    mkLet :: ExprLStmt GhcPs -> (ExprLStmt GhcPs, Maybe (Refactoring SrcSpan))
mkLet g :: ExprLStmt GhcPs
g@(LL _ (BindStmt _ v@(view' -> PVar_' p) (fromRet -> Just (_, y)) _ _ ))
      | String
p 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
y, String
p String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String -> [String] -> [String]
forall a. Eq a => a -> [a] -> [a]
delete String
p [String]
vs
      = (String -> LHsExpr GhcPs -> ExprLStmt GhcPs
template String
p LHsExpr GhcPs
y, Refactoring SrcSpan -> Maybe (Refactoring SrcSpan)
forall a. a -> Maybe a
Just Refactoring SrcSpan
refact)
      where
        refact :: Refactoring SrcSpan
refact = RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Stmt (ExprLStmt GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' ExprLStmt GhcPs
g) [("lhs", Pat GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' Pat GhcPs
v), ("rhs", LHsExpr GhcPs -> SrcSpan
forall e. HasSrcSpan e => e -> SrcSpan
toSS' LHsExpr GhcPs
y)]
                      (ExprLStmt GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint (ExprLStmt GhcPs -> String) -> ExprLStmt GhcPs -> String
forall a b. (a -> b) -> a -> b
$ String -> LHsExpr GhcPs -> ExprLStmt GhcPs
template "lhs" (String -> LHsExpr GhcPs
strToVar "rhs"))
    mkLet x :: ExprLStmt GhcPs
x = (ExprLStmt GhcPs
x, Maybe (Refactoring SrcSpan)
forall a. Maybe a
Nothing)

    template :: String -> LHsExpr GhcPs -> ExprLStmt GhcPs
    template :: String -> LHsExpr GhcPs -> ExprLStmt GhcPs
template lhs :: String
lhs rhs :: LHsExpr GhcPs
rhs =
        let p :: Located (NameOrRdrName (IdP GhcPs))
p = SrcSpanLess (Located (NameOrRdrName (IdP GhcPs)))
-> Located (NameOrRdrName (IdP GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located (NameOrRdrName (IdP GhcPs)))
 -> Located (NameOrRdrName (IdP GhcPs)))
-> SrcSpanLess (Located (NameOrRdrName (IdP GhcPs)))
-> Located (NameOrRdrName (IdP GhcPs))
forall a b. (a -> b) -> a -> b
$ OccName -> RdrName
mkRdrUnqual (String -> OccName
mkVarOcc String
lhs)
            grhs :: LGRHS GhcPs (LHsExpr GhcPs)
grhs = SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
-> LGRHS GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XCGRHS GhcPs (LHsExpr GhcPs)
-> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS NoExt
XCGRHS GhcPs (LHsExpr GhcPs)
noExt [] LHsExpr GhcPs
rhs)
            grhss :: GRHSs GhcPs (LHsExpr GhcPs)
grhss = 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 NoExt
XCGRHSs GhcPs (LHsExpr GhcPs)
noExt [LGRHS GhcPs (LHsExpr GhcPs)
grhs] (SrcSpanLess (LHsLocalBinds GhcPs) -> LHsLocalBinds GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XEmptyLocalBinds GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds NoExt
XEmptyLocalBinds GhcPs GhcPs
noExt))
            match :: LMatch GhcPs (LHsExpr GhcPs)
match = 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))
-> [Pat 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 NoExt
XCMatch GhcPs (LHsExpr GhcPs)
noExt (Located (NameOrRdrName (IdP GhcPs))
-> LexicalFixity
-> SrcStrictness
-> HsMatchContext (NameOrRdrName (IdP GhcPs))
forall id.
Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id
FunRhs Located (NameOrRdrName (IdP GhcPs))
p LexicalFixity
Prefix SrcStrictness
NoSrcStrict) [] GRHSs GhcPs (LHsExpr GhcPs)
grhss
            fb :: LHsBindLR GhcPs GhcPs
fb = SrcSpanLess (LHsBindLR GhcPs GhcPs) -> LHsBindLR GhcPs GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsBindLR GhcPs GhcPs) -> LHsBindLR GhcPs GhcPs)
-> SrcSpanLess (LHsBindLR GhcPs GhcPs) -> LHsBindLR GhcPs GhcPs
forall a b. (a -> b) -> a -> b
$ XFunBind GhcPs GhcPs
-> Located (IdP GhcPs)
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> HsWrapper
-> [Tickish Id]
-> HsBindLR GhcPs GhcPs
forall idL idR.
XFunBind idL idR
-> Located (IdP idL)
-> MatchGroup idR (LHsExpr idR)
-> HsWrapper
-> [Tickish Id]
-> HsBindLR idL idR
FunBind NoExt
XFunBind GhcPs GhcPs
noExt Located (IdP GhcPs)
Located (NameOrRdrName (IdP GhcPs))
p (XMG GhcPs (LHsExpr GhcPs)
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
-> Origin
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG NoExt
XMG GhcPs (LHsExpr GhcPs)
noExt (SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [LMatch GhcPs (LHsExpr GhcPs)
match]) Origin
Generated) HsWrapper
WpHole []
            binds :: Bag (LHsBindLR GhcPs GhcPs)
binds = LHsBindLR GhcPs GhcPs -> Bag (LHsBindLR GhcPs GhcPs)
forall a. a -> Bag a
unitBag LHsBindLR GhcPs GhcPs
fb
            valBinds :: HsValBindsLR GhcPs GhcPs
valBinds = XValBinds GhcPs GhcPs
-> Bag (LHsBindLR GhcPs GhcPs)
-> [LSig GhcPs]
-> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds NoExt
XValBinds GhcPs GhcPs
noExt Bag (LHsBindLR GhcPs GhcPs)
binds []
            localBinds :: LHsLocalBinds GhcPs
localBinds = 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
$ XHsValBinds GhcPs GhcPs
-> HsValBindsLR GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds NoExt
XHsValBinds GhcPs GhcPs
noExt HsValBindsLR GhcPs GhcPs
valBinds
         in SrcSpanLess (ExprLStmt GhcPs) -> ExprLStmt GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (ExprLStmt GhcPs) -> ExprLStmt GhcPs)
-> SrcSpanLess (ExprLStmt GhcPs) -> ExprLStmt GhcPs
forall a b. (a -> b) -> a -> b
$ XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
-> LHsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt NoExt
XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
noExt LHsLocalBinds GhcPs
localBinds

fromApplies :: LHsExpr GhcPs -> ([LHsExpr GhcPs], LHsExpr GhcPs)
fromApplies :: LHsExpr GhcPs -> ([LHsExpr GhcPs], LHsExpr GhcPs)
fromApplies (LL _ (HsApp _ f x)) = ([LHsExpr GhcPs] -> [LHsExpr GhcPs])
-> ([LHsExpr GhcPs], LHsExpr GhcPs)
-> ([LHsExpr GhcPs], LHsExpr GhcPs)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (LHsExpr GhcPs
fLHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
:) (([LHsExpr GhcPs], LHsExpr GhcPs)
 -> ([LHsExpr GhcPs], LHsExpr GhcPs))
-> ([LHsExpr GhcPs], LHsExpr GhcPs)
-> ([LHsExpr GhcPs], LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> ([LHsExpr GhcPs], LHsExpr GhcPs)
fromApplies (LHsExpr GhcPs -> LHsExpr GhcPs
fromParen' LHsExpr GhcPs
x)
fromApplies (LL _ (OpApp _ f (isDol -> True) x)) = ([LHsExpr GhcPs] -> [LHsExpr GhcPs])
-> ([LHsExpr GhcPs], LHsExpr GhcPs)
-> ([LHsExpr GhcPs], LHsExpr GhcPs)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (LHsExpr GhcPs
fLHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
:) (([LHsExpr GhcPs], LHsExpr GhcPs)
 -> ([LHsExpr GhcPs], LHsExpr GhcPs))
-> ([LHsExpr GhcPs], LHsExpr GhcPs)
-> ([LHsExpr GhcPs], LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> ([LHsExpr GhcPs], LHsExpr GhcPs)
fromApplies LHsExpr GhcPs
x
fromApplies x :: LHsExpr GhcPs
x = ([], LHsExpr GhcPs
x)

fromRet :: LHsExpr GhcPs -> Maybe (String, LHsExpr GhcPs)
fromRet :: LHsExpr GhcPs -> Maybe (String, LHsExpr GhcPs)
fromRet (LL _ (HsPar _ x)) = LHsExpr GhcPs -> Maybe (String, LHsExpr GhcPs)
fromRet LHsExpr GhcPs
x
fromRet (LL _ (OpApp _ x (LL _ (HsVar _ (L _ y))) z)) | OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
IdP GhcPs
y) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "$" = LHsExpr GhcPs -> Maybe (String, LHsExpr GhcPs)
fromRet (LHsExpr GhcPs -> Maybe (String, LHsExpr GhcPs))
-> LHsExpr GhcPs -> Maybe (String, LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExt
XApp GhcPs
noExt LHsExpr GhcPs
x LHsExpr GhcPs
z)
fromRet (LL _ (HsApp _ x y)) | LHsExpr GhcPs -> Bool
isReturn LHsExpr GhcPs
x = (String, LHsExpr GhcPs) -> Maybe (String, LHsExpr GhcPs)
forall a. a -> Maybe a
Just (LHsExpr GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint LHsExpr GhcPs
x, LHsExpr GhcPs
y)
fromRet _ = Maybe (String, LHsExpr GhcPs)
forall a. Maybe a
Nothing