{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns, MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-}
{-# 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 BasicTypes
import SrcLoc
import FastString
import RdrName
import OccName
import Bag(bagToList)
import GHC.Util.Brackets
import GHC.Util.View
import GHC.Util.FreeVars
import Control.Applicative
import Control.Monad.Trans.State
import Data.Data
import Data.Generics.Uniplate.Data
import Data.List.Extra
import Data.Tuple.Extra
import Refact (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 :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
dotApp x y = noLoc $ OpApp noExtField x (noLoc $ HsVar noExtField (noLoc $ mkVarUnqual (fsLit "."))) y
dotApps :: [LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps [] = error "GHC.Util.HsExpr.dotApps', does not work on an empty list"
dotApps [x] = x
dotApps (x : xs) = dotApp x (dotApps xs)
lambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda vs body = noLoc $ HsLam noExtField (MG noExtField (noLoc [noLoc $ Match noExtField LambdaExpr vs (GRHSs noExtField [noLoc $ GRHS noExtField [] body] (noLoc $ EmptyLocalBinds noExtField))]) Generated)
paren :: LHsExpr GhcPs -> LHsExpr GhcPs
paren x
| isAtom x = x
| otherwise = addParen x
universeParentExp :: Data a => a -> [(Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)]
universeParentExp xs = concat [(Nothing, x) : f x | x <- childrenBi xs]
where f p = concat [(Just (i,p), c) : f c | (i,c) <- zipFrom 0 $ children p]
apps :: [LHsExpr GhcPs] -> LHsExpr GhcPs
apps = foldl1' mkApp where mkApp x y = noLoc (HsApp noExtField x y)
fromApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]
fromApps (L _ (HsApp _ x y)) = fromApps x ++ [y]
fromApps x = [x]
childrenApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]
childrenApps (L _ (HsApp _ x y)) = childrenApps x ++ [y]
childrenApps x = children x
universeApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]
universeApps x = x : concatMap universeApps (childrenApps x)
descendAppsM :: Monad m => (LHsExpr GhcPs -> m (LHsExpr GhcPs)) -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
descendAppsM f (L l (HsApp _ x y)) = liftA2 (\x y -> L l $ HsApp noExtField x y) (descendAppsM f x) (f y)
descendAppsM f x = descendM f x
transformAppsM :: Monad m => (LHsExpr GhcPs -> m (LHsExpr GhcPs)) -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
transformAppsM f x = f =<< descendAppsM (transformAppsM f) x
descendIndex :: Data a => (Int -> a -> a) -> a -> a
descendIndex f x = flip evalState 0 $ flip descendM x $ \y -> do
i <- get
modify (+1)
pure $ f i y
descendBracket :: (LHsExpr GhcPs -> (Bool, LHsExpr GhcPs)) -> LHsExpr GhcPs -> LHsExpr GhcPs
descendBracket op x = descendIndex g x
where
g i y = if a then f i b else b
where (a, b) = op y
f i y@(L _ e) | needBracket i x y = addParen y
f _ y = y
rebracket1 :: LHsExpr GhcPs -> LHsExpr GhcPs
rebracket1 = descendBracket (True, )
appsBracket :: [LHsExpr GhcPs] -> LHsExpr GhcPs
appsBracket = foldl1 mkApp
where mkApp x y = rebracket1 (noLoc $ HsApp noExtField x y)
simplifyExp :: LHsExpr GhcPs -> LHsExpr GhcPs
simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp noExtField x (noLoc (HsPar noExtField y)))
simplifyExp e@(L _ (HsLet _ (L _ (HsValBinds _ (ValBinds _ binds []))) z)) =
case bagToList binds of
[L _ (FunBind _ _(MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _) [] (GRHSs _[L _ (GRHS _ [] y)] (L _ (EmptyLocalBinds _))))]) _) _ _)]
| occNameStr x `notElem` vars y && length [() | Unqual a <- universeBi z, a == rdrNameOcc x] <= 1 ->
transform f z
where f (view -> Var_ x') | occNameStr x == x' = paren y
f x = x
_ -> e
simplifyExp e = e
niceDotApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
niceDotApp (L _ (HsVar _ (L _ r))) b | occNameStr r == "$" = b
niceDotApp a b = dotApp a b
niceLambda :: [String] -> LHsExpr GhcPs -> LHsExpr GhcPs
niceLambda ss e = fst (niceLambdaR ss e)
allowRightSection :: String -> Bool
allowRightSection x = x `notElem` ["-","#"]
allowLeftSection :: String -> Bool
allowLeftSection x = x /= "#"
niceLambdaR :: [String]
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, R.SrcSpan
-> [Refactoring R.SrcSpan])
niceLambdaR xs (SimpleLambda [] x) = niceLambdaR xs x
niceLambdaR xs (L _ (HsPar _ x)) = niceLambdaR xs x
niceLambdaR (unsnoc -> Just (vs, v)) (view -> App2 f e (view -> Var_ v'))
| isDol f
, v == v'
, vars e `disjoint` [v]
= niceLambdaR vs e
niceLambdaR [v] (L _ (OpApp _ e f (view -> Var_ v')))
| isLexeme e
, v == v'
, vars e `disjoint` [v]
, L _ (HsVar _ (L _ fname)) <- f
, isSymOcc $ rdrNameOcc fname
= (noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField e f, \s -> [Replace Expr s [] (unsafePrettyPrint e)])
niceLambdaR (unsnoc -> Just (vs, v)) (L _ (HsApp _ f (view -> Var_ v')))
| v == v'
, vars f `disjoint` [v]
= niceLambdaR vs f
niceLambdaR (unsnoc -> Just (vs, v)) (L _ (SectionL _ (view -> Var_ v') f))
| v == v' = niceLambdaR vs f
niceLambdaR xs (SimpleLambda ((view -> PVar_ v):vs) x)
| v `notElem` xs = niceLambdaR (xs++[v]) $ lambda vs x
niceLambdaR [x] (view -> App2 op@(L _ (HsVar _ (L _ tag))) l r)
| isLexeme r, view l == Var_ x, x `notElem` vars r, allowRightSection (occNameStr tag) =
let e = rebracket1 $ addParen (noLoc $ SectionR noExtField op r)
in (e, \s -> [Replace Expr s [] (unsafePrettyPrint e)])
niceLambdaR [x] y
| Just (z, subts) <- factor y, x `notElem` vars z = (z, \s -> [mkRefact subts s])
where
factor :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
factor y@(L _ (HsApp _ ini lst)) | view lst == Var_ x = Just (ini, [ini])
factor y@(L _ (HsApp _ ini lst)) | Just (z, ss) <- factor lst
= let r = niceDotApp ini z
in if astEq r z then Just (r, ss) else Just (r, ini : ss)
factor (L _ (OpApp _ y op (factor -> Just (z, ss))))| isDol op
= let r = niceDotApp y z
in if astEq r z then Just (r, ss) else Just (r, y : ss)
factor (L _ (HsPar _ y@(L _ HsApp{}))) = factor y
factor _ = Nothing
mkRefact :: [LHsExpr GhcPs] -> R.SrcSpan -> Refactoring R.SrcSpan
mkRefact subts s =
let tempSubts = zipWith (\a b -> ([a], toSS b)) ['a' .. 'z'] subts
template = dotApps (map (strToVar . fst) tempSubts)
in Replace Expr s tempSubts (unsafePrettyPrint template)
niceLambdaR [x,y] (L _ (OpApp _ (view -> Var_ x1) op@(L _ HsVar {}) (view -> Var_ y1)))
| x == x1, y == y1, vars op `disjoint` [x, y] = (op, \s -> [Replace Expr s [] (unsafePrettyPrint op)])
niceLambdaR [x, y] (view -> App2 op (view -> Var_ y1) (view -> Var_ x1))
| x == x1, y == y1, vars op `disjoint` [x, y] =
( gen op
, \s -> [Replace Expr s [("x", toSS op)] (unsafePrettyPrint $ gen (strToVar "x"))]
)
where
gen = noLoc . HsApp noExtField (strToVar "flip")
niceLambdaR [] e = (e, const [])
niceLambdaR ss e =
let grhs = noLoc $ GRHS noExtField [] e :: LGRHS GhcPs (LHsExpr GhcPs)
grhss = GRHSs {grhssExt = noExtField, grhssGRHSs=[grhs], grhssLocalBinds=noLoc $ EmptyLocalBinds noExtField}
match = noLoc $ Match {m_ext=noExtField, m_ctxt=LambdaExpr, m_pats=map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs)
matchGroup = MG {mg_ext=noExtField, mg_origin=Generated, mg_alts=noLoc [match]}
in (noLoc $ HsLam noExtField matchGroup, const [])
replaceBranches :: LHsExpr GhcPs -> ([LHsExpr GhcPs], [LHsExpr GhcPs] -> LHsExpr GhcPs)
replaceBranches (L l (HsIf _ _ a b c)) = ([b, c], \[b, c] -> cL l (HsIf noExtField Nothing a b c))
replaceBranches (L s (HsCase _ a (MG _ (L l bs) FromSource))) =
(concatMap f bs, \xs -> cL s (HsCase noExtField a (MG noExtField (cL l (g bs xs)) Generated)))
where
f :: LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs]
f (L _ (Match _ CaseAlt _ (GRHSs _ xs _))) = [x | (L _ (GRHS _ _ x)) <- xs]
f _ = error "GHC.Util.HsExpr.replaceBranches: unexpected XMatch"
g :: [LMatch GhcPs (LHsExpr GhcPs)] -> [LHsExpr GhcPs] -> [LMatch GhcPs (LHsExpr GhcPs)]
g (L s1 (Match _ CaseAlt a (GRHSs _ ns b)) : rest) xs =
cL s1 (Match noExtField CaseAlt a (GRHSs noExtField [cL a (GRHS noExtField gs x) | (L a (GRHS _ gs _), x) <- zip ns as] b)) : g rest bs
where (as, bs) = splitAt (length ns) xs
g [] [] = []
g _ _ = error "GHC.Util.HsExpr.replaceBranches': internal invariant failed, lists are of differing lengths"
replaceBranches x = ([], \[] -> x)
needBracketOld :: Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
needBracketOld i parent child
| isDotApp parent, isDotApp child, i == 2 = False
| otherwise = needBracket i parent child
transformBracketOld :: (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)) -> LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs)
transformBracketOld op = first snd . g
where
g = first f . descendBracketOld g
f x = maybe (False, x) (True, ) (op x)
descendBracketOld :: (LHsExpr GhcPs -> ((Bool, LHsExpr GhcPs), LHsExpr GhcPs))
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, LHsExpr GhcPs)
descendBracketOld op x = (descendIndex g1 x, descendIndex g2 x)
where
g i y = if a then (f1 i b z, f2 i b z) else (b, z)
where ((a, b), z) = op y
g1 = (fst .) . g
g2 = (snd .) . g
f i (L _ (HsPar _ y)) z | not $ needBracketOld i x y = (y, z)
f i y z | needBracketOld i x y = (addParen y, addParen z)
f _ y z = (y, z)
f1 = ((fst .) .) . f
f2 = ((snd .) .) . f
fromParen1 :: LHsExpr GhcPs -> LHsExpr GhcPs
fromParen1 (L _ (HsPar _ x)) = x
fromParen1 x = x