{-# LANGUAGE ImportQualifiedPost #-}
{-# 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.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, toSSA)
import Refact.Types hiding (SrcSpan, Match)
import Refact.Types qualified 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 = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
x (forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA 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 [] = 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 = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
noExtField (forall p body.
XMG p body -> XRec p [LMatch p body] -> MatchGroup p body
MG Origin
Generated (forall a an. a -> LocatedAn an a
noLocA [forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p body.
XCMatch p body
-> HsMatchContext p -> [LPat p] -> GRHSs p body -> Match p body
Match forall ann. EpAnn ann
EpAnnNotUsed forall p. HsMatchContext p
LambdaExpr [LPat GhcPs]
vs (forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
emptyComments [forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS forall ann. EpAnn ann
EpAnnNotUsed [] LHsExpr GhcPs
body] (forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds NoExtField
noExtField))]))

-- | '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
  | forall a. Brackets a => a -> Bool
isAtom LHsExpr GhcPs
x  = LHsExpr GhcPs
x
  | Bool
otherwise = forall a. Brackets a => a -> a
addParen LHsExpr GhcPs
x

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


apps :: [LHsExpr GhcPs] -> LHsExpr GhcPs
apps :: [LHsExpr GhcPs] -> LHsExpr GhcPs
apps = forall a. (a -> a -> a) -> [a] -> a
foldl1' forall {p} {ann} {an}.
(XApp p ~ EpAnn ann) =>
XRec p (HsExpr p) -> XRec p (HsExpr p) -> LocatedAn an (HsExpr p)
mkApp where mkApp :: XRec p (HsExpr p) -> XRec p (HsExpr p) -> LocatedAn an (HsExpr p)
mkApp XRec p (HsExpr p)
x XRec p (HsExpr p)
y = forall a an. a -> LocatedAn an a
noLocA (forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall ann. EpAnn ann
EpAnnNotUsed XRec p (HsExpr p)
x XRec p (HsExpr p)
y)

fromApps :: LHsExpr GhcPs  -> [LHsExpr GhcPs]
fromApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]
fromApps (L SrcSpanAnnA
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
x LHsExpr GhcPs
y)) = LHsExpr GhcPs -> [LHsExpr GhcPs]
fromApps LHsExpr GhcPs
x 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 SrcSpanAnnA
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
x LHsExpr GhcPs
y)) = LHsExpr GhcPs -> [LHsExpr GhcPs]
childrenApps LHsExpr GhcPs
x forall a. [a] -> [a] -> [a]
++ [LHsExpr GhcPs
y]
childrenApps LHsExpr GhcPs
x = 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 forall a. a -> [a] -> [a]
: 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 :: forall (m :: * -> *).
Monad m =>
(LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr GhcPs)
descendAppsM LHsExpr GhcPs -> m (LHsExpr GhcPs)
f (L SrcSpanAnnA
l (HsApp XApp GhcPs
_ LHsExpr GhcPs
x LHsExpr GhcPs
y)) = (\GenLocated SrcSpanAnnA (HsExpr GhcPs)
x GenLocated SrcSpanAnnA (HsExpr GhcPs)
y -> forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l forall a b. (a -> b) -> a -> b
$ forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall ann. EpAnn ann
EpAnnNotUsed GenLocated SrcSpanAnnA (HsExpr GhcPs)
x GenLocated SrcSpanAnnA (HsExpr GhcPs)
y) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Monad m =>
(LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr GhcPs)
descendAppsM LHsExpr GhcPs -> m (LHsExpr GhcPs)
f LHsExpr GhcPs
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsExpr GhcPs -> m (LHsExpr GhcPs)
f LHsExpr GhcPs
y
descendAppsM LHsExpr GhcPs -> m (LHsExpr GhcPs)
f LHsExpr GhcPs
x = 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 :: forall (m :: * -> *).
Monad m =>
(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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
Monad m =>
(LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr GhcPs)
descendAppsM (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 :: forall a. Data a => (Int -> a -> a) -> a -> a
descendIndex Int -> a -> a
f = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a w.
(Data a, Monoid w) =>
(Int -> a -> Writer w a) -> a -> (a, w)
descendIndex' (\Int
x a
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' :: forall a w.
(Data a, Monoid w) =>
(Int -> a -> Writer w a) -> a -> (a, w)
descendIndex' Int -> a -> Writer w a
f a
x = forall w a. Monoid w => Writer w a -> (a, w)
runWriter forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Int
0 forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall on (m :: * -> *).
(Uniplate on, Applicative m) =>
(on -> m on) -> on -> m on
descendM a
x forall a b. (a -> b) -> a -> b
$ \a
y -> do
    Int
i <- forall (m :: * -> *) s. Monad m => StateT s m s
get
    forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (forall a. Num a => a -> a -> a
+Int
1)
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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 = forall a. Data a => (Int -> a -> a) -> a -> a
descendIndex Int
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
g LHsExpr GhcPs
x
    where
        g :: Int
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
g Int
i GenLocated SrcSpanAnnA (HsExpr GhcPs)
y = if Bool
a then Int
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
f Int
i LHsExpr GhcPs
b else LHsExpr GhcPs
b
            where (Bool
a, LHsExpr GhcPs
b) = LHsExpr GhcPs -> (Bool, LHsExpr GhcPs)
op GenLocated SrcSpanAnnA (HsExpr GhcPs)
y
        f :: Int
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
f Int
i GenLocated SrcSpanAnnA (HsExpr GhcPs)
y = if forall a. Brackets a => Int -> a -> a -> Bool
needBracket Int
i LHsExpr GhcPs
x GenLocated SrcSpanAnnA (HsExpr GhcPs)
y then forall a. Brackets a => a -> a
addParen GenLocated SrcSpanAnnA (HsExpr GhcPs)
y else GenLocated SrcSpanAnnA (HsExpr 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 = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
mkApp
  where mkApp :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> LHsExpr GhcPs
mkApp GenLocated SrcSpanAnnA (HsExpr GhcPs)
x GenLocated SrcSpanAnnA (HsExpr GhcPs)
y = LHsExpr GhcPs -> LHsExpr GhcPs
rebracket1 (forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall ann. EpAnn ann
EpAnnNotUsed GenLocated SrcSpanAnnA (HsExpr GhcPs)
x GenLocated SrcSpanAnnA (HsExpr GhcPs)
y)

simplifyExp :: LHsExpr GhcPs -> LHsExpr GhcPs
-- Replace appliciations 'f $ x' with 'f (x)'.
simplifyExp :: LHsExpr GhcPs -> LHsExpr GhcPs
simplifyExp (L SrcSpanAnnA
l (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
x LHsExpr GhcPs
op LHsExpr GhcPs
y)) | LHsExpr GhcPs -> Bool
isDol LHsExpr GhcPs
op = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
x (forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar LHsExpr GhcPs
y))
simplifyExp e :: LHsExpr GhcPs
e@(L SrcSpanAnnA
_ (HsLet XLet GhcPs
_ LHsToken "let" GhcPs
_ ((HsValBinds XHsValBinds GhcPs GhcPs
_ (ValBinds XValBinds GhcPs GhcPs
_ LHsBindsLR GhcPs GhcPs
binds []))) LHsToken "in" GhcPs
_ LHsExpr GhcPs
z)) =
  -- An expression of the form, 'let x = y in z'.
  case forall a. Bag a -> [a]
bagToList LHsBindsLR GhcPs GhcPs
binds of
    [L SrcSpanAnnA
_ (FunBind XFunBind GhcPs GhcPs
_ LIdP GhcPs
_ (MG XMG GhcPs (LHsExpr GhcPs)
_ (L SrcSpanAnnL
_ [L SrcSpanAnnA
_ (Match XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_(FunRhs (L SrcSpanAnnN
_ RdrName
x) LexicalFixity
_ SrcStrictness
_) [] (GRHSs XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_[L SrcAnn NoEpAnns
_ (GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [] GenLocated SrcSpanAnnA (HsExpr GhcPs)
y)] ((EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
_))))])))]
         -- If 'x' is not in the free variables of 'y', beta-reduce to
         -- 'z[(y)/x]'.
      | RdrName -> String
occNameStr RdrName
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall a. FreeVars a => a -> [String]
vars GenLocated SrcSpanAnnA (HsExpr GhcPs)
y Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | Unqual OccName
a <- forall from to. Biplate from to => from -> [to]
universeBi LHsExpr GhcPs
z, OccName
a forall a. Eq a => a -> a -> Bool
== RdrName -> OccName
rdrNameOcc RdrName
x] forall a. Ord a => a -> a -> Bool
<= Int
1 ->
          forall on. Uniplate on => (on -> on) -> on -> on
transform GenLocated SrcSpanAnnA (HsExpr GhcPs) -> LHsExpr GhcPs
f LHsExpr GhcPs
z
          where f :: GenLocated SrcSpanAnnA (HsExpr GhcPs) -> LHsExpr GhcPs
f (forall a b. View a b => a -> b
view -> Var_ String
x') | RdrName -> String
occNameStr RdrName
x forall a. Eq a => a -> a -> Bool
== String
x' = LHsExpr GhcPs -> LHsExpr GhcPs
paren GenLocated SrcSpanAnnA (HsExpr GhcPs)
y
                f GenLocated SrcSpanAnnA (HsExpr GhcPs)
x = GenLocated SrcSpanAnnA (HsExpr GhcPs)
x
    [GenLocated SrcSpanAnnA (HsBindLR 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 SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ RdrName
r))) LHsExpr GhcPs
b | RdrName -> String
occNameStr RdrName
r 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 = 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 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 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 [] GenLocated SrcSpanAnnA (HsExpr GhcPs)
x) = [String]
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, SrcSpan -> [Refactoring SrcSpan])
niceLambdaR [String]
xs GenLocated SrcSpanAnnA (HsExpr GhcPs)
x

