{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}

module GHC.Util.HsExpr (
    dotApps, lambda
  , simplifyExp, niceLambda, niceLambdaR
  , Brackets(..)
  , rebracket1, appsBracket, transformAppsM, fromApps, apps, universeApps, universeParentExp
  , paren
  , replaceBranches
  , needBracketOld, transformBracketOld, fromParen1
  , allowLeftSection, allowRightSection
) where

import GHC.Hs
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Data.FastString
import GHC.Types.Name.Reader
import GHC.Types.Name.Occurrence
import GHC.Data.Bag(bagToList)

import GHC.Util.Brackets
import GHC.Util.FreeVars
import GHC.Util.View

import Control.Applicative
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Control.Monad.Trans.Writer.CPS

import Data.Data
import Data.Generics.Uniplate.DataOnly
import Data.List.Extra
import Data.Tuple.Extra
import Data.Maybe

import Refact (substVars, toSS)
import Refact.Types hiding (SrcSpan, Match)
import qualified Refact.Types as R (SrcSpan)

import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader

-- | 'dotApp a b' makes 'a . b'.
dotApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
dotApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
dotApp LHsExpr GhcPs
x LHsExpr GhcPs
y = HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr 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 NoExtField
XOpApp GhcPs
noExtField LHsExpr GhcPs
x (HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcPs
noExtField (RdrName -> Located RdrName
forall e. e -> Located e
noLoc (RdrName -> Located RdrName) -> RdrName -> Located RdrName
forall a b. (a -> b) -> a -> b
$ FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"."))) LHsExpr GhcPs
y

dotApps :: [LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps :: [LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps [] = String -> LHsExpr GhcPs
forall a. HasCallStack => String -> a
error String
"GHC.Util.HsExpr.dotApps', does not work on an empty list"
dotApps [LHsExpr GhcPs
x] = LHsExpr GhcPs
x
dotApps (LHsExpr GhcPs
x : [LHsExpr GhcPs]
xs) = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
dotApp LHsExpr GhcPs
x ([LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps [LHsExpr GhcPs]
xs)

-- | @lambda [p0, p1..pn] body@ makes @\p1 p1 .. pn -> body@
lambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [LPat GhcPs]
vs LHsExpr GhcPs
body = HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr 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 (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 NoExtField
XMG GhcPs (LHsExpr GhcPs)
noExtField ([LMatch GhcPs (LHsExpr GhcPs)]
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
forall e. e -> Located e
noLoc [Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall e. e -> Located e
noLoc (Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs))
-> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XCMatch GhcPs (LHsExpr GhcPs)
-> HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> GRHSs GhcPs (LHsExpr GhcPs)
-> Match GhcPs (LHsExpr GhcPs)
forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noExtField HsMatchContext (NoGhcTc GhcPs)
forall p. HsMatchContext p
LambdaExpr [LPat GhcPs]
vs (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 [GRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
forall e. e -> Located e
noLoc (GRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs))
-> GRHS 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
body] (HsLocalBindsLR GhcPs GhcPs -> LHsLocalBinds GhcPs
forall e. e -> Located e
noLoc (HsLocalBindsLR GhcPs GhcPs -> LHsLocalBinds GhcPs)
-> HsLocalBindsLR GhcPs 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)

-- | 'paren e' wraps 'e' in parens if 'e' is non-atomic.
paren :: LHsExpr GhcPs -> LHsExpr GhcPs
paren :: LHsExpr GhcPs -> LHsExpr GhcPs
paren LHsExpr GhcPs
x
  | LHsExpr GhcPs -> Bool
forall a. Brackets a => a -> Bool
isAtom LHsExpr GhcPs
x  = LHsExpr GhcPs
x
  | Bool
otherwise = LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Brackets a => a -> a
addParen LHsExpr GhcPs
x

universeParentExp :: Data a => a -> [(Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)]
universeParentExp :: a -> [(Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)]
universeParentExp a
xs = [[(Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)]]
-> [(Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [(Maybe (Int, LHsExpr GhcPs)
forall a. Maybe a
Nothing, LHsExpr GhcPs
x) (Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)
-> [(Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)]
-> [(Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)]
forall a. a -> [a] -> [a]
: LHsExpr GhcPs -> [(Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)]
forall a t. (Enum a, Num a, Data t) => t -> [(Maybe (a, t), t)]
f LHsExpr GhcPs
x | LHsExpr GhcPs
x <- a -> [LHsExpr GhcPs]
forall from to. Biplate from to => from -> [to]
childrenBi a
xs]
    where f :: t -> [(Maybe (a, t), t)]
f t
p = [[(Maybe (a, t), t)]] -> [(Maybe (a, t), t)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [((a, t) -> Maybe (a, t)
forall a. a -> Maybe a
Just (a
i,t
p), t
c) (Maybe (a, t), t) -> [(Maybe (a, t), t)] -> [(Maybe (a, t), t)]
forall a. a -> [a] -> [a]
: t -> [(Maybe (a, t), t)]
f t
c | (a
i,t
c) <- a -> [t] -> [(a, t)]
forall a b. Enum a => a -> [b] -> [(a, b)]
zipFrom a
0 ([t] -> [(a, t)]) -> [t] -> [(a, t)]
forall a b. (a -> b) -> a -> b
$ t -> [t]
forall on. Uniplate on => on -> [on]
children t
p]


apps :: [LHsExpr GhcPs] -> LHsExpr GhcPs
apps :: [LHsExpr GhcPs] -> LHsExpr GhcPs
apps = (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs)
-> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall a. (a -> a -> a) -> [a] -> a
foldl1' LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall p.
(XApp p ~ NoExtField) =>
LHsExpr p -> LHsExpr p -> LHsExpr p
mkApp where mkApp :: LHsExpr p -> LHsExpr p -> LHsExpr p
mkApp LHsExpr p
x LHsExpr p
y = HsExpr p -> LHsExpr p
forall e. e -> Located e
noLoc (XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExtField
XApp p
noExtField LHsExpr p
x LHsExpr p
y)

fromApps :: LHsExpr GhcPs  -> [LHsExpr GhcPs]
fromApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]
fromApps (L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
x LHsExpr GhcPs
y)) = LHsExpr GhcPs -> [LHsExpr GhcPs]
fromApps LHsExpr GhcPs
x [LHsExpr GhcPs] -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsExpr GhcPs
y]
fromApps LHsExpr GhcPs
x = [LHsExpr GhcPs
x]

childrenApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]
childrenApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]
childrenApps (L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
x LHsExpr GhcPs
y)) = LHsExpr GhcPs -> [LHsExpr GhcPs]
childrenApps LHsExpr GhcPs
x [LHsExpr GhcPs] -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsExpr GhcPs
y]
childrenApps LHsExpr GhcPs
x = LHsExpr GhcPs -> [LHsExpr GhcPs]
forall on. Uniplate on => on -> [on]
children LHsExpr GhcPs
x

universeApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]
universeApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]
universeApps LHsExpr GhcPs
x = LHsExpr GhcPs
x LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
: (LHsExpr GhcPs -> [LHsExpr GhcPs])
-> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LHsExpr GhcPs -> [LHsExpr GhcPs]
universeApps (LHsExpr GhcPs -> [LHsExpr GhcPs]
childrenApps LHsExpr GhcPs
x)

