HaRe-0.8.3.0: src/Language/Haskell/Refact/Refactoring/AddRmParam.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.Refact.Refactoring.AddRmParam
( addOneParameter, compAddOneParameter
, rmOneParameter, compRmOneParameter
) where
import qualified Data.Generics as SYB
import qualified GHC.SYB.Utils as SYB
import qualified GHC
import qualified Name as GHC
import qualified Outputable as GHC
import qualified Language.Haskell.GhcMod as GM
import Language.Haskell.GhcMod.Internal as GM
import Language.Haskell.Refact.API
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Transform
import Language.Haskell.GHC.ExactPrint.Utils
import System.Directory
import Data.Char
import Data.Foldable
import Data.Maybe
import Data.List hiding (delete)
import Data.Generics.Strafunski.StrategyLib.StrategyLib
-----------------------------------------------------------------------------------------------------
{- An argument can be added to the definition of a function or constant. Adding an argument to a constant
definition will change the constant definition to a function definition. The new parameter is always
added as the first parameter of the function. A default parameter will be added as the first argument
to each of the function's call site. Suppose a new parameter named 'p' is added to function 'f',
then default parameter will be defined automatically as p_f_i=undefined, where 'i' is an integer.
To ensure that the default parameter name does not cause name clash in the client modules, we take the
visble names both in the current module and in the client modules into account when creating the
name.
-}
-----------------------------------------------------------------------------------------------------
addOneParameter :: RefactSettings -> GM.Options -> FilePath -> String -> SimpPos -> IO [FilePath]
addOneParameter settings opts fileName paramName (row,col) = do
absFileName <- canonicalizePath fileName
runRefacSession settings opts (compAddOneParameter absFileName paramName (row,col))
compAddOneParameter :: FilePath -> String -> SimpPos -> RefactGhc [ApplyRefacResult]
compAddOneParameter fileName paramName (row, col) = do
if isVarId paramName
then
do
parseSourceFileGhc fileName
parsed <- getRefactParsed
nm <- getRefactNameMap
logParsedSource "compAdd entry"
targetModule <- getRefactTargetModule
logm $ "AddRmParam.compAdd:got targetModule"
let maybePn = locToNameRdrPure nm (row, col) parsed
case maybePn of
Just pn ->
do
logm $ "AddRmParam.compAdd:about to applyRefac for:pn=" ++ SYB.showData SYB.Parser 0 pn
-- make sure this name is defined in this module
if isFunOrPatName nm pn parsed
then do
exported <- isExported pn
if exported
then do
clients <- clientModsAndFiles targetModule
decls <- liftT $ hsDecls parsed
let inscopes = []
defaultArg <- mkTopLevelDefaultArgName pn paramName inscopes decls
logm $ "compAdd:defaultArg=" ++ showGhc defaultArg
(refactoredMod,_) <- applyRefac (doAddingParam pn paramName (Just defaultArg) True) RSAlreadyLoaded
refactoredClients <- mapM (addArgInClientMod pn defaultArg) clients
-- let refactoredClients = []
return $ refactoredMod:refactoredClients
else do
logm $ "compAdd:not exported"
(refactoredMod,_) <- applyRefac (doAddingParam pn paramName Nothing False) (RSFile fileName)
return [refactoredMod]
else error "Invalid cursor position or identifier is not a function/pattern name defined in this module!\n"
Nothing -> error "Invalid cursor position or identifier is not a function/pattern name defined in this module!\n"
else error $ "Invalid parameter name:" ++ paramName ++ "!"
-- ---------------------------------------------------------------------
doAddingParam :: GHC.Name -> String -> Maybe (GHC.Located GHC.RdrName) -> Bool
-> RefactGhc ()
doAddingParam pn newParam defaultArg isExported' = do
logm $ "doAddingParam entered:defaultArg=" ++ showGhc defaultArg
parsed <- getRefactParsed
-- logDataWithAnns "parsed" parsed
r <- applyTP (once_tdTP (failTP `adhocTP` inMod
`adhocTP` inMatch
-- `adhocTP` inPat
`adhocTP` inLet
-- `adhocTP` inAlt
`adhocTP` inLetStmt
)
`choiceTP` failure) parsed
putRefactParsed r emptyAnns
return ()
where
--1.pn is declared in top level
inMod :: GHC.ParsedSource -> RefactGhc GHC.ParsedSource
inMod modu = do
nm <- getRefactNameMap
decls <- liftT $ hsDecls modu
if not ( null (definingDeclsRdrNames nm [pn] decls False False))
then
do
logm $ "doAddingParam.inMod doing it"
ds <- liftT $ hsDecls modu
modu' <- doAdding modu ds
if isExported' && isExplicitlyExported nm pn modu
then addItemsToExport modu' (Just pn) False (Left [GHC.unLoc (fromJust defaultArg)])
else return modu'
else mzero
--2. pn is declared locally in the where clause of a match.
inMatch ::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)
-> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))
inMatch match
= do
nm <- getRefactNameMap
decls <- liftT $ hsDecls match
logm $ "doAddingParam.inMatch:decls=" ++ showGhc decls
if not ( null (definingDeclsRdrNames nm [pn] decls False False))
then doAdding match decls
else mzero
{-
--3. pn is declared locally in the where clause of a pattern binding.
inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)
| definingDecls [pn] ds False False/=[] = doAdding pat ds
inPat _ = mzero
-}
--4: pn is declared locally in a Let expression
inLet (letExp@(GHC.L _ (GHC.HsLet _ds _e)) :: GHC.LHsExpr GHC.RdrName)
= do
nm <- getRefactNameMap
decls <- liftT $ hsDecls letExp
-- logm $ "doAddingParam.inLet:decls=" ++ showGhc decls
if not ( null (definingDeclsRdrNames nm [pn] decls False False))
then doAdding letExp decls
else mzero
#if __GLASGOW_HASKELL__ <= 710
inLet ((GHC.L l (GHC.HsDo ctx stmts ptt)) :: GHC.LHsExpr GHC.RdrName)
#else
inLet ((GHC.L l (GHC.HsDo ctx (GHC.L ls stmts) ptt)) :: GHC.LHsExpr GHC.RdrName)
#endif
= do
nm <- getRefactNameMap
-- logm $ "doAddingParam.inHsDo:stmts=" ++ showGhc stmts
if not ( null (definingDeclsRdrNames' nm [pn] stmts))
then do
stmts' <- doAddingStmts stmts
stmts2 <- applyTP (once_tdTP (failTP `adhocTP` inMod
`adhocTP` inMatch
-- `adhocTP` inPat
`adhocTP` inLet
-- `adhocTP` inHsDo
-- `adhocTP` inAlt
`adhocTP` inLetStmt
)
`choiceTP` failure) stmts'
#if __GLASGOW_HASKELL__ <= 710
return (GHC.L l (GHC.HsDo ctx stmts2 ptt))
#else
return (GHC.L l (GHC.HsDo ctx (GHC.L ls stmts2) ptt))
#endif
else mzero
inLet _ = mzero
{-
--5. pn is declared locally in a case alternative.
inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)
| definingDecls [pn] ds False False/=[] = doAdding alt ds
inAlt _ = mzero
-}
--6.pn is declared locally in a let statement.
inLetStmt (letStmt@(GHC.L _ (GHC.LetStmt _stmts)):: GHC.ExprLStmt GHC.RdrName)
= do
nm <- getRefactNameMap
decls <- liftT $ hsDecls letStmt
if not ( null (definingDeclsRdrNames nm [pn] decls False False))
then doAdding letStmt decls
else mzero
inLetStmt _ = mzero
failure = idTP `adhocTP` modu
where modu (_::GHC.ParsedSource) = error "Refactoring failed"
doAdding :: (HasDecls t) => t -> [GHC.LHsDecl GHC.RdrName] -> RefactGhc t
doAdding parent ds = do
nm <- getRefactNameMap
if paramNameOk nm pn newParam ds
then do
ds' <- addParamsToDecls ds pn [mkRdrName newParam] --addFormalParam pn newParam ds
defaultParamPName <-if isNothing defaultArg
then mkLocalDefaultArgName pn newParam parent
else return (gfromJust "doAdding" defaultArg)
parent1 <- liftT $ replaceDecls parent ds'
parent' <- addDefaultActualArg False pn defaultParamPName parent1
parent''<- addDefaultActualArgDecl defaultParamPName parent' pn isExported'
ds2 <- liftT $ hsDecls parent''
ds'' <- addArgToSig pn ds2
parent3 <- liftT $ replaceDecls parent'' ds''
return parent3
else error " Refactoring failed."
doAddingStmts :: [GHC.ExprLStmt GHC.RdrName] -> RefactGhc [GHC.ExprLStmt GHC.RdrName]
doAddingStmts stmts = do
logDataWithAnns "doAddingStmts:stmts:" stmts
nm <- getRefactNameMap
if paramNameOk nm pn newParam stmts
then do
defaultParamPName <-if isNothing defaultArg
then mkLocalDefaultArgName pn newParam stmts
else return (gfromJust "doAddingStmts" defaultArg)
stmts' <- addDefaultActualArg False pn defaultParamPName stmts
return stmts'
else error " Refactoring failed."
-- ---------------------------------------------------------------------
-- |check whether the new parameter is a legal.
paramNameOk :: (SYB.Data t) => NameMap -> GHC.Name -> String -> t -> Bool
paramNameOk nm pn newParam t
= (fromMaybe True) (applyTU (once_tdTU (failTU `adhocTU` decl
`adhocTU` bind)) t)
where
decl :: GHC.LHsDecl GHC.RdrName -> Maybe Bool
decl (GHC.L l (GHC.ValD d)) = bind (GHC.L l d)
decl _ = mzero
bind :: GHC.LHsBind GHC.RdrName -> Maybe Bool
#if __GLASGOW_HASKELL__ <= 710
bind (GHC.L _ (GHC.FunBind n _i (GHC.MG matches _a _ptt _o) _co _fvs _))
#else
bind (GHC.L _ (GHC.FunBind n (GHC.MG matches _a _ptt _o) _co _fvs _))
#endif
| rdrName2NamePure nm n == pn
= do results' <- mapM checkInMatch matches
Just (all (==True) results')
bind (GHC.L _ (GHC.PatBind _pat _rhs _ty _fvs _t))
= error "Parameter can not be added to complex pattern binding"
bind _ = mzero
checkInMatch match
= do let (f,d) = hsFDNamesFromInsideRdrPure nm match
if elem newParam (f `union` d)
then error "The new parameter name will cause name clash or semantics change, please choose another name!"
else return True
-- ---------------------------------------------------------------------
-- |add the default argument declaration right after the declaration defining pn
addDefaultActualArgDecl :: (SYB.Data t) => GHC.Located GHC.RdrName -> t -> GHC.Name -> Bool -> RefactGhc t
addDefaultActualArgDecl defaultParamPName parent pn isExported' = do
defaultArgDecl <- parseDeclWithAnns ((showGhc defaultParamPName) ++ " = undefined")
nm <- getRefactNameMap
let inParent = findLRdrName nm pn parent
if not inParent && not isExported'
then return parent
else addDecl parent (Just pn) ([defaultArgDecl],Nothing)
-- ---------------------------------------------------------------------
-- |suppose function name is f, parameter name is p, then the default argument
-- name is like f_p.
mkLocalDefaultArgName :: (SYB.Data t)
=> GHC.Name -> String -> t -> RefactGhc (GHC.Located GHC.RdrName)
mkLocalDefaultArgName fun paramName t = do
logm $ "mkLocalDefaultArgName"
(f,d) <- hsFDNamesFromInsideRdr t
vs <- hsVisibleNamesRdr fun t -- ++AZ++ TODO : FindEntity on fun will fail in a RdrName AST
let name = mkNewName ((showGhc fun)++"_"++paramName) (nub (f `union` d `union` vs)) 0
loc <- liftT $ uniqueSrcSpanT
let vn = (GHC.L loc (mkRdrName name))
liftT $ addSimpleAnnT vn (DP (0,1)) [((G GHC.AnnVal),DP (0,0))]
return vn
-- ---------------------------------------------------------------------
mkTopLevelDefaultArgName :: (SYB.Data t,GHC.Outputable a)
=> a -> String -> [String] -> t
-> RefactGhc (GHC.Located GHC.RdrName)
mkTopLevelDefaultArgName fun paramName inscopeNames t = do
(f,d) <- hsFDNamesFromInsideRdr t
let name = mkNewName ((showGhc fun)++"_"++paramName) (nub (f `union` d `union` inscopeNames)) 0
loc <- liftT $ uniqueSrcSpanT
let vn = (GHC.L loc (mkRdrName name))
liftT $ addSimpleAnnT vn (DP (0,1)) [((G GHC.AnnVal),DP (0,0))]
return vn
-- ---------------------------------------------------------------------
-- |Add the default argument to each call site of the function receiving the new parameter (AZ)
addDefaultActualArg :: (SYB.Data t)
=> Bool -- ^If True recursively add the parameter to all
-- occurences of the function call site. If False,
-- stop the recursion when hitting the function
-- itself.
-> GHC.Name -- ^ The function name to receive the new parameter
-> GHC.Located GHC.RdrName -- ^The new parameter name
-- ++AZ++: why is it located?
-> t -- ^The AST fragment to be updated
-> RefactGhc t
addDefaultActualArg recursion pn argPName t = do
logm $ "addDefaultActualArg:(recursion,pn,argPName):" ++ showGhc (recursion,pn,argPName)
logDataWithAnns "addDefaultActualArg:t=:" t
nm <- getRefactNameMap
if recursion then (applyTP (stop_tdTP (failTP `adhocTP` (funApp nm)))) t
else (applyTP (stop_tdTP (failTP `adhocTP` (inDecl nm)
`adhocTP` (funApp nm)))) t
where
inDecl :: NameMap -> GHC.LHsDecl GHC.RdrName -> RefactGhc (GHC.LHsDecl GHC.RdrName)
#if __GLASGOW_HASKELL__ <= 710
inDecl nm fun@(GHC.L _ (GHC.ValD (GHC.FunBind n _i _ _co _fvs _)))
#else
inDecl nm fun@(GHC.L _ (GHC.ValD (GHC.FunBind n _ _co _fvs _)))
#endif
| rdrName2NamePure nm n == pn
= return fun -- Stop the recursion by not returning mzero
-- inDecl (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)
-- | pn == patToPN ps
-- = return pat
inDecl _ _ = mzero
funApp :: NameMap -> GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName)
#if __GLASGOW_HASKELL__ <= 710
funApp nm (expr@(GHC.L l (GHC.HsVar n))::GHC.LHsExpr GHC.RdrName)
#else
funApp nm (expr@(GHC.L l (GHC.HsVar (GHC.L _ n)))::GHC.LHsExpr GHC.RdrName)
#endif
| rdrName2NamePure nm (GHC.L l n) == pn = do
logm $ "addDefaultActualArg.funApp:expr=" ++ showGhc expr
addParamToExp expr (GHC.unLoc argPName)
funApp _ _ = mzero
-- ---------------------------------------------------------------------
-- | Add a parameter to a 'GHC.HsVar' expression
addParamToExp :: GHC.LHsExpr GHC.RdrName -> GHC.RdrName
-> RefactGhc (GHC.LHsExpr GHC.RdrName)
addParamToExp (expr@(GHC.L _ (GHC.HsVar _))) argPName = do
lp <- liftT uniqueSrcSpanT
la <- liftT uniqueSrcSpanT
lv <- liftT uniqueSrcSpanT
#if __GLASGOW_HASKELL__ <= 710
let e2 = GHC.L lv (GHC.HsVar argPName)
liftT $ addSimpleAnnT e2 (DP (0,1)) [((G GHC.AnnVal),DP (0,0))]
#else
let lname = GHC.L lv argPName
let e2 = GHC.L lv (GHC.HsVar lname)
liftT $ addSimpleAnnT e2 (DP (0,1)) [((G GHC.AnnVal),DP (0,0))]
#endif
let ret = GHC.L lp (GHC.HsPar (GHC.L la (GHC.HsApp expr e2)))
liftT $ addSimpleAnnT ret (DP (0,0)) [((G GHC.AnnOpenP),DP (0,0)),((G GHC.AnnCloseP),DP (0,0))]
liftT $ transferEntryDPT expr ret
liftT $ setEntryDPT expr (DP (0,0))
return ret
addParamToExp x _
= error $ "AddRmParam.addParamToExp: can only add param to HsVar, got:" ++ showGhc x
-- ---------------------------------------------------------------------
-- |Add type arg to type siginature
addArgToSig :: GHC.Name -> [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName]
addArgToSig pn decls = do
nm <- getRefactNameMap
let (before,after) = break (\d -> definesSigDRdr nm pn d) decls
in if null after
then return decls
else do newSig<-addArgToSig' [(head after)] --no problem with head.
return (before++newSig++(tail after))
where
addArgToSig' :: [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName]
#if __GLASGOW_HASKELL__ <= 710
addArgToSig' sig@[(GHC.L l (GHC.SigD (GHC.TypeSig is tp pr)))] = do
#else
addArgToSig' sig@[(GHC.L l (GHC.SigD (GHC.TypeSig is typ@(GHC.HsIB ivs (GHC.HsWC wcs mwc tp)))))] = do
#endif
nm <- getRefactNameMap
let tVar = mkNewTypeVarName sig
#if __GLASGOW_HASKELL__ <= 710
typeVar <- newTypeVar tVar tp
#else
typeVar' <- newTypeVar tVar tp
let typeVar = GHC.HsIB ivs (GHC.HsWC wcs mwc typeVar')
#endif
let newSig=if length is==1
#if __GLASGOW_HASKELL__ <= 710
then --the type sig only defines the type for pn
[GHC.L l (GHC.SigD (GHC.TypeSig is typeVar pr))]
else --otherwise, seperate it into two type signatures.
[GHC.L l (GHC.SigD (GHC.TypeSig (filter (\x->rdrName2NamePure nm x/=pn) is) tp pr)),
GHC.L l (GHC.SigD (GHC.TypeSig (filter (\x->rdrName2NamePure nm x==pn) is) typeVar pr))]
#else
then --the type sig only defines the type for pn
[GHC.L l (GHC.SigD (GHC.TypeSig is typeVar))]
else --otherwise, seperate it into two type signatures.
[GHC.L l (GHC.SigD (GHC.TypeSig (filter (\x->rdrName2NamePure nm x/=pn) is) typ)),
GHC.L l (GHC.SigD (GHC.TypeSig (filter (\x->rdrName2NamePure nm x==pn) is) typeVar))]
#endif
return newSig
addArgToSig' sig = do
logm $ "addArgToSig':not processing " ++ showGhc sig
return sig
-- compose a type application using type expressions tv and tp
newTypeVar :: String -> GHC.LHsType GHC.RdrName -> RefactGhc (GHC.LHsType GHC.RdrName)
newTypeVar tVar tp = do
ls <- liftT $ uniqueSrcSpanT
lv <- liftT $ uniqueSrcSpanT
#if __GLASGOW_HASKELL__ <= 710
let tv = GHC.L lv (GHC.HsTyVar (mkRdrName tVar))
liftT $ addSimpleAnnT tv (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]
#else
let lname = GHC.L lv (mkRdrName tVar)
let tv = GHC.L lv (GHC.HsTyVar lname)
liftT $ addSimpleAnnT lname (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]
#endif
let typ = GHC.L ls (GHC.HsFunTy tv tp)
liftT $ addSimpleAnnT typ (DP (0,1)) [((G GHC.AnnRarrow),DP (0,1))]
return typ
-- make a fresh type variable name. the new name is the first letter in
-- the alphabet which is not used in the type signature.
mkNewTypeVarName :: [GHC.LHsDecl GHC.RdrName] -> String
mkNewTypeVarName sig
=mkANewName "a" $ map showGhc $ (snd.hsTypeVbls) sig
where mkANewName initName v
=if elem initName v
then mkANewName ((intToDigit (digitToInt(head initName)+1)):tail initName) v
else initName
-- ---------------------------------------------------------------------
addArgInClientMod :: GHC.Name -> GHC.Located GHC.RdrName -> TargetModule -> RefactGhc ApplyRefacResult
addArgInClientMod pnt defaultArg serverModName = do
(r,_) <- applyRefac (addArgInClientMod' pnt defaultArg (GM.mpModule serverModName)) (RSTarget serverModName)
return r
addArgInClientMod' :: GHC.Name -> GHC.Located GHC.RdrName -> GHC.ModuleName -> RefactGhc ()
addArgInClientMod' pnt defaultArg serverModName = do
parsed <- getRefactParsed
let pn = pnt
qual <- hsQualifier pnt
if qual == []
then return ()
else do
mod' <- addItemsToImport serverModName (Just pn) (Left [GHC.unLoc defaultArg]) parsed
mod'' <- addItemsToExport mod' (Just pn) False (Left [GHC.unLoc defaultArg])
mod3 <- addDefaultActualArgInClientMod pn defaultArg mod''
putRefactParsed mod3 emptyAnns
return ()
-- ---------------------------------------------------------------------
-- |Add default actual argument to pn in all the calling places.
addDefaultActualArgInClientMod :: (SYB.Data t)
=> GHC.Name -> GHC.Located GHC.RdrName -> t
-> RefactGhc t
addDefaultActualArgInClientMod pn argPName t = do
logm $ "addDefaultActualArgInClientMod entered:argPName=" ++ showGhc argPName
nm <- getRefactNameMap
r <- applyTP (stop_tdTP (failTP `adhocTP` (funApp nm))) t
return r
where
#if __GLASGOW_HASKELL__ <= 710
funApp nm (expr@((GHC.L l (GHC.HsVar pname )))::GHC.LHsExpr GHC.RdrName)
#else
funApp nm (expr@((GHC.L l (GHC.HsVar (GHC.L _ pname) )))::GHC.LHsExpr GHC.RdrName)
#endif
| GHC.nameUnique (rdrName2NamePure nm (GHC.L l pname)) == GHC.nameUnique pn
= do
logm $ "addDefaultActualArgInClientMod:hit"
-- vs <- hsVisibleNamesRdr (GHC.L l pname) t
let argExp = GHC.unLoc argPName
addParamToExp expr argExp
funApp _ _ = mzero
-------------------------------End of adding a parameter-----------------------------------
-----------------------------------------------------------------------------------------------------
{-Refactoring: Remove a parameter
Description: The refactoring removes a user specified formal parameter in a function binding,and
the corresponding actual parameters in all calling places of this function. The
condition acompanying this refactoring is that the parameter to be removed is not being used.
--To select a parameter, just stop the cursor at any position between the start and end position of this parameter.
-}
-----------------------------------------------------------------------------------------------------
-- |The refactoring removes a user specified formal parameter in a function
-- binding,and the corresponding actual parameters in all calling places of this
-- function. The condition acompanying this refactoring is that the parameter to
-- be removed is not being used.
-- The @SimpPos@ should be somwewhere inside the parameter to be removed
rmOneParameter :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath]
rmOneParameter settings opts fileName (row,col) = do
absFileName <- canonicalizePath fileName
runRefacSession settings opts (compRmOneParameter absFileName (row,col))
compRmOneParameter :: FilePath -> SimpPos -> RefactGhc [ApplyRefacResult]
compRmOneParameter fileName (row, col) = do
parseSourceFileGhc fileName
-- logParsedSource "compRm entry"
-- pn is the function names.
-- nth is the nth paramter of pn is to be removed,index starts from 0.
mp <- getParam (row,col)
case mp of
Nothing -> error "Invalid cursor position!" -- cursor doesn't stop at a parameter position.
Just (pn,pnth) -> do
logm $ "compRm:(pn,pnth)=" ++ showGhc (pn,pnth)
exported <- isExported pn
if exported
then do
logm $ "compRm: exported"
(refactoredMod,_) <- applyRefac (doRmParam pn pnth) (RSFile fileName)
targetModule <- getRefactTargetModule
clients <- clientModsAndFiles targetModule
logm $ "compRm: clients:" ++ showGhc clients
refactoredClients <- mapM (rmParamInClientMod pn pnth) clients
-- let refactoredClients = []
return $ refactoredMod:refactoredClients
else do
logm $ "compRm:not exported"
(refactoredMod,_) <- applyRefac (doRmParam pn pnth) (RSFile fileName)
return [refactoredMod]
-- ---------------------------------------------------------------------
--pn: function name; nth: the index of the parameter to be removed.
doRmParam :: GHC.Name -> Int -> RefactGhc ()
doRmParam pn nTh = do
logm $ "doRmParam entered:(pn,nth)=" ++ showGhc (pn,nTh)
parsed <- getRefactParsed
r <- applyTP ((once_tdTP (failTP `adhocTP` inMod
`adhocTP` inMatch
-- `adhocTP` inPat
`adhocTP` inLet
-- `adhocTP` inAlt
`adhocTP` inLetStmt
))
`choiceTP` failure) parsed
logm $ "doRmParam after applyTP"
putRefactParsed r emptyAnns
logParsedSource "doRmParam:parsed after"
return ()
where
--1. pn is declared in top level.
inMod :: GHC.ParsedSource -> RefactGhc GHC.ParsedSource
inMod modu = doRemoving' modu
-- --2. pn is declared locally in the where clause of a match.
inMatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))
#if __GLASGOW_HASKELL__ <= 710
inMatch match@(GHC.L _ (GHC.Match (Just (_fun,_)) _pats _mtyp (GHC.GRHSs _rhs _ds)))
#else
inMatch match@(GHC.L _ (GHC.Match (GHC.FunBindMatch _fun _) _pats _mtyp (GHC.GRHSs _rhs _ds)))
#endif
= doRemoving' match
inMatch _ = mzero
-- --3. pn is declared locally in the where clause of a pattern binding.
-- inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)
-- | definingDecls [pn] ds False False/=[] = doRemoving pat ds
-- inPat _=mzero
-- --4: pn is declared locally in a Let expression
inLet :: GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName)
inLet letExp@(GHC.L _ (GHC.HsLet _bs _e))
= doRemoving' letExp
#if __GLASGOW_HASKELL__ <= 710
inLet (GHC.L l (GHC.HsDo ctx stmts ptt))
#else
inLet (GHC.L l (GHC.HsDo ctx (GHC.L ls stmts) ptt))
#endif
= do
nm <- getRefactNameMap
if not ( null (definingDeclsRdrNames' nm [pn] stmts))
then do
stmts' <- doRemovingStmts stmts
#if __GLASGOW_HASKELL__ <= 710
return (GHC.L l (GHC.HsDo ctx stmts' ptt))
#else
return (GHC.L l (GHC.HsDo ctx (GHC.L ls stmts') ptt))
#endif
else mzero
inLet _ = mzero
-- --5. pn is declared locally in a case alternative.
-- inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)
-- | definingDecls [pn] ds False False/=[] = doRemoving alt ds
-- inAlt _=mzero
-- --6.pn is declared locally in a let statement.
inLetStmt :: GHC.ExprLStmt GHC.RdrName -> RefactGhc (GHC.ExprLStmt GHC.RdrName)
inLetStmt letStmt@(GHC.L _ (GHC.LetStmt _))
= doRemoving' letStmt
inLetStmt _ = mzero
failure = idTP `adhocTP` modu
where modu (_m::GHC.ParsedSource) = error "Refactoring failed"
-- ------------------------
doRemoving' parent = do
nm <- getRefactNameMap
decls <- liftT $ hsDecls parent
if not ( null (definingDeclsRdrNames nm [pn] decls False False))
then doRemoving parent decls
else mzero
doRemoving :: (HasDecls t) => t -> [GHC.LHsDecl GHC.RdrName] -> RefactGhc t
doRemoving parent ds --PROBLEM: How about doRemoving fails?
=do
-- Check the preconditions, will error on failure
void $ rmFormalArg pn nTh False True =<< rmNthArgInFunCall pn nTh ds
-- preconditions passed, do the transformation
ds' <- rmNthArgInSig pn nTh =<< rmFormalArg pn nTh True False ds
ds'' <- liftT $ replaceDecls parent ds'
rmNthArgInFunCall pn nTh ds''
doRemovingStmts :: [GHC.ExprLStmt GHC.RdrName] -> RefactGhc [GHC.ExprLStmt GHC.RdrName]
doRemovingStmts stmts
=do
-- Check the preconditions, will error on failure
void $ rmFormalArg pn nTh False True =<< rmNthArgInFunCall pn nTh stmts
-- preconditions passed, do the transformation
stmts' <- rmFormalArg pn nTh True False stmts
rmNthArgInFunCall pn nTh stmts'
-- |Just remove the nth formal parameter.
rmFormalArg :: (SYB.Data t) => GHC.Name -> Int -> Bool -> Bool -> t -> RefactGhc t
rmFormalArg pn' nTh' updateToks checking t = do
logm $ "rmFormalArg:(pn,nTh,updateToks,checking)=" ++ showGhc (pn',nTh',updateToks,checking)
-- logDataWithAnns "rmFormalArg:t=" t
nm <- getRefactNameMap
applyTP (stop_tdTP (failTP `adhocTP` (rmInMatch nm))) t
where
-- a formal parameter only exists in a match
#if __GLASGOW_HASKELL__ <= 710
rmInMatch nm (match@(GHC.L l (GHC.Match (Just (fun,b)) pats typ (GHC.GRHSs rhs decls)))::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))
#else
rmInMatch nm (match@(GHC.L l (GHC.Match (GHC.FunBindMatch fun b) pats typ (GHC.GRHSs rhs decls)))::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))
#endif
| rdrName2NamePure nm fun == pn' =
let pat = pats!!nTh' --get the nth formal parameter
pats' = take nTh' pats ++ drop (nTh' + 1) pats
pNames = map (rdrName2NamePure nm) $ hsNamessRdr pat --get all the names in this pat. (the pat may be just be a variable)
in if checking && not ( all (==False) ((map (flip (findNameInRdr nm) rhs) pNames)) && --not used in rhs
all (==False) ((map (flip (findNameInRdr nm) decls) pNames))) --not used in the where clause
then error "This parameter can not be removed, as it is used!"
else do
-- If we have removed the last parametwer, make
-- sure the AnnEqual annotation takes its spacing
-- from the original parameter spacing
when (null pats') $ do
dp <- liftT $ getEntryDPT (ghead "rmFormalArg" pats)
logm $ "rmFormalArg.rmInMatch:dp=" ++ show dp
liftT $ setAnnKeywordDP match (G GHC.AnnEqual) dp
#if __GLASGOW_HASKELL__ <= 710
return (GHC.L l (GHC.Match (Just (fun,b)) pats' typ (GHC.GRHSs rhs decls)))
#else
return (GHC.L l (GHC.Match (GHC.FunBindMatch fun b) pats' typ (GHC.GRHSs rhs decls)))
#endif
rmInMatch _ _ = mzero
-- ---------------------------------------------------------------------
-- |Remove the nth argument of function pn in all the calling places. The index
-- for the first argument is zero.
rmNthArgInFunCall :: (SYB.Data t) => GHC.Name -> Int -> t -> RefactGhc t
rmNthArgInFunCall pn nTh t = do
nm <- getRefactNameMap
applyTP (stop_tdTP (failTP `adhocTP` (funApp nm))) t
where
funApp nm (expr@(GHC.L _ (GHC.HsPar (GHC.L _ (GHC.HsApp e1 _e2))))::GHC.LHsExpr GHC.RdrName)
| nTh == 0 && Just pn == expToNameRdr nm e1
= do
liftT $ transferEntryDPT expr e1
return e1 -- handle the case like '(fun x) => fun "
funApp nm (expr@(GHC.L _ (GHC.HsApp _e1 _e2))) = do
--test if this application is a calling of fun pn.
let expu = unfoldHsApp expr
ed <- liftT $ getEntryDPT expr
if Just pn == (expToNameRdr nm.snd.(ghead "rmNthArgInFunCall")) expu
then do
let (before,after)=splitAt (nTh+1) expu --remove the nth argument
let exp' = (foldHsApp (before++tail after)) --reconstruct the function application.
liftT $ setEntryDPT exp' ed
return exp'
else mzero
funApp _ _ = mzero
-- |deconstruct a function application into a list of expressions.
unfoldHsApp :: GHC.LHsExpr GHC.RdrName -> [(GHC.SrcSpan, GHC.LHsExpr GHC.RdrName)]
unfoldHsApp expr =
case expr of
(GHC.L l (GHC.HsApp e1 e2)) -> unfoldHsApp e1 ++ [(l,e2)]
_ -> [(GHC.noSrcSpan,expr)]
-- |reconstruct a function application by a list of expressions.
foldHsApp :: [(GHC.SrcSpan, GHC.LHsExpr GHC.RdrName)] -> GHC.LHsExpr GHC.RdrName
foldHsApp [] = error "foldHsApp:empty list"
foldHsApp exps = snd $ foldl1 (\(_l1,e1) (l2,e2) -> (l2,GHC.L l2 (GHC.HsApp e1 e2))) exps
-- ---------------------------------------------------------------------
rmNthArgInSig :: GHC.Name -> Int -> [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName]
rmNthArgInSig pn nTh decls = do
nm <- getRefactNameMap
let (before,after)=break (\d ->definesSigDRdr nm pn d) decls
if null after
then return decls
else do newSig<-rmNthArgInSig' nm [(head after)] --no problem with 'head'
return (before++newSig++(tail after))
where
#if __GLASGOW_HASKELL__ <= 710
rmNthArgInSig' nm [GHC.L l (GHC.SigD (GHC.TypeSig is typ@(GHC.L lt (GHC.HsForAllTy ex wc bnd ctx tp)) c))]
#else
-- rmNthArgInSig' nm [GHC.L l (GHC.SigD (GHC.TypeSig is typ@(GHC.HsIB ivs (GHC.HsWC wcs mwc (GHC.L lt (GHC.HsForAllTy bnd tp))))))]
rmNthArgInSig' nm [GHC.L l (GHC.SigD (GHC.TypeSig is typ@(GHC.HsIB ivs (GHC.HsWC wcs mwc tp))))]
#endif
=do
ed <- liftT $ getEntryDPT tp
let (GHC.L lp tp') = rmNth tp
lp' <- liftT uniqueSrcSpanT
liftT $ modifyAnnsT $ copyAnn (GHC.L lp tp') (GHC.L lp' tp')
liftT $ setEntryDPT (GHC.L lp' tp') ed
#if __GLASGOW_HASKELL__ <= 710
let typ' = GHC.L lt (GHC.HsForAllTy ex wc bnd ctx (GHC.L lp' tp'))
#else
-- let typ' = GHC.HsIB ivs (GHC.HsWC wcs mwc (GHC.L lt (GHC.HsForAllTy bnd (GHC.L lp' tp'))))
let typ' = GHC.HsIB ivs (GHC.HsWC wcs mwc (GHC.L lp' tp'))
#endif
newSig <- liftT $ if length is ==1
then --this type signature only defines the type of pn
#if __GLASGOW_HASKELL__ <= 710
return [GHC.L l (GHC.SigD (GHC.TypeSig is typ' c))]
#else
return [GHC.L l (GHC.SigD (GHC.TypeSig is typ'))]
#endif
else do --this type signature also defines the type of other ids.
let otherNames = filter (\x->rdrName2NamePure nm x/=pn) is
[thisName] = filter (\x->rdrName2NamePure nm x==pn) is
removeTrailingCommaT thisName
removeTrailingCommaT (last otherNames)
ls <- uniqueSrcSpanT
#if __GLASGOW_HASKELL__ <= 710
let otherSig = GHC.L l (GHC.SigD (GHC.TypeSig otherNames typ c))
thisSig = GHC.L ls (GHC.SigD (GHC.TypeSig [thisName] typ' c))
#else
let otherSig = GHC.L l (GHC.SigD (GHC.TypeSig otherNames typ))
thisSig = GHC.L ls (GHC.SigD (GHC.TypeSig [thisName] typ'))
#endif
modifyAnnsT $ copyAnn otherSig thisSig
clearPriorComments thisSig
setEntryDPT thisSig (DP (2,0))
return [otherSig,thisSig]
return newSig
rmNthArgInSig' _nm sig = return sig
rmNth tp = let (before,after)=splitAt nTh (unfoldHsTypApp tp)
in (foldHsTypApp (before ++ tail after))
--deconstruct a type application into a list of types
unfoldHsTypApp :: GHC.LHsType GHC.RdrName -> [(GHC.SrcSpan,GHC.LHsType GHC.RdrName)]
unfoldHsTypApp typ =
case typ of (GHC.L l (GHC.HsFunTy t1 t2)) ->(l,t1):unfoldHsTypApp t2
_ ->[(GHC.noSrcSpan,typ)]
--reconstruct a type application by a list of type expression.
foldHsTypApp :: [(GHC.SrcSpan,GHC.LHsType GHC.RdrName)] -> GHC.LHsType GHC.RdrName
foldHsTypApp [] = error "foldHsTypApp:empty list"
foldHsTypApp ts=snd $ foldr1 (\(l1,t1) (_l2,t2)->(l1,GHC.L l1 (GHC.HsFunTy t1 t2))) ts
-- ---------------------------------------------------------------------
-- |Get the function name and the index of the parameter to be removed from the
-- cursor position.
getParam :: SimpPos -> RefactGhc (Maybe (GHC.Name,Int))
getParam pos = do
nm <- getRefactNameMap
parsed <- getRefactParsed
let r = applyTU (once_tdTU (failTU `adhocTU` inMatch)) parsed
case r of
Nothing -> return Nothing
Just (ln,i) -> return $ Just (rdrName2NamePure nm ln,i)
where
#if __GLASGOW_HASKELL__ <= 710
inMatch ((GHC.Match (Just (fun,_)) pats _mtyp _grhs)::GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName))
#else
inMatch ((GHC.Match (GHC.FunBindMatch fun _) pats _mtyp _grhs)::GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName))
#endif
= case locToRdrName pos pats of
Nothing -> Nothing
Just _ln -> if isNothing element
then error "Invalid cursor position!" -- cursor doesn't stop at a parameter position.
else Just (fun, fromJust (elemIndex (fromJust element) paramPosRanges))
where
paramPosRanges = map GHC.getLoc pats
element = find (inRange pos) paramPosRanges
inMatch _ = Nothing
inRange pos' ss = pos' >= startPos && pos'<=endPos
where (startPos,endPos) = (ss2pos ss,ss2posEnd ss)
-- ---------------------------------------------------------------------
rmParamInClientMod :: GHC.Name -> Int -> TargetModule -> RefactGhc ApplyRefacResult
rmParamInClientMod pn nTh serverModName = do
logm $ "rmParamInClientMod:serverModName" ++ showGhc serverModName
(r,_) <- applyRefac (rmNthArgInFunCallMod pn nTh) (RSTarget serverModName)
return r
rmNthArgInFunCallMod :: GHC.Name -> Int -> RefactGhc ()
rmNthArgInFunCallMod pn nTh = do
parsed <- getRefactParsed
newNames <- equivalentNameInNewMod pn
logm $ "rmNthArgInFunCallMod:(newNames)=" ++ showGhcQual newNames
case newNames of
[] -> return ()
[_pnt] -> do
parsed' <- rmNthArgInFunCall pn nTh parsed
putRefactParsed parsed' emptyAnns
return ()
_ns -> error "HaRe: rmParam: more than one name matches"