-- Rewrite @\xs -> (e)@ as @\xs -> e@.
niceLambdaR [String]
xs (L SrcSpanAnnA
_ (HsPar XPar GhcPs
_ LHsToken "(" GhcPs
_ LHsExpr GhcPs
x LHsToken ")" GhcPs
_)) = [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 (forall a. [a] -> Maybe ([a], a)
unsnoc -> Just ([String]
vs, String
v)) (forall a b. View a b => a -> b
view -> App2 GenLocated SrcSpanAnnA (HsExpr GhcPs)
f GenLocated SrcSpanAnnA (HsExpr GhcPs)
e (forall a b. View a b => a -> b
view -> Var_ String
v'))
  | LHsExpr GhcPs -> Bool
isDol GenLocated SrcSpanAnnA (HsExpr GhcPs)
f
  , String
v forall a. Eq a => a -> a -> Bool
== String
v'
  , forall a. FreeVars a => a -> [String]
vars GenLocated SrcSpanAnnA (HsExpr GhcPs)
e forall a. Eq a => [a] -> [a] -> Bool
`disjoint` [String
v]
  = [String]
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, SrcSpan -> [Refactoring SrcSpan])
niceLambdaR [String]
vs GenLocated SrcSpanAnnA (HsExpr GhcPs)
e

-- @\v -> thing + v@ ==> @\v -> (thing +)@  (heuristic: @v@ must be a single
-- lexeme, or it all gets too complex)
niceLambdaR [String
v] (L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
e LHsExpr GhcPs
f (forall a b. View a b => a -> b
view -> Var_ String
v')))
  | LHsExpr GhcPs -> Bool
isLexeme LHsExpr GhcPs
e
  , String
v forall a. Eq a => a -> a -> Bool
== String
v'
  , forall a. FreeVars a => a -> [String]
vars LHsExpr GhcPs
e forall a. Eq a => [a] -> [a] -> Bool
`disjoint` [String
v]
  , L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ RdrName
fname)) <- LHsExpr GhcPs
f
  , OccName -> Bool
isSymOcc forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc RdrName
fname
  = let res :: LHsExpr GhcPs
res = forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar forall a b. (a -> b) -> a -> b
$ forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
e LHsExpr GhcPs
f
     in (LHsExpr GhcPs
res, \SrcSpan
s -> [forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr SrcSpan
s [] (forall a. Outputable a => a -> String
unsafePrettyPrint LHsExpr GhcPs
res)])

-- @\vs v -> f x v@ ==> @\vs -> f x@
niceLambdaR (forall a. [a] -> Maybe ([a], a)
unsnoc -> Just ([String]
vs, String
v)) (L SrcSpanAnnA
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
f (forall a b. View a b => a -> b
view -> Var_ String
v')))
  | String
v forall a. Eq a => a -> a -> Bool
== String
v'
  , forall a. FreeVars a => a -> [String]
vars LHsExpr GhcPs
f 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 (forall a. [a] -> Maybe ([a], a)
unsnoc -> Just ([String]
vs, String
v)) (L SrcSpanAnnA
_ (SectionL XSectionL GhcPs
_ (forall a b. View a b => a -> b
view -> Var_ String
v') LHsExpr GhcPs
f))
  | String
v 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 ((forall a b. View a b => a -> b
view -> PVar_ String
v):[LocatedA (Pat GhcPs)]
vs) GenLocated SrcSpanAnnA (HsExpr GhcPs)
x)
  | String
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
xs = [String]
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, SrcSpan -> [Refactoring SrcSpan])
niceLambdaR ([String]
xsforall a. [a] -> [a] -> [a]
++[String
v]) forall a b. (a -> b) -> a -> b
$ [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda [LocatedA (Pat GhcPs)]
vs GenLocated SrcSpanAnnA (HsExpr GhcPs)
x

-- Rewrite @\x -> x + a@ as @(+ a)@ (heuristic: @a@ must be a single
-- lexeme, or it all gets too complex).
niceLambdaR [String
x] (forall a b. View a b => a -> b
view -> App2 op :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
op@(L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ RdrName
tag))) GenLocated SrcSpanAnnA (HsExpr GhcPs)
l GenLocated SrcSpanAnnA (HsExpr GhcPs)
r)
  | LHsExpr GhcPs -> Bool
isLexeme GenLocated SrcSpanAnnA (HsExpr GhcPs)
r, forall a b. View a b => a -> b
view GenLocated SrcSpanAnnA (HsExpr GhcPs)
l forall a. Eq a => a -> a -> Bool
== String -> Var_
Var_ String
x, String
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall a. FreeVars a => a -> [String]
vars GenLocated SrcSpanAnnA (HsExpr GhcPs)
r, String -> Bool
allowRightSection (RdrName -> String
occNameStr RdrName
tag) =
      let e :: LHsExpr GhcPs
e = LHsExpr GhcPs -> LHsExpr GhcPs
rebracket1 forall a b. (a -> b) -> a -> b
$ forall a. Brackets a => a -> a
addParen (forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR forall ann. EpAnn ann
EpAnnNotUsed GenLocated SrcSpanAnnA (HsExpr GhcPs)
op GenLocated SrcSpanAnnA (HsExpr GhcPs)
r)
      in (LHsExpr GhcPs
e, \SrcSpan
s -> [forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr SrcSpan
s [] (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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` 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 SrcSpanAnnA
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
ini LHsExpr GhcPs
lst)) | forall a b. View a b => a -> b
view LHsExpr GhcPs
lst forall a. Eq a => a -> a -> Bool
== String -> Var_
Var_ String
x = forall a. a -> Maybe a
Just (LHsExpr GhcPs
ini, [LHsExpr GhcPs
ini])
    factor (L SrcSpanAnnA
_ (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 forall a. Data a => a -> a -> Bool
astEq LHsExpr GhcPs
r LHsExpr GhcPs
z then forall a. a -> Maybe a
Just (LHsExpr GhcPs
r, [LHsExpr GhcPs]
ss) else forall a. a -> Maybe a
Just (LHsExpr GhcPs
r, LHsExpr GhcPs
ini forall a. a -> [a] -> [a]
: [LHsExpr GhcPs]
ss)
    factor (L SrcSpanAnnA
_ (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 forall a. Data a => a -> a -> Bool
astEq LHsExpr GhcPs
r LHsExpr GhcPs
z then forall a. a -> Maybe a
Just (LHsExpr GhcPs
r, [LHsExpr GhcPs]
ss) else forall a. a -> Maybe a
Just (LHsExpr GhcPs
r, LHsExpr GhcPs
y forall a. a -> [a] -> [a]
: [LHsExpr GhcPs]
ss)
    factor (L SrcSpanAnnA
_ (HsPar XPar GhcPs
_ LHsToken "(" GhcPs
_ y :: LHsExpr GhcPs
y@(L SrcSpanAnnA
_ HsApp{}) LHsToken ")" GhcPs
_)) = LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
factor LHsExpr GhcPs
y
    factor 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 = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
a GenLocated SrcSpanAnnA (HsExpr GhcPs)
b -> (String
a, forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA GenLocated SrcSpanAnnA (HsExpr GhcPs)
b)) [String]
substVars [LHsExpr GhcPs]
subts
          template :: LHsExpr GhcPs
template = [LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps (forall a b. (a -> b) -> [a] -> [b]
map (String -> LHsExpr GhcPs
strToVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(String, SrcSpan)]
tempSubts)
      in forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr SrcSpan
s [(String, SrcSpan)]
tempSubts (forall a. Outputable a => a -> String
unsafePrettyPrint LHsExpr GhcPs
template)
-- Rewrite @\x y -> x + y@ as @(+)@.
niceLambdaR [String
x,String
y] (L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_ (forall a b. View a b => a -> b
view -> Var_ String
x1) op :: LHsExpr GhcPs
op@(L SrcSpanAnnA
_ HsVar {}) (forall a b. View a b => a -> b
view -> Var_ String
y1)))
    | String
x forall a. Eq a => a -> a -> Bool
== String
x1, String
y forall a. Eq a => a -> a -> Bool
== String
y1, forall a. FreeVars a => a -> [String]
vars LHsExpr GhcPs
op forall a. Eq a => [a] -> [a] -> Bool
`disjoint` [String
x, String
y] = (LHsExpr GhcPs
op, \SrcSpan
s -> [forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr SrcSpan
s [] (forall a. Outputable a => a -> String
unsafePrettyPrint LHsExpr GhcPs
op)])
-- Rewrite @\x y -> f y x@ as @flip f@.
niceLambdaR [String
x, String
y] (forall a b. View a b => a -> b
view -> App2 GenLocated SrcSpanAnnA (HsExpr GhcPs)
op (forall a b. View a b => a -> b
view -> Var_ String
y1) (forall a b. View a b => a -> b
view -> Var_ String
x1))
  | String
x forall a. Eq a => a -> a -> Bool
== String
x1, String
y forall a. Eq a => a -> a -> Bool
== String
y1, forall a. FreeVars a => a -> [String]
vars GenLocated SrcSpanAnnA (HsExpr GhcPs)
op forall a. Eq a => [a] -> [a] -> Bool
`disjoint` [String
x, String
y] =
      ( LHsExpr GhcPs -> LHsExpr GhcPs
gen GenLocated SrcSpanAnnA (HsExpr GhcPs)
op
      , \SrcSpan
s -> [forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr SrcSpan
s [(String
"x", forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA GenLocated SrcSpanAnnA (HsExpr GhcPs)
op)] (forall a. Outputable a => a -> String
unsafePrettyPrint 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 :: LHsExpr GhcPs -> LHsExpr GhcPs
gen = forall a an. a -> LocatedAn an a
noLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall ann. EpAnn ann
EpAnnNotUsed (String -> LHsExpr GhcPs
strToVar String
"flip")
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. if forall a. Brackets a => a -> Bool
isAtom GenLocated SrcSpanAnnA (HsExpr GhcPs)
op then forall a. a -> a
id else 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 -> [forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr SrcSpan
s [(String
"a", forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA 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 = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS forall ann. EpAnn ann
EpAnnNotUsed [] LHsExpr GhcPs
e :: LGRHS GhcPs (LHsExpr GhcPs)
      grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grhss = GRHSs {grhssExt :: XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grhssExt = EpAnnComments
emptyComments, grhssGRHSs :: [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
grhssGRHSs=[LGRHS GhcPs (LHsExpr GhcPs)
grhs], grhssLocalBinds :: HsLocalBindsLR GhcPs GhcPs
grhssLocalBinds=forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds NoExtField
noExtField}
      match :: LMatch GhcPs (LHsExpr GhcPs)
match = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ Match {m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext=forall ann. EpAnn ann
EpAnnNotUsed, m_ctxt :: HsMatchContext GhcPs
m_ctxt=forall p. HsMatchContext p
LambdaExpr, m_pats :: [LPat GhcPs]
m_pats=forall a b. (a -> b) -> [a] -> [b]
map String -> LPat GhcPs
strToPat [String]
ss, m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss=GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grhss} :: LMatch GhcPs (LHsExpr GhcPs)
      matchGroup :: MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
matchGroup = MG {mg_ext :: XMG GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mg_ext=Origin
Generated, mg_alts :: XRec GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
mg_alts=forall a an. a -> LocatedAn an a
noLocA [LMatch GhcPs (LHsExpr GhcPs)
match]}
  in (forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
noExtField MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
matchGroup, 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 SrcSpanAnnA
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] -> forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (forall p. XIf p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsIf forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
a LHsExpr GhcPs
b LHsExpr GhcPs
c))

replaceBranches (L SrcSpanAnnA
s (HsCase XCase GhcPs
_ LHsExpr GhcPs
a (MG Origin
XMG GhcPs (LHsExpr GhcPs)
FromSource (L SrcSpanAnnL
l [LocatedAn
   AnnListItem (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
bs)))) =
  (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs]
f [LocatedAn
   AnnListItem (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
bs, forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p body.
XMG p body -> XRec p [LMatch p body] -> MatchGroup p body
MG Origin
Generated forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LMatch GhcPs (LHsExpr GhcPs)]
-> [LHsExpr GhcPs] -> [LMatch GhcPs (LHsExpr GhcPs)]
g [LocatedAn
   AnnListItem (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
bs)
  where
    f :: LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs]
    f :: LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs]
f (L SrcSpanAnnA
_ (Match XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ HsMatchContext GhcPs
CaseAlt [LPat GhcPs]
_ (GRHSs XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
xs HsLocalBindsLR GhcPs GhcPs
_))) = [GenLocated SrcSpanAnnA (HsExpr GhcPs)
x | (L SrcAnn NoEpAnns
_ (GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [GuardLStmt GhcPs]
_ GenLocated SrcSpanAnnA (HsExpr GhcPs)
x)) <- [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
xs]
    f LMatch GhcPs (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 SrcSpanAnnA
s1 (Match XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ HsMatchContext GhcPs
CaseAlt [LPat GhcPs]
a (GRHSs XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
ns HsLocalBindsLR GhcPs GhcPs
b)) : [LMatch GhcPs (LHsExpr GhcPs)]
rest) [LHsExpr GhcPs]
xs =
      forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
s1 (forall p body.
XCMatch p body
-> HsMatchContext p -> [LPat p] -> GRHSs p body -> Match p body
Match forall ann. EpAnn ann
EpAnnNotUsed forall p. HsMatchContext p
CaseAlt [LPat GhcPs]
a (forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
emptyComments [forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
a (forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS forall ann. EpAnn ann
EpAnnNotUsed [GuardLStmt GhcPs]
gs GenLocated SrcSpanAnnA (HsExpr GhcPs)
x) | (L SrcAnn NoEpAnns
a (GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [GuardLStmt GhcPs]
gs GenLocated SrcSpanAnnA (HsExpr GhcPs)
_), GenLocated SrcSpanAnnA (HsExpr GhcPs)
x) <- forall a b. [a] -> [b] -> [(a, b)]
zip [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
ns [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
as] HsLocalBindsLR GhcPs GhcPs
b)) forall a. a -> [a] -> [a]
: [LMatch GhcPs (LHsExpr GhcPs)]
-> [LHsExpr GhcPs] -> [LMatch GhcPs (LHsExpr GhcPs)]
g [LMatch GhcPs (LHsExpr GhcPs)]
rest [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
bs
      where  ([GenLocated SrcSpanAnnA (HsExpr GhcPs)]
as, [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
bs) = forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
ns) [LHsExpr GhcPs]
xs
    g [] [] = []
    g [LMatch GhcPs (LHsExpr 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 forall a. Eq a => a -> a -> Bool
== Int
2 = Bool
False
  | Bool
otherwise = 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 = forall a a' b. (a -> a') -> (a, b) -> (a', b)
first forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ((Bool, GenLocated SrcSpanAnnA (HsExpr GhcPs)),
    (GenLocated SrcSpanAnnA (HsExpr GhcPs), [String]))
g
  where
    g :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ((Bool, GenLocated SrcSpanAnnA (HsExpr GhcPs)),
    (GenLocated SrcSpanAnnA (HsExpr GhcPs), [String]))
g = forall a a' b. (a -> a') -> (a, b) -> (a', b)
first GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> (Bool, GenLocated SrcSpanAnnA (HsExpr GhcPs))
f 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 GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ((Bool, GenLocated SrcSpanAnnA (HsExpr GhcPs)),
    (GenLocated SrcSpanAnnA (HsExpr GhcPs), [String]))
g
    f :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> (Bool, GenLocated SrcSpanAnnA (HsExpr GhcPs))
f GenLocated SrcSpanAnnA (HsExpr GhcPs)
x = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool
False, GenLocated SrcSpanAnnA (HsExpr GhcPs)
x) (Bool
True, ) (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
op GenLocated SrcSpanAnnA (HsExpr 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 = (forall a. Data a => (Int -> a -> a) -> a -> a
descendIndex Int
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
g1 LHsExpr GhcPs
x, forall a w.
(Data a, Monoid w) =>
(Int -> a -> Writer w a) -> a -> (a, w)
descendIndex' Int
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> WriterT
     [String] Identity (GenLocated SrcSpanAnnA (HsExpr GhcPs))
g2 LHsExpr GhcPs
x)
  where
    g :: Int
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs),
    (GenLocated SrcSpanAnnA (HsExpr GhcPs), [String]))
g Int
i GenLocated SrcSpanAnnA (HsExpr GhcPs)
y = if Bool
a then (Int
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [String]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
f1 Int
i LHsExpr GhcPs
b LHsExpr GhcPs
z [String]
w, Int
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [String]
-> (GenLocated SrcSpanAnnA (HsExpr 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 GenLocated SrcSpanAnnA (HsExpr GhcPs)
y

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

    f :: Int
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [String]
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs),
    (GenLocated SrcSpanAnnA (HsExpr GhcPs), [String]))
f Int
i (L SrcSpanAnnA
_ (HsPar XPar GhcPs
_ LHsToken "(" GhcPs
_ LHsExpr GhcPs
y LHsToken ")" GhcPs
_)) GenLocated SrcSpanAnnA (HsExpr GhcPs)
z [String]
w
      | Bool -> Bool
not 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, GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs), [String])
removeBracket GenLocated SrcSpanAnnA (HsExpr 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 :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs), [String])
removeBracket = \case
          var :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
var@(L SrcSpanAnnA
_ HsVar{}) -> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
z, LHsExpr GhcPs -> String
varToStr GenLocated SrcSpanAnnA (HsExpr GhcPs)
var forall a. a -> [a] -> [a]
: [String]
w)
          GenLocated SrcSpanAnnA (HsExpr GhcPs)
other -> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
fromParen GenLocated SrcSpanAnnA (HsExpr GhcPs)
z, [String]
w)
    f Int
i GenLocated SrcSpanAnnA (HsExpr GhcPs)
y GenLocated SrcSpanAnnA (HsExpr GhcPs)
z [String]
w
      | Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
needBracketOld Int
i LHsExpr GhcPs
x GenLocated SrcSpanAnnA (HsExpr GhcPs)
y = (forall a. Brackets a => a -> a
addParen GenLocated SrcSpanAnnA (HsExpr GhcPs)
y, (forall a. Brackets a => a -> a
addParen GenLocated SrcSpanAnnA (HsExpr GhcPs)
z, [String]
w))
      -- https://github.com/mpickering/apply-refact/issues/7
      | forall {l}. GenLocated l (HsExpr GhcPs) -> Bool
isOp GenLocated SrcSpanAnnA (HsExpr GhcPs)
y = (GenLocated SrcSpanAnnA (HsExpr GhcPs)
y, (forall a. Brackets a => a -> a
addParen GenLocated SrcSpanAnnA (HsExpr GhcPs)
z, [String]
w))
    f Int
_ GenLocated SrcSpanAnnA (HsExpr GhcPs)
y GenLocated SrcSpanAnnA (HsExpr GhcPs)
z [String]
w = (GenLocated SrcSpanAnnA (HsExpr GhcPs)
y, (GenLocated SrcSpanAnnA (HsExpr GhcPs)
z, [String]
w))

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

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

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