descendAppsM :: Monad m => (LHsExpr GhcPs  -> m (LHsExpr GhcPs)) -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
descendAppsM :: (LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr GhcPs)
descendAppsM LHsExpr GhcPs -> m (LHsExpr GhcPs)
f (L SrcSpan
l (HsApp XApp GhcPs
_ LHsExpr GhcPs
x LHsExpr GhcPs
y)) = (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs)
-> m (LHsExpr GhcPs) -> m (LHsExpr GhcPs) -> m (LHsExpr GhcPs)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\LHsExpr GhcPs
x LHsExpr GhcPs
y -> SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr 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 NoExtField
XApp GhcPs
noExtField LHsExpr GhcPs
x LHsExpr GhcPs
y) ((LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr GhcPs)
forall (m :: * -> *).
Monad m =>
(LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr GhcPs)
descendAppsM LHsExpr GhcPs -> m (LHsExpr GhcPs)
f LHsExpr GhcPs
x) (LHsExpr GhcPs -> m (LHsExpr GhcPs)
f LHsExpr GhcPs
y)
descendAppsM LHsExpr GhcPs -> m (LHsExpr GhcPs)
f LHsExpr GhcPs
x = (LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr GhcPs)
forall on (m :: * -> *).
(Uniplate on, Applicative m) =>
(on -> m on) -> on -> m on
descendM LHsExpr GhcPs -> m (LHsExpr GhcPs)
f LHsExpr GhcPs
x

transformAppsM :: Monad m => (LHsExpr GhcPs -> m (LHsExpr GhcPs)) -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
transformAppsM :: (LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr GhcPs)
transformAppsM LHsExpr GhcPs -> m (LHsExpr GhcPs)
f LHsExpr GhcPs
x = LHsExpr GhcPs -> m (LHsExpr GhcPs)
f (LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> m (LHsExpr GhcPs) -> m (LHsExpr GhcPs)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr GhcPs)
forall (m :: * -> *).
Monad m =>
(LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr GhcPs)
descendAppsM ((LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr GhcPs)
forall (m :: * -> *).
Monad m =>
(LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr GhcPs)
transformAppsM LHsExpr GhcPs -> m (LHsExpr GhcPs)
f) LHsExpr GhcPs
x

descendIndex :: Data a => (Int -> a -> a) -> a -> a
descendIndex :: (Int -> a -> a) -> a -> a
descendIndex Int -> a -> a
f = (a, ()) -> a
forall a b. (a, b) -> a
fst ((a, ()) -> a) -> (a -> (a, ())) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> a -> Writer () a) -> a -> (a, ())
forall a w.
(Data a, Monoid w) =>
(Int -> a -> Writer w a) -> a -> (a, w)
descendIndex' (\Int
x a
a -> (a, ()) -> Writer () a
forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
(a, w) -> WriterT w m a
writer (Int -> a -> a
f Int
x a
a, ()))

descendIndex' :: (Data a, Monoid w) => (Int -> a -> Writer w a) -> a -> (a, w)
descendIndex' :: (Int -> a -> Writer w a) -> a -> (a, w)
descendIndex' Int -> a -> Writer w a
f a
x = Writer w a -> (a, w)
forall w a. Monoid w => Writer w a -> (a, w)
runWriter (Writer w a -> (a, w)) -> Writer w a -> (a, w)
forall a b. (a -> b) -> a -> b
$ (StateT Int (WriterT w Identity) a -> Int -> Writer w a)
-> Int -> StateT Int (WriterT w Identity) a -> Writer w a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Int (WriterT w Identity) a -> Int -> Writer w a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Int
0 (StateT Int (WriterT w Identity) a -> Writer w a)
-> StateT Int (WriterT w Identity) a -> Writer w a
forall a b. (a -> b) -> a -> b
$ ((a -> StateT Int (WriterT w Identity) a)
 -> a -> StateT Int (WriterT w Identity) a)
-> a
-> (a -> StateT Int (WriterT w Identity) a)
-> StateT Int (WriterT w Identity) a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> StateT Int (WriterT w Identity) a)
-> a -> StateT Int (WriterT w Identity) a
forall on (m :: * -> *).
(Uniplate on, Applicative m) =>
(on -> m on) -> on -> m on
descendM a
x ((a -> StateT Int (WriterT w Identity) a)
 -> StateT Int (WriterT w Identity) a)
-> (a -> StateT Int (WriterT w Identity) a)
-> StateT Int (WriterT w Identity) a
forall a b. (a -> b) -> a -> b
$ \a
y -> do
    Int
i <- StateT Int (WriterT w Identity) Int
forall (m :: * -> *) s. Monad m => StateT s m s
get
    (Int -> Int) -> StateT Int (WriterT w Identity) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    Writer w a -> StateT Int (WriterT w Identity) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Writer w a -> StateT Int (WriterT w Identity) a)
-> Writer w a -> StateT Int (WriterT w Identity) a
forall a b. (a -> b) -> a -> b
$ Int -> a -> Writer w a
f Int
i a
y

