module Language.Haskell.Refact.Refactoring.Renaming
( rename
, compRename
) 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 RdrName as GHC
import Control.Monad
import Data.Generics.Strafunski.StrategyLib.StrategyLib hiding (liftIO,MonadPlus,mzero)
import Data.List
import Language.Haskell.GHC.ExactPrint
import Language.Haskell.GHC.ExactPrint.Utils
import Language.Haskell.Refact.API
import System.Directory
import qualified Language.Haskell.GhcMod as GM (Options(..))
import qualified Data.Map as Map
rename :: RefactSettings
-> GM.Options
-> FilePath
-> String
-> SimpPos
-> IO [FilePath]
rename settings opts fileName newName (row,col) = do
absFileName <- canonicalizePath fileName
runRefacSession settings opts (compRename absFileName newName (row,col))
compRename :: FilePath -> String -> SimpPos -> RefactGhc [ApplyRefacResult]
compRename fileName newName (row,col) = do
logm $ "Renaming.comp: (fileName,newName,(row,col))=" ++ show (fileName,newName,(row,col))
parseSourceFileGhc fileName
parsed <- getRefactParsed
modu <- getModule
targetModule <- getRefactTargetModule
nm <- getRefactNameMap
let modName = maybe (GHC.mkModuleName "Main") fst $ getModuleName parsed
case locToRdrName (row, col) parsed of
Just pn'@(GHC.L l rdrName) -> do
let n = rdrName2NamePure nm pn'
pn = GHC.L l n
logm $ "Renaming:(n,modu)=" ++ showGhc (n,modu)
let occName = GHC.rdrNameOcc rdrName
let rdrNameStr = GHC.occNameString occName
logm $ "Renaming:original occName attributes:" ++ showGhc occName ++ occAttributes occName
unless (nameToString n /= newName) $ error "The new name is same as the old name"
unless (isValidNewName n rdrNameStr newName) $ error $ "Invalid new name:" ++ newName ++ "!"
let defineMod = case GHC.nameModule_maybe n of
Just mn -> GHC.moduleName mn
Nothing -> modName
unless (defineMod == modName) . error $ mconcat [ "This identifier is defined in module "
, GHC.moduleNameString defineMod
, ", please do renaming in that module!"
]
when (isMainModule modu && showGhcQual pn == "Main.main") $
error "The 'main' function defined in a 'Main' module should not be renamed!"
newNameGhc <- mkNewGhcName (Just modu) newName
(refactoredMod, nIsExported) <- applyRefac (doRenaming pn rdrNameStr newName newNameGhc modName)
RSAlreadyLoaded
logm $ "Renaming:nIsExported=" ++ show nIsExported
if nIsExported
then do clients <- clientModsAndFiles targetModule
logm ("Renaming: clients=" ++ show clients)
refactoredClients <- mapM (renameInClientMod n newName newNameGhc) clients
return $ refactoredMod : concat refactoredClients
else return [refactoredMod]
Nothing -> error "Invalid cursor position!"
condChecking :: (SYB.Data t)
=> GHC.Name -> String -> GHC.Name -> GHC.ModuleName
-> t
-> Bool -> Bool -> RefactGhc ()
condChecking oldPN newName newNameGhc modName ast existChecking exportChecking = do
condChecking1 oldPN newName newNameGhc modName ast existChecking exportChecking
nm <- getRefactNameMap
condChecking2 nm oldPN newName ast
doRenaming :: GHC.Located GHC.Name -> String -> String -> GHC.Name -> GHC.ModuleName -> RefactGhc Bool
doRenaming pn@(GHC.L _ oldn) rdrNameStr newNameStr newNameGhc modName = do
logm $ "doRenaming:(pn,rdrNameStr,newNameStr) = (" ++ intercalate "," [showGhc pn,rdrNameStr,newNameStr] ++ ")"
parsed <- getRefactParsed
nm <- getRefactNameMap
if GHC.isVarName oldn
then do
decls <- liftT $ hsDeclsGeneric parsed
if isDeclaredInRdr nm oldn decls
then do
logm "doRenaming:renameInMod isDeclaredInRdr True"
condChecking oldn newNameStr newNameGhc modName parsed True True
parsed' <- renameTopLevelVarName oldn newNameStr newNameGhc True
putRefactParsed parsed' mempty
isExported oldn
else do
logm "doRenaming: not declared at the top level"
condChecking oldn newNameStr newNameGhc modName parsed False False
parsed' <- renameTopLevelVarName oldn newNameStr newNameGhc False
putRefactParsed parsed' mempty
return False
else do
logm "doRenaming:not isVarName"
condChecking oldn newNameStr newNameGhc modName parsed True True
parsed' <- renameTopLevelVarName oldn newNameStr newNameGhc True
putRefactParsed parsed' mempty
isExported oldn
condChecking2 :: (SYB.Data t) => NameMap -> GHC.Name -> String -> t -> RefactGhc ()
condChecking2 nm oldPN newName t = do
void $ applyTP (once_buTP (failTP `adhocTP` inMod
`adhocTP` inMatch
`adhocTP` inExp
`adhocTP` inStmts
`adhocTP` inDataDefn
`adhocTP` inConDecl
`adhocTP` inTyClDecl
)) t
where
isDeclaredBy t = isDeclaredBy' t
where
isDeclaredBy' t
= do (_ , d) <- hsFreeAndDeclaredPNs t
logm $ "isDeclaredBy:d=" ++ showGhc d
return (oldPN `elem` d )
inMod (parsed :: GHC.ParsedSource) = do
decls <- liftT $ hsDeclsGeneric parsed
isDeclared <- isDeclaredBy decls
logm $ "Renaming.condChecking2.inMod:isDeclared=" ++ show isDeclared
if isDeclared
then condChecking' parsed
else mzero
#if __GLASGOW_HASKELL__ <= 710
inMatch (GHC.Match f@(Just (ln,_)) pats mtype (GHC.GRHSs rhs ds)
::GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do
#else
inMatch (GHC.Match f@(GHC.FunBindMatch ln isInfix) pats mtype (GHC.GRHSs rhs ds)
::GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do
#endif
isDeclaredPats <- isDeclaredBy pats
isDeclaredDs <- isDeclaredBy ds
logm $ "Renaming.condChecking2.inMatch:isDeclared=" ++ show (isDeclaredPats,isDeclaredDs)
if isDeclaredPats
then condChecking' (GHC.Match f pats mtype (GHC.GRHSs rhs ds))
else if isDeclaredDs
then condChecking' (GHC.Match f [] mtype (GHC.GRHSs rhs ds))
else mzero
inMatch _ = mzero
inExp expr@((GHC.L _ (GHC.HsLet ds e)):: GHC.LHsExpr GHC.RdrName) = do
isDeclaredDs <- isDeclaredBy ds
if isDeclaredDs
then condChecking' expr
else mzero
inExp expr@((GHC.L _ (GHC.HsDo _ ds e)):: GHC.LHsExpr GHC.RdrName) = do
isDeclared <- isDeclaredBy ds
logm $ "inExp.HsDo:isDeclared=" ++ show isDeclared
if isDeclared
then condChecking' expr
else mzero
inExp _ = mzero
inStmts (stmt@(GHC.L _ (GHC.LetStmt binds)) :: GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do
isDeclared <- isDeclaredBy binds
if isDeclared
then condChecking' stmt
else mzero
inStmts _ = mzero
inDataDefn dd@(GHC.HsDataDefn _ ctxt mctype mkindsig cons derivs :: GHC.HsDataDefn GHC.RdrName) = do
declared <- isDeclaredBy cons
if declared
then condChecking' dd
else mzero
#if __GLASGOW_HASKELL__ <= 710
inConDecl (cd@(GHC.ConDecl ns _expr (GHC.HsQTvs _ns bndrs) ctxt
dets res _ depc_syntax) :: GHC.ConDecl GHC.RdrName ) =
case res of
GHC.ResTyGADT ls typ -> do
declared <- isDeclaredBy ns
if declared
then condChecking' cd
else mzero
GHC.ResTyH98 -> do
declaredn <- isDeclaredBy ns
declaredd <- isDeclaredBy dets
if declaredn || declaredd
then condChecking' cd
else mzero
#else
inConDecl cd@(GHC.ConDeclGADT ns _ _ :: GHC.ConDecl GHC.RdrName) = do
declared <- isDeclaredBy ns
if declared
then condChecking' cd
else mzero
inConDecl cd@(GHC.ConDeclH98 n _ _ dets _) = do
declaredn <- isDeclaredBy n
declaredd <- isDeclaredBy dets
if declaredn || declaredd
then condChecking' cd
else mzero
#endif
#if __GLASGOW_HASKELL__ <= 710
inTyClDecl dd@(GHC.DataDecl ln (GHC.HsQTvs _ns tyvars) defn _ :: GHC.TyClDecl GHC.RdrName) = do
#else
inTyClDecl dd@(GHC.DataDecl ln tyvars defn _ _ :: GHC.TyClDecl GHC.RdrName) = do
#endif
declared <- isDeclaredBy dd
declaredtv <- isDeclaredBy tyvars
if declared || declaredtv
then condChecking' dd
else mzero
inTyClDecl _ = mzero
condChecking' t = do
sameGroupDecls <- declaredVarsInSameGroup nm oldPN t
when (newName `elem` sameGroupDecls)
$ error "The new name exists in the same binding group!"
(f, d) <- hsFreeAndDeclaredNameStrings t
when (newName `elem` f) $ error "Existing uses of the new name will be captured!"
ds <- hsVisibleNamesRdr oldPN t
when (newName `elem` ds) $ error "The new name will cause name capture!"
return t
declaredVarsInSameGroup :: (SYB.Data t) => NameMap -> GHC.Name -> t -> RefactGhc [String]
declaredVarsInSameGroup nm n t = do
decls <- liftT $ hsDeclsGeneric t
let declared = nub $ map showGhc $ getDeclaredVarsRdr nm decls
return $ filter (/= showGhc n) declared
condChecking1 :: (SYB.Data t)
=> GHC.Name -> String -> GHC.Name -> GHC.ModuleName
-> t
-> Bool -> Bool -> RefactGhc ()
condChecking1 oldPN newName newNameGhc modName ast existChecking exportChecking = do
nm <- getRefactNameMap
let (FN f', DN d') = hsFDsFromInsideRdr nm ast
let (f, _d) = (map nameToString f', map nameToString d')
let newNameStr = nameToString newNameGhc
scopeClashNames <- inScopeNames newName
when (nonEmptyList $ intersect scopeClashNames f') .
error $ mconcat [ "The new name will cause an ambiguous occurrence problem, "
, "please select another new name or qualify the use of '"
, newName ++ "' before renaming!\n"]
parsed <- getRefactParsed
let dns = map nameToString $ filter (sameNameSpace oldPN) d'
when (existChecking && newNameStr `elem` dns \\ [nameToString oldPN]) $ do
logm $ "condChecking1:dns=" ++ intercalate "," dns
let m = Map.fromList $ map (\n -> (nameToString n,n)) $ filter (sameNameSpace oldPN) d'
Just dupN = Map.lookup newNameStr m
logm $ "condChecking1:dupN=" ++ showGhcQual dupN
case definingTyClDeclsNames nm [dupN] parsed of
[] -> do
error $ mconcat ["Name '", newName, "' already exists in this module\n"]
ds -> do
return ()
when (exportChecking && causeNameClashInExports nm oldPN newNameGhc modName parsed) $
error "The new name will cause conflicting exports, please select another new name!"
causeAmbiguity <- causeAmbiguityInExports oldPN newNameGhc
when (exportChecking && causeAmbiguity) .
error $ mconcat ["The new name will cause ambiguity in the exports of module '"
, show modName
, "' , please select another name!"]
DN ds' <- hsVisibleDsRdr nm oldPN ast
let dns2 = map nameToString $ filter (sameNameSpace oldPN) ds'
when (existChecking && newName `elem` nub (dns2 `union` f) \\ [nameToString oldPN]) .
error $ mconcat [ "Name '", newName, "' already exists, or renaming '", nameToString oldPN, "' to '"
, newName, "' will change the program's semantics!\n"]
renameTopLevelVarName :: GHC.Name -> String -> GHC.Name
-> Bool -> RefactGhc GHC.ParsedSource
renameTopLevelVarName oldPN newName newNameGhc exportChecking = do
parsed <- getRefactParsed
isInScopeUnqual <- isInScopeAndUnqualifiedGhc newName (Just newNameGhc)
let qual = if exportChecking && isInScopeUnqual then Qualify else PreserveQualify
renamePN oldPN newNameGhc qual parsed
renameLocalVarName :: (SYB.Data t) => GHC.Name -> String -> GHC.Name -> t -> RefactGhc t
renameLocalVarName oldPN newName newNameGhc t = do
nm <- getRefactNameMap
let qual = PreserveQualify
(f,d) <- hsFDNamesFromInsideRdr t
if elem newName (d \\ [showGhc oldPN])
then error ("Name '"++newName++"' already existed\n")
else do
ds <- hsVisibleNamesRdr oldPN t
if elem newName ((nub (ds `union` f)) \\[showGhc oldPN])
then error ("Name '"++newName++"' already existed, or rename '"
++showGhc oldPN++ "' to '"++newName++
"' will change the program's semantics!\n")
else renamePN oldPN newNameGhc qual t
renameInClientMod :: GHC.Name -> String -> GHC.Name -> TargetModule
-> RefactGhc [ApplyRefacResult]
renameInClientMod oldPN newName newNameGhc targetModule = do
logm $ "renameInClientMod:(oldPN,newNameGhc,targetModule)=" ++ showGhc (oldPN,newNameGhc,targetModule)
logm $ "renameInClientMod:(newNameGhc module)=" ++ showGhc (GHC.nameModule newNameGhc)
getTargetGhc targetModule
modName <- getRefactModuleName
parsed <- getRefactParsed
nm <- getRefactNameMap
newNames <- equivalentNameInNewMod oldPN
logm $ "renameInClientMod:(newNames)=" ++ showGhcQual newNames
let newNames' = filter (sameNameSpace oldPN) newNames
case newNames' of
[] -> return []
[oldName] | findNameInRdr nm oldName parsed -> doRenameInClientMod nm oldName modName parsed
| otherwise -> do
logm "renameInClientMod: name not present in module, returning"
return []
ns -> error $ "HaRe: renameInClientMod: could not find name to replace, got:"
++ (showGhcQual $ map (\n -> (n,GHC.occNameSpace $ GHC.nameOccName n)) ns)
where
doRenameInClientMod nm oldNameGhc modName parsed = do
isInScopeUnqual <- isInScopeAndUnqualifiedGhc (nameToString oldPN) Nothing
isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName Nothing
logm $ "renameInClientMod: (isInScopeAndUnqual,isInScopeUnqualNew)=" ++
show (isInScopeUnqual, isInScopeUnqualNew)
if isInScopeUnqualNew
then do
(refactoredMod, _) <- applyRefac (refactRenameSimple oldNameGhc newName newNameGhc Qualify)
RSAlreadyLoaded
return [refactoredMod]
else do
when (causeNameClashInExports nm oldPN newNameGhc modName parsed) .
error $ mconcat [ "The new name will cause conflicting exports in module"
, show newName, ", please select another name!"]
(refactoredMod, _) <- applyRefac (refactRenameComplex oldNameGhc newName newNameGhc)
RSAlreadyLoaded
return [refactoredMod]
refactRenameSimple :: GHC.Name -> String -> GHC.Name -> HowToQual -> RefactGhc ()
refactRenameSimple old newStr new useQual = do
logm $ "refactRenameSimple:(old,newStr,new,useQual)=" ++ showGhc (old, newStr, new, useQual)
qualifyTopLevelVar newStr
parsed <- renamePN old new useQual =<< getRefactParsed
putRefactParsed parsed mempty
return ()
refactRenameComplex :: GHC.Name -> String -> GHC.Name -> RefactGhc ()
refactRenameComplex old new newGhc = do
logm $ "refactRenameComplex:(old,new,newGhc)=" ++ showGhc (old, new, newGhc)
qualifyTopLevelVar new
worker old new newGhc
qualifyTopLevelVar :: String -> RefactGhc ()
qualifyTopLevelVar new = do
toQualify <- inScopeNames new
logm $ "renameInClientMod.qualifyTopLevelVar:new:toQualify=" ++ show new ++ ":" ++ showGhc toQualify
mapM_ qualifyToplevelName toQualify
return ()
worker :: GHC.Name -> String -> GHC.Name -> RefactGhc ()
worker oldPN' newName' newNameGhc' = do
logm $ "renameInClientMod.worker:(oldPN',newName',newNameGhc')=" ++
showGhc (oldPN', newName', newNameGhc')
isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName' Nothing
vs <- hsVisibleNamesRdr oldPN' =<< getRefactParsed
logm $ "renameInClientMod.worker:(vs,oldPN',isInScopeUnqualNew)=" ++
showGhc (vs, oldPN', isInScopeUnqualNew)
let qual = if (newName' `elem` (nub vs \\ [nameToString oldPN']) || isInScopeUnqualNew)
then Qualify
else PreserveQualify
parsed <- renamePN oldPN' newNameGhc' qual =<< getRefactParsed
putRefactParsed parsed mempty
return ()
causeAmbiguityInExports :: GHC.Name -> GHC.Name -> RefactGhc Bool
causeAmbiguityInExports old newName = do
(GHC.L _ (GHC.HsModule _ exps _imps _decls _ _)) <- getRefactParsed
isInScopeUnqual <- isInScopeAndUnqualifiedGhc (nameToString old) Nothing
let usedUnqual = usedWithoutQualR newName exps
logm $ "causeAmbiguityInExports:(isInScopeUnqual,usedUnqual)" ++ show (isInScopeUnqual, usedUnqual)
return (isInScopeUnqual && usedUnqual)
isValidNewName :: GHC.Name -> String -> String -> Bool
isValidNewName oldName rdrNameStr newName = res
where
doTest :: Bool -> Bool -> String -> Bool
doTest isCategory isRightType errStr = not isCategory || isRightType || error errStr
tyconOk = doTest (GHC.isTyConName oldName) (isConId newName) "Invalid type constructor/class name!"
dataConOk = doTest (GHC.isDataConName oldName) (isConId newName) "Invalid data constructor name!"
tyVarOk = doTest (GHC.isTyVarName oldName) (isVarId newName) "Invalid type variable name!"
oldName' = rdrNameStr
matchNamesOk
| GHC.isVarName oldName
= if isVarId oldName' && not (isVarId newName)
then error "The new name should be an identifier!"
else if isOperator oldName' && not (isOperator newName)
then error "The new name should be an operator!"
else (isVarId oldName' && isVarId newName)
|| (isOperator oldName' && isOperator newName)
|| (error $ "Invalid new name!" ++ show ( oldName', newName
, isVarId oldName'
, isVarId newName
, isOperator oldName'
, isOperator newName ))
| otherwise = True
res = tyconOk && dataConOk && tyVarOk && matchNamesOk