--  There are differences in pretty-printing between GHC and HSE. This
--  version never removes brackets.
descendBracket :: (LHsExpr GhcPs -> (Bool, LHsExpr GhcPs)) -> LHsExpr GhcPs -> LHsExpr GhcPs
descendBracket :: (LHsExpr GhcPs -> (Bool, LHsExpr GhcPs))
-> LHsExpr GhcPs -> LHsExpr GhcPs
descendBracket LHsExpr GhcPs -> (Bool, LHsExpr GhcPs)
op LHsExpr GhcPs
x = (Int -> LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Data a => (Int -> a -> a) -> a -> a
descendIndex Int -> LHsExpr GhcPs -> LHsExpr GhcPs
g LHsExpr GhcPs
x
    where
        g :: Int -> LHsExpr GhcPs -> LHsExpr GhcPs
g Int
i LHsExpr GhcPs
y = if Bool
a then Int -> LHsExpr GhcPs -> LHsExpr GhcPs
f Int
i LHsExpr GhcPs
b else LHsExpr GhcPs
b
            where (Bool
a, LHsExpr GhcPs
b) = LHsExpr GhcPs -> (Bool, LHsExpr GhcPs)
op LHsExpr GhcPs
y
        f :: Int -> LHsExpr GhcPs -> LHsExpr GhcPs
f Int
i LHsExpr GhcPs
y = if Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a. Brackets a => Int -> a -> a -> Bool
needBracket Int
i LHsExpr GhcPs
x LHsExpr GhcPs
y then LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Brackets a => a -> a
addParen LHsExpr GhcPs
y else LHsExpr GhcPs
y

-- Add brackets as suggested 'needBracket at 1-level of depth.
rebracket1 :: LHsExpr GhcPs -> LHsExpr GhcPs
rebracket1 :: LHsExpr GhcPs -> LHsExpr GhcPs
rebracket1 = (LHsExpr GhcPs -> (Bool, LHsExpr GhcPs))
-> LHsExpr GhcPs -> LHsExpr GhcPs
descendBracket (Bool
True, )

-- A list of application, with any necessary brackets.
appsBracket :: [LHsExpr GhcPs] -> LHsExpr GhcPs
appsBracket :: [LHsExpr GhcPs] -> LHsExpr GhcPs
appsBracket = (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs)
-> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkApp
  where mkApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
mkApp LHsExpr GhcPs
x LHsExpr GhcPs
y = LHsExpr GhcPs -> LHsExpr GhcPs
rebracket1 (HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr 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 NoExtField
XApp GhcPs
noExtField LHsExpr GhcPs
x LHsExpr GhcPs
y)

simplifyExp :: LHsExpr GhcPs -> LHsExpr GhcPs
-- Replace appliciations 'f $ x' with 'f (x)'.
simplifyExp :: LHsExpr GhcPs -> LHsExpr GhcPs
simplifyExp (L SrcSpan
l (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
x LHsExpr GhcPs
op LHsExpr GhcPs
y)) | LHsExpr GhcPs -> Bool
isDol LHsExpr GhcPs
op = SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (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 (HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExtField
XPar GhcPs
noExtField LHsExpr GhcPs
y)))
simplifyExp e :: LHsExpr GhcPs
e@(L SrcSpan
_ (HsLet XLet GhcPs
_ (L SrcSpan
_ (HsValBinds XHsValBinds GhcPs GhcPs
_ (ValBinds XValBinds GhcPs GhcPs
_ LHsBindsLR GhcPs GhcPs
binds []))) LHsExpr GhcPs
z)) =
  -- An expression of the form, 'let x = y in z'.
  case LHsBindsLR GhcPs GhcPs -> [LHsBindLR GhcPs GhcPs]
forall a. Bag a -> [a]
bagToList LHsBindsLR GhcPs GhcPs
binds of
    [L SrcSpan
_ (FunBind XFunBind GhcPs GhcPs
_ Located (IdP GhcPs)
_ (MG XMG GhcPs (LHsExpr GhcPs)
_ (L SrcSpan
_ [L SrcSpan
_ (Match XCMatch GhcPs (LHsExpr GhcPs)
_(FunRhs (L SrcSpan
_ IdP (NoGhcTc GhcPs)
x) LexicalFixity
_ SrcStrictness
_) [] (GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
_[L SrcSpan
_ (GRHS XCGRHS GhcPs (LHsExpr GhcPs)
_ [] LHsExpr GhcPs
y)] (L SrcSpan
_ (EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
_))))]) Origin
_) [Tickish Id]
_)]
         -- If 'x' is not in the free variables of 'y', beta-reduce to
         -- 'z[(y)/x]'.
      | RdrName -> String
occNameStr IdP (NoGhcTc GhcPs)
RdrName
x 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 Bool -> Bool -> Bool
&& [()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | Unqual OccName
a <- LHsExpr GhcPs -> [RdrName]
forall from to. Biplate from to => from -> [to]
universeBi LHsExpr GhcPs
z, OccName
a OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName -> OccName
rdrNameOcc IdP (NoGhcTc GhcPs)
RdrName
x] Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 ->
          (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall on. Uniplate on => (on -> on) -> on -> on
transform LHsExpr GhcPs -> LHsExpr GhcPs
f LHsExpr GhcPs
z
          where f :: LHsExpr GhcPs -> LHsExpr GhcPs
f (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
x') | RdrName -> String
occNameStr IdP (NoGhcTc GhcPs)
RdrName
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
x' = LHsExpr GhcPs -> LHsExpr GhcPs
paren LHsExpr GhcPs
y
                f LHsExpr GhcPs
x = LHsExpr GhcPs
x
    [LHsBindLR GhcPs GhcPs]
_ -> LHsExpr GhcPs
e
simplifyExp LHsExpr GhcPs
e = LHsExpr GhcPs
e

-- Rewrite '($) . b' as 'b'.
niceDotApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
niceDotApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
niceDotApp (L SrcSpan
_ (HsVar XVar GhcPs
_ (L SrcSpan
_ IdP GhcPs
r))) LHsExpr GhcPs
b | RdrName -> String
occNameStr IdP GhcPs
RdrName
r String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"$" = LHsExpr GhcPs
b
niceDotApp LHsExpr GhcPs
a LHsExpr GhcPs
b = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
dotApp LHsExpr GhcPs
a LHsExpr GhcPs
b

-- Generate a lambda expression but prettier if possible.
niceLambda :: [String] -> LHsExpr GhcPs -> LHsExpr GhcPs
niceLambda :: [String] -> LHsExpr GhcPs -> LHsExpr GhcPs
niceLambda [String]
ss LHsExpr GhcPs
e = (LHsExpr GhcPs, SrcSpan -> [Refactoring SrcSpan]) -> LHsExpr GhcPs
forall a b. (a, b) -> a
fst ([String]
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, SrcSpan -> [Refactoring SrcSpan])
niceLambdaR [String]
ss LHsExpr GhcPs
e)-- We don't support refactorings yet.

allowRightSection :: String -> Bool
allowRightSection :: String -> Bool
allowRightSection String
x = String
x String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"-",String
"#"]
allowLeftSection :: String -> Bool
allowLeftSection :: String -> Bool
allowLeftSection String
x = String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"#"

-- Implementation. Try to produce special forms (e.g. sections,
-- compositions) where we can.
niceLambdaR :: [String]
            -> LHsExpr GhcPs
            -> (LHsExpr GhcPs, R.SrcSpan -> [Refactoring R.SrcSpan])
-- Rewrite @\ -> e@ as @e@
-- These are encountered as recursive calls.
niceLambdaR :: [String]
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, SrcSpan -> [Refactoring SrcSpan])
niceLambdaR [String]
xs (SimpleLambda [] LHsExpr GhcPs
x) = [String]
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, SrcSpan -> [Refactoring SrcSpan])
niceLambdaR [String]
xs LHsExpr GhcPs
x

-- Rewrite @\xs -> (e)@ as @\xs -> e@.
niceLambdaR [String]
xs (L SrcSpan
_ (HsPar XPar GhcPs
_ LHsExpr GhcPs
x)) = [String]
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, SrcSpan -> [Refactoring SrcSpan])
niceLambdaR [String]
xs LHsExpr GhcPs
x

-- @\vs v -> ($) e v@ ==> @\vs -> e@
-- @\vs v -> e $ v@ ==> @\vs -> e@
niceLambdaR ([String] -> Maybe ([String], String)
forall a. [a] -> Maybe ([a], a)
unsnoc -> Just ([String]
vs, String
v)) (LHsExpr GhcPs -> App2
forall a b. View a b => a -> b
view -> App2 LHsExpr GhcPs
f LHsExpr GhcPs
e (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
v'))
  | LHsExpr GhcPs -> Bool
isDol LHsExpr GhcPs
f
  , String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v'
  , LHsExpr GhcPs -> [String]
forall a. FreeVars a => a -> [String]
vars LHsExpr GhcPs
e [String] -> [String] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`disjoint` [String
v]
  = [String]
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, SrcSpan -> [Refactoring SrcSpan])
niceLambdaR [String]
vs LHsExpr GhcPs
e

-- @\v -> thing + v@ ==> @\v -> (thing +)@  (heuristic: @v@ must be a single
-- lexeme, or it all gets too complex)
niceLambdaR [String
v] (L SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
e LHsExpr GhcPs
f (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
v')))
  | LHsExpr GhcPs -> Bool
isLexeme LHsExpr GhcPs
e
  , String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v'
  , LHsExpr GhcPs -> [String]
forall a. FreeVars a => a -> [String]
vars LHsExpr GhcPs
e [String] -> [String] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`disjoint` [String
v]
  , L SrcSpan
_ (HsVar XVar GhcPs
_ (L SrcSpan
_ IdP GhcPs
fname)) <- LHsExpr GhcPs
f
  , OccName -> Bool
isSymOcc (OccName -> Bool) -> OccName -> Bool
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc IdP GhcPs
RdrName
fname
  = let res :: LHsExpr GhcPs
res = HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr 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
$ HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr 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
e LHsExpr GhcPs
f
     in (LHsExpr GhcPs
res, \SrcSpan
s -> [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr SrcSpan
s [] (LHsExpr GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint LHsExpr GhcPs
res)])

-- @\vs v -> f x v@ ==> @\vs -> f x@
niceLambdaR ([String] -> Maybe ([String], String)
forall a. [a] -> Maybe ([a], a)
unsnoc -> Just ([String]
vs, String
v)) (L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
f (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
v')))
  | String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v'
  , LHsExpr GhcPs -> [String]
forall a. FreeVars a => a -> [String]
vars LHsExpr GhcPs
f [String] -> [String] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`disjoint` [String
v]
  = [String]
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, SrcSpan -> [Refactoring SrcSpan])
niceLambdaR [String]
vs LHsExpr GhcPs
f

-- @\vs v -> (v `f`)@ ==> @\vs -> f@
niceLambdaR ([String] -> Maybe ([String], String)
forall a. [a] -> Maybe ([a], a)
unsnoc -> Just ([String]
vs, String
v)) (L SrcSpan
_ (SectionL XSectionL GhcPs
_ (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
v') LHsExpr GhcPs
f))
  | String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v' = [String]
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, SrcSpan -> [Refactoring SrcSpan])
niceLambdaR [String]
vs LHsExpr GhcPs
f

-- Strip one variable pattern from the end of a lambdas match, and place it in our list of factoring variables.
niceLambdaR [String]
xs (SimpleLambda ((LPat GhcPs -> PVar_
forall a b. View a b => a -> b
view -> PVar_ String
v):[LPat GhcPs]
vs) LHsExpr GhcPs
x)
  | String
v String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
xs = [String]
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, SrcSpan -> [Refactoring SrcSpan])
niceLambdaR ([String]
xs[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String
v]) (LHsExpr GhcPs
 -> (LHsExpr GhcPs, SrcSpan -> [Refactoring SrcSpan]))
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, SrcSpan -> [Refactoring SrcSpan])
forall a b. (a -> b) -> a -> b
$ [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [LPat GhcPs]
vs LHsExpr GhcPs
x

-- Rewrite @\x -> x + a@ as @(+ a)@ (heuristic: @a@ must be a single
-- lexeme, or it all gets too complex).
niceLambdaR [String
x] (LHsExpr GhcPs -> App2
forall a b. View a b => a -> b
view -> App2 op :: LHsExpr GhcPs
op@(L SrcSpan
_ (HsVar XVar GhcPs
_ (L SrcSpan
_ IdP GhcPs
tag))) LHsExpr GhcPs
l LHsExpr GhcPs
r)
  | LHsExpr GhcPs -> Bool
isLexeme LHsExpr GhcPs
r, LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view LHsExpr GhcPs
l Var_ -> Var_ -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Var_
Var_ String
x, String
x 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
r, String -> Bool
allowRightSection (RdrName -> String
occNameStr IdP GhcPs
RdrName
tag) =
      let e :: LHsExpr GhcPs
e = LHsExpr GhcPs -> LHsExpr GhcPs
rebracket1 (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Brackets a => a -> a
addParen (HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr 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
op LHsExpr GhcPs
r)
      in (LHsExpr GhcPs
e, \SrcSpan
s -> [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr SrcSpan
s [] (LHsExpr GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint LHsExpr GhcPs
e)])
-- Rewrite (1) @\x -> f (b x)@ as @f . b@, (2) @\x -> f $ b x@ as @f . b@.
niceLambdaR [String
x] LHsExpr GhcPs
y
  | Just (LHsExpr GhcPs
z, [LHsExpr GhcPs]
subts) <- LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
factor LHsExpr GhcPs
y, String
x 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
z = (LHsExpr GhcPs
z, \SrcSpan
s -> [[LHsExpr GhcPs] -> SrcSpan -> Refactoring SrcSpan
mkRefact [LHsExpr GhcPs]
subts SrcSpan
s])
  where
    -- Factor the expression with respect to x.
    factor :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
    factor :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
factor (L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
ini LHsExpr GhcPs
lst)) | LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view LHsExpr GhcPs
lst Var_ -> Var_ -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Var_
Var_ String
x = (LHsExpr GhcPs, [LHsExpr GhcPs])
-> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
forall a. a -> Maybe a
Just (LHsExpr GhcPs
ini, [LHsExpr GhcPs
ini])
    factor (L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
ini LHsExpr GhcPs
lst)) | Just (LHsExpr GhcPs
z, [LHsExpr GhcPs]
ss) <- LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
factor LHsExpr GhcPs
lst
      = let r :: LHsExpr GhcPs
r = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
niceDotApp LHsExpr GhcPs
ini LHsExpr GhcPs
z
        in if LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a. Data a => a -> a -> Bool
astEq LHsExpr GhcPs
r LHsExpr GhcPs
z then (LHsExpr GhcPs, [LHsExpr GhcPs])
-> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
forall a. a -> Maybe a
Just (LHsExpr GhcPs
r, [LHsExpr GhcPs]
ss) else (LHsExpr GhcPs, [LHsExpr GhcPs])
-> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
forall a. a -> Maybe a
Just (LHsExpr GhcPs
r, LHsExpr GhcPs
ini LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
: [LHsExpr GhcPs]
ss)
    factor (L SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
y LHsExpr GhcPs
op (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
factor -> Just (LHsExpr GhcPs
z, [LHsExpr GhcPs]
ss))))| LHsExpr GhcPs -> Bool
isDol LHsExpr GhcPs
op
      = let r :: LHsExpr GhcPs
r = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
niceDotApp LHsExpr GhcPs
y LHsExpr GhcPs
z
        in if LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a. Data a => a -> a -> Bool
astEq LHsExpr GhcPs
r LHsExpr GhcPs
z then (LHsExpr GhcPs, [LHsExpr GhcPs])
-> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
forall a. a -> Maybe a
Just (LHsExpr GhcPs
r, [LHsExpr GhcPs]
ss) else (LHsExpr GhcPs, [LHsExpr GhcPs])
-> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
forall a. a -> Maybe a
Just (LHsExpr GhcPs
r, LHsExpr GhcPs
y LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
: [LHsExpr GhcPs]
ss)
    factor (L SrcSpan
_ (HsPar XPar GhcPs
_ y :: LHsExpr GhcPs
y@(L SrcSpan
_ HsApp{}))) = LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
factor LHsExpr GhcPs
y
    factor LHsExpr GhcPs
_ = Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
forall a. Maybe a
Nothing
    mkRefact :: [LHsExpr GhcPs] -> R.SrcSpan -> Refactoring R.SrcSpan
    mkRefact :: [LHsExpr GhcPs] -> SrcSpan -> Refactoring SrcSpan
mkRefact [LHsExpr GhcPs]
subts SrcSpan
s =
      let tempSubts :: [(String, SrcSpan)]
tempSubts = (String -> LHsExpr GhcPs -> (String, SrcSpan))
-> [String] -> [LHsExpr GhcPs] -> [(String, SrcSpan)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
a LHsExpr GhcPs
b -> (String
a, LHsExpr GhcPs -> SrcSpan
forall a. Located a -> SrcSpan
toSS LHsExpr GhcPs
b)) [String]
substVars [LHsExpr GhcPs]
subts
          template :: LHsExpr GhcPs
template = [LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps (((String, SrcSpan) -> LHsExpr GhcPs)
-> [(String, SrcSpan)] -> [LHsExpr GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (String -> LHsExpr GhcPs
strToVar (String -> LHsExpr GhcPs)
-> ((String, SrcSpan) -> String)
-> (String, SrcSpan)
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, SrcSpan) -> String
forall a b. (a, b) -> a
fst) [(String, SrcSpan)]
tempSubts)
      in RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr SrcSpan
s [(String, SrcSpan)]
tempSubts (LHsExpr GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint LHsExpr GhcPs
template)
-- Rewrite @\x y -> x + y@ as @(+)@.
niceLambdaR [String
x,String
y] (L SrcSpan
_ (OpApp XOpApp GhcPs
_ (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
x1) op :: LHsExpr GhcPs
op@(L SrcSpan
_ HsVar {}) (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
y1)))
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
x1, String
y String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y1, LHsExpr GhcPs -> [String]
forall a. FreeVars a => a -> [String]
vars LHsExpr GhcPs
op [String] -> [String] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`disjoint` [String
x, String
y] = (LHsExpr GhcPs
op, \SrcSpan
s -> [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr SrcSpan
s [] (LHsExpr GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint LHsExpr GhcPs
op)])
-- Rewrite @\x y -> f y x@ as @flip f@.
niceLambdaR [String
x, String
y] (LHsExpr GhcPs -> App2
forall a b. View a b => a -> b
view -> App2 LHsExpr GhcPs
op (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
y1) (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
x1))
  | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
x1, String
y String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y1, LHsExpr GhcPs -> [String]
forall a. FreeVars a => a -> [String]
vars LHsExpr GhcPs
op [String] -> [String] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`disjoint` [String
x, String
y] =
      ( LHsExpr GhcPs -> LHsExpr GhcPs
gen LHsExpr GhcPs
op
      , \SrcSpan
s -> [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr SrcSpan
s [(String
"x", LHsExpr GhcPs -> SrcSpan
forall a. Located a -> SrcSpan
toSS LHsExpr GhcPs
op)] (LHsExpr GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint (LHsExpr GhcPs -> String) -> LHsExpr GhcPs -> String
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
gen (String -> LHsExpr GhcPs
strToVar String
"x"))]
      )
  where
    gen :: LHsExpr GhcPs -> LHsExpr GhcPs
gen = HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (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 NoExtField
XApp GhcPs
noExtField (String -> LHsExpr GhcPs
strToVar String
"flip")
        (LHsExpr GhcPs -> HsExpr GhcPs)
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs
-> HsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. if LHsExpr GhcPs -> Bool
forall a. Brackets a => a -> Bool
isAtom LHsExpr GhcPs
op then LHsExpr GhcPs -> LHsExpr GhcPs
forall a. a -> a
id else LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Brackets a => a -> a
addParen

-- We're done factoring, but have no variables left, so we shouldn't make a lambda.
-- @\ -> e@ ==> @e@
niceLambdaR [] LHsExpr GhcPs
e = (LHsExpr GhcPs
e, \SrcSpan
s -> [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr SrcSpan
s [(String
"a", LHsExpr GhcPs -> SrcSpan
forall a. Located a -> SrcSpan
toSS LHsExpr GhcPs
e)] String
"a"])
-- Base case. Just a good old fashioned lambda.
niceLambdaR [String]
ss LHsExpr GhcPs
e =
  let grhs :: LGRHS GhcPs (LHsExpr GhcPs)
grhs = GRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
forall e. e -> Located e
noLoc (GRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs))
-> GRHS 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
e :: LGRHS GhcPs (LHsExpr GhcPs)
      grhss :: GRHSs GhcPs (LHsExpr GhcPs)
grhss = GRHSs :: forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs {grhssExt :: XCGRHSs GhcPs (LHsExpr GhcPs)
grhssExt = NoExtField
XCGRHSs GhcPs (LHsExpr GhcPs)
noExtField, grhssGRHSs :: [LGRHS GhcPs (LHsExpr GhcPs)]
grhssGRHSs=[LGRHS GhcPs (LHsExpr GhcPs)
grhs], grhssLocalBinds :: LHsLocalBinds GhcPs
grhssLocalBinds=HsLocalBindsLR GhcPs GhcPs -> LHsLocalBinds GhcPs
forall e. e -> Located e
noLoc (HsLocalBindsLR GhcPs GhcPs -> LHsLocalBinds GhcPs)
-> HsLocalBindsLR GhcPs 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}
      match :: LMatch GhcPs (LHsExpr GhcPs)
match = Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall e. e -> Located e
noLoc (Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs))
-> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ Match :: forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match {m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext=NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noExtField, m_ctxt :: HsMatchContext (NoGhcTc GhcPs)
m_ctxt=HsMatchContext (NoGhcTc GhcPs)
forall p. HsMatchContext p
LambdaExpr, m_pats :: [LPat GhcPs]
m_pats=(String -> Located (Pat GhcPs))
-> [String] -> [Located (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map String -> LPat GhcPs
String -> Located (Pat GhcPs)
strToPat [String]
ss, m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss=GRHSs GhcPs (LHsExpr GhcPs)
grhss} :: LMatch GhcPs (LHsExpr GhcPs)
      matchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup = MG :: forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG {mg_ext :: XMG GhcPs (LHsExpr GhcPs)
mg_ext=NoExtField
XMG GhcPs (LHsExpr GhcPs)
noExtField, mg_origin :: Origin
mg_origin=Origin
Generated, mg_alts :: Located [LMatch GhcPs (LHsExpr GhcPs)]
mg_alts=[LMatch GhcPs (LHsExpr GhcPs)]
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
forall e. e -> Located e
noLoc [LMatch GhcPs (LHsExpr GhcPs)
match]}
  in (HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr 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)
matchGroup, [Refactoring SrcSpan] -> SrcSpan -> [Refactoring SrcSpan]
forall a b. a -> b -> a
const [])


-- 'case' and 'if' expressions have branches, nothing else does (this
-- doesn't consider 'HsMultiIf' perhaps it should?).
replaceBranches :: LHsExpr GhcPs -> ([LHsExpr GhcPs], [LHsExpr GhcPs] -> LHsExpr GhcPs)
replaceBranches :: LHsExpr GhcPs
-> ([LHsExpr GhcPs], [LHsExpr GhcPs] -> LHsExpr GhcPs)
replaceBranches (L SrcSpan
l (HsIf XIf GhcPs
_ LHsExpr GhcPs
a LHsExpr GhcPs
b LHsExpr GhcPs
c)) = ([LHsExpr GhcPs
b, LHsExpr GhcPs
c], \[LHsExpr GhcPs
b, LHsExpr GhcPs
c] -> SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XIf GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XIf p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsIf NoExtField
XIf GhcPs
noExtField LHsExpr GhcPs
a LHsExpr GhcPs
b LHsExpr GhcPs
c))

replaceBranches (L SrcSpan
s (HsCase XCase GhcPs
_ LHsExpr GhcPs
a (MG XMG GhcPs (LHsExpr GhcPs)
_ (L SrcSpan
l [LMatch GhcPs (LHsExpr GhcPs)]
bs) Origin
FromSource))) =
  ((LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs])
-> [LMatch GhcPs (LHsExpr GhcPs)] -> [LHsExpr GhcPs]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs]
f [LMatch GhcPs (LHsExpr GhcPs)]
bs, \[LHsExpr GhcPs]
xs -> SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
s (XCase GhcPs
-> LHsExpr GhcPs
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> HsExpr GhcPs
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase NoExtField
XCase GhcPs
noExtField LHsExpr GhcPs
a (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 NoExtField
XMG GhcPs (LHsExpr GhcPs)
noExtField (SrcSpan
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l ([LMatch GhcPs (LHsExpr GhcPs)]
-> [LHsExpr GhcPs] -> [LMatch GhcPs (LHsExpr GhcPs)]
g [LMatch GhcPs (LHsExpr GhcPs)]
bs [LHsExpr GhcPs]
xs)) Origin
Generated)))
  where
    f :: LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs]
    f :: LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs]
f (L SrcSpan
_ (Match XCMatch GhcPs (LHsExpr GhcPs)
_ HsMatchContext (NoGhcTc GhcPs)
CaseAlt [LPat GhcPs]
_ (GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
_ [LGRHS GhcPs (LHsExpr GhcPs)]
xs LHsLocalBinds GhcPs
_))) = [LHsExpr GhcPs
x | (L SrcSpan
_ (GRHS XCGRHS GhcPs (LHsExpr GhcPs)
_ [GuardLStmt GhcPs]
_ LHsExpr GhcPs
x)) <- [LGRHS GhcPs (LHsExpr GhcPs)]
xs]
    f LMatch GhcPs (LHsExpr GhcPs)
_ = String -> [LHsExpr GhcPs]
forall a. HasCallStack => String -> a
error String
"GHC.Util.HsExpr.replaceBranches: unexpected XMatch"

    g :: [LMatch GhcPs (LHsExpr GhcPs)] -> [LHsExpr GhcPs] -> [LMatch GhcPs (LHsExpr GhcPs)]
    g :: [LMatch GhcPs (LHsExpr GhcPs)]
-> [LHsExpr GhcPs] -> [LMatch GhcPs (LHsExpr GhcPs)]
g (L SrcSpan
s1 (Match XCMatch GhcPs (LHsExpr GhcPs)
_ HsMatchContext (NoGhcTc GhcPs)
CaseAlt [LPat GhcPs]
a (GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
_ [LGRHS GhcPs (LHsExpr GhcPs)]
ns LHsLocalBinds GhcPs
b)) : [LMatch GhcPs (LHsExpr GhcPs)]
rest) [LHsExpr GhcPs]
xs =
      SrcSpan
-> Match GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
s1 (XCMatch GhcPs (LHsExpr GhcPs)
-> HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> GRHSs GhcPs (LHsExpr GhcPs)
-> Match GhcPs (LHsExpr GhcPs)
forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noExtField HsMatchContext (NoGhcTc GhcPs)
forall p. HsMatchContext p
CaseAlt [LPat GhcPs]
a (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 [SrcSpan
-> GRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
a (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 [GuardLStmt GhcPs]
gs LHsExpr GhcPs
x) | (L SrcSpan
a (GRHS XCGRHS GhcPs (LHsExpr GhcPs)
_ [GuardLStmt GhcPs]
gs LHsExpr GhcPs
_), LHsExpr GhcPs
x) <- [LGRHS GhcPs (LHsExpr GhcPs)]
-> [LHsExpr GhcPs]
-> [(LGRHS GhcPs (LHsExpr GhcPs), LHsExpr GhcPs)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LGRHS GhcPs (LHsExpr GhcPs)]
ns [LHsExpr GhcPs]
as] LHsLocalBinds GhcPs
b)) LMatch GhcPs (LHsExpr GhcPs)
-> [LMatch GhcPs (LHsExpr GhcPs)] -> [LMatch GhcPs (LHsExpr GhcPs)]
forall a. a -> [a] -> [a]
: [LMatch GhcPs (LHsExpr GhcPs)]
-> [LHsExpr GhcPs] -> [LMatch GhcPs (LHsExpr GhcPs)]
g [LMatch GhcPs (LHsExpr GhcPs)]
rest [LHsExpr GhcPs]
bs
      where  ([LHsExpr GhcPs]
as, [LHsExpr GhcPs]
bs) = Int -> [LHsExpr GhcPs] -> ([LHsExpr GhcPs], [LHsExpr GhcPs])
forall a. Int -> [a] -> ([a], [a])
splitAt ([LGRHS GhcPs (LHsExpr GhcPs)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LGRHS GhcPs (LHsExpr GhcPs)]
ns) [LHsExpr GhcPs]
xs
    g [] [] = []
    g [LMatch GhcPs (LHsExpr GhcPs)]
_ [LHsExpr GhcPs]
_ = String -> [LMatch GhcPs (LHsExpr GhcPs)]
forall a. HasCallStack => String -> a
error String
"GHC.Util.HsExpr.replaceBranches': internal invariant failed, lists are of differing lengths"

replaceBranches LHsExpr GhcPs
x = ([], \[] -> LHsExpr GhcPs
x)


-- Like needBracket, but with a special case for 'a . b . b', which was
-- removed from haskell-src-exts-util-0.2.2.
needBracketOld :: Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
needBracketOld :: Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
needBracketOld Int
i LHsExpr GhcPs
parent LHsExpr GhcPs
child
  | LHsExpr GhcPs -> Bool
isDotApp LHsExpr GhcPs
parent, LHsExpr GhcPs -> Bool
isDotApp LHsExpr GhcPs
child, Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = Bool
False
  | Bool
otherwise = Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a. Brackets a => Int -> a -> a -> Bool
needBracket Int
i LHsExpr GhcPs
parent LHsExpr GhcPs
child

transformBracketOld :: (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs))
                    -> LHsExpr GhcPs
                    -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
transformBracketOld :: (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs))
-> LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
transformBracketOld LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
op = ((Bool, LHsExpr GhcPs) -> LHsExpr GhcPs)
-> ((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String]))
-> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (Bool, LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a, b) -> b
snd (((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String]))
 -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String])))
-> (LHsExpr GhcPs
    -> ((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String])))
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> ((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String]))
g
  where
    g :: LHsExpr GhcPs -> ((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String]))
g = (LHsExpr GhcPs -> (Bool, LHsExpr GhcPs))
-> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
-> ((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String]))
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first LHsExpr GhcPs -> (Bool, LHsExpr GhcPs)
f ((LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
 -> ((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String])))
-> (LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String])))
-> LHsExpr GhcPs
-> ((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsExpr GhcPs
 -> ((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String])))
-> LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
descendBracketOld LHsExpr GhcPs -> ((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String]))
g
    f :: LHsExpr GhcPs -> (Bool, LHsExpr GhcPs)
f LHsExpr GhcPs
x = (Bool, LHsExpr GhcPs)
-> (LHsExpr GhcPs -> (Bool, LHsExpr GhcPs))
-> Maybe (LHsExpr GhcPs)
-> (Bool, LHsExpr GhcPs)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool
False, LHsExpr GhcPs
x) (Bool
True, ) (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
op LHsExpr GhcPs
x)

-- Descend, and if something changes then add/remove brackets
-- appropriately. Returns (suggested replacement, (refactor template, no bracket vars)),
-- where "no bracket vars" is a list of substitution variables which, when expanded,
-- should have the brackets stripped.
descendBracketOld :: (LHsExpr GhcPs -> ((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String])))
                  -> LHsExpr GhcPs
                  -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
descendBracketOld :: (LHsExpr GhcPs
 -> ((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String])))
-> LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
descendBracketOld LHsExpr GhcPs -> ((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String]))
op LHsExpr GhcPs
x = ((Int -> LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Data a => (Int -> a -> a) -> a -> a
descendIndex Int -> LHsExpr GhcPs -> LHsExpr GhcPs
g1 LHsExpr GhcPs
x, (Int -> LHsExpr GhcPs -> Writer [String] (LHsExpr GhcPs))
-> LHsExpr GhcPs -> (LHsExpr GhcPs, [String])
forall a w.
(Data a, Monoid w) =>
(Int -> a -> Writer w a) -> a -> (a, w)
descendIndex' Int -> LHsExpr GhcPs -> Writer [String] (LHsExpr GhcPs)
g2 LHsExpr GhcPs
x)
  where
    g :: Int -> LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
g Int
i LHsExpr GhcPs
y = if Bool
a then (Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> [String] -> LHsExpr GhcPs
f1 Int
i LHsExpr GhcPs
b LHsExpr GhcPs
z [String]
w, Int
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> [String]
-> (LHsExpr GhcPs, [String])
f2 Int
i LHsExpr GhcPs
b LHsExpr GhcPs
z [String]
w) else (LHsExpr GhcPs
b, (LHsExpr GhcPs
z, [String]
w))
      where ((Bool
a, LHsExpr GhcPs
b), (LHsExpr GhcPs
z, [String]
w)) = LHsExpr GhcPs -> ((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String]))
op LHsExpr GhcPs
y

    g1 :: Int -> LHsExpr GhcPs -> LHsExpr GhcPs
g1 Int
a LHsExpr GhcPs
b = (LHsExpr GhcPs, (LHsExpr GhcPs, [String])) -> LHsExpr GhcPs
forall a b. (a, b) -> a
fst (Int -> LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
g Int
a LHsExpr GhcPs
b)
    g2 :: Int -> LHsExpr GhcPs -> Writer [String] (LHsExpr GhcPs)
g2 Int
a LHsExpr GhcPs
b = (LHsExpr GhcPs, [String]) -> Writer [String] (LHsExpr GhcPs)
forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
(a, w) -> WriterT w m a
writer ((LHsExpr GhcPs, [String]) -> Writer [String] (LHsExpr GhcPs))
-> (LHsExpr GhcPs, [String]) -> Writer [String] (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
-> (LHsExpr GhcPs, [String])
forall a b. (a, b) -> b
snd (Int -> LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
g Int
a LHsExpr GhcPs
b)

    f :: Int
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> [String]
-> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
f Int
i (L SrcSpan
_ (HsPar XPar GhcPs
_ LHsExpr GhcPs
y)) LHsExpr GhcPs
z [String]
w
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
needBracketOld Int
i LHsExpr GhcPs
x LHsExpr GhcPs
y = (LHsExpr GhcPs
y, LHsExpr GhcPs -> (LHsExpr GhcPs, [String])
removeBracket LHsExpr GhcPs
z)
      where
        -- If the template expr is a Var, record it so that we can remove the brackets
        -- later when expanding it. Otherwise, remove the enclosing brackets (if any).
        removeBracket :: LHsExpr GhcPs -> (LHsExpr GhcPs, [String])
removeBracket = \case
          var :: LHsExpr GhcPs
var@(L SrcSpan
_ HsVar{}) -> (LHsExpr GhcPs
z, LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
var String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
w)
          LHsExpr GhcPs
other -> (LHsExpr GhcPs -> LHsExpr GhcPs
fromParen LHsExpr GhcPs
z, [String]
w)
    f Int
i LHsExpr GhcPs
y LHsExpr GhcPs
z [String]
w
      | Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
needBracketOld Int
i LHsExpr GhcPs
x LHsExpr GhcPs
y = (LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Brackets a => a -> a
addParen LHsExpr GhcPs
y, (LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Brackets a => a -> a
addParen LHsExpr GhcPs
z, [String]
w))
      -- https://github.com/mpickering/apply-refact/issues/7
      | LHsExpr GhcPs -> Bool
forall l. GenLocated l (HsExpr GhcPs) -> Bool
isOp LHsExpr GhcPs
y = (LHsExpr GhcPs
y, (LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Brackets a => a -> a
addParen LHsExpr GhcPs
z, [String]
w))
    f Int
_ LHsExpr GhcPs
y LHsExpr GhcPs
z [String]
w = (LHsExpr GhcPs
y, (LHsExpr GhcPs
z, [String]
w))

    f1 :: Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> [String] -> LHsExpr GhcPs
f1 Int
a LHsExpr GhcPs
b LHsExpr GhcPs
c [String]
d = (LHsExpr GhcPs, (LHsExpr GhcPs, [String])) -> LHsExpr GhcPs
forall a b. (a, b) -> a
fst (Int
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> [String]
-> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
f Int
a LHsExpr GhcPs
b LHsExpr GhcPs
c [String]
d)
    f2 :: Int
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> [String]
-> (LHsExpr GhcPs, [String])
f2 Int
a LHsExpr GhcPs
b LHsExpr GhcPs
c [String]
d = (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
-> (LHsExpr GhcPs, [String])
forall a b. (a, b) -> b
snd (Int
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> [String]
-> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
f Int
a LHsExpr GhcPs
b LHsExpr GhcPs
c [String]
d)

    isOp :: GenLocated l (HsExpr GhcPs) -> Bool
isOp = \case
      L l
_ (HsVar XVar GhcPs
_ (L SrcSpan
_ IdP GhcPs
name)) -> RdrName -> Bool
isSymbolRdrName IdP GhcPs
RdrName
name
      GenLocated l (HsExpr GhcPs)
_ -> Bool
False

fromParen1 :: LHsExpr GhcPs -> LHsExpr GhcPs
fromParen1 :: LHsExpr GhcPs -> LHsExpr GhcPs
fromParen1 LHsExpr GhcPs
x = LHsExpr GhcPs -> Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. a -> Maybe a -> a
fromMaybe LHsExpr GhcPs
x (Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall a. Brackets a => a -> Maybe a
remParen LHsExpr GhcPs
x