module Language.Haskell.Refact.Refactoring.Renaming
( rename
, compRename
) where
import qualified Data.Generics.Schemes as SYB
import qualified Data.Generics.Aliases as SYB
import qualified GHC.SYB.Utils as SYB
import qualified GHC
import qualified Name as GHC
import qualified RdrName as GHC
import Control.Monad
import Data.Maybe
import Data.List
import qualified Language.Haskell.GhcMod as GM (Options(..))
import Language.Haskell.Refact.API
import System.Directory
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
renamed <- getRefactRenamed
parsed <- getRefactParsed
modu <- getModule
targetModule <- getRefactTargetModule
let modName = maybe (GHC.mkModuleName "Main") fst $ getModuleName parsed
maybePn = locToName (row, col) renamed
logm $ "Renamed.comp:maybePn=" ++ showGhc maybePn
case maybePn of
Just pn@(GHC.L _ n) -> do
logm $ "Renaming:(n,modu)=" ++ showGhc (n,modu)
let (GHC.L _ rdrName) = gfromJust "Renaming.comp.2" $ locToRdrName (row, col) parsed
let rdrNameStr = GHC.occNameString $ GHC.rdrNameOcc rdrName
logm $ "Renaming: rdrName=" ++ SYB.showData SYB.Parser 0 rdrName
logm $ "Renaming: occname rdrName=" ++ show (GHC.occNameString $ GHC.rdrNameOcc rdrName)
unless (nameToString n /= newName) $ error "The new name is same as the old name"
unless (isValidNewName n rdrNameStr newName) $ error $ "Invalid new name:" ++ newName ++ "!"
logm $ "Renaming.comp: before GHC.nameModule,n=" ++ showGhc n
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!"
]
logm $ "Renaming.comp:(isMainModule modu,pn)=" ++ showGhcQual (isMainModule modu,pn)
when (isMainModule modu && showGhcQual pn == "Main.main") $
error "The 'main' function defined in a 'Main' module should not be renamed!"
logm "Renaming.comp: not main module"
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!"
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) = " ++ showGhc (pn,rdrNameStr,newNameStr)
renamed <- getRefactRenamed
void $ SYB.everywhereM (SYB.mkM renameInMod) renamed
logm "doRenaming done"
isExported oldn
where
renameInMod :: GHC.RenamedSource -> RefactGhc GHC.RenamedSource
renameInMod ren = do
logm "renameInMod"
renameTopLevelVarName oldn newNameStr newNameGhc modName ren True True
renameTopLevelVarName :: GHC.Name -> String -> GHC.Name -> GHC.ModuleName -> GHC.RenamedSource
-> Bool -> Bool -> RefactGhc GHC.RenamedSource
renameTopLevelVarName oldPN newName newNameGhc modName renamed existChecking exportChecking = do
logm $ "renameTopLevelVarName:(existChecking, exportChecking)=" ++ show (existChecking, exportChecking)
causeAmbiguity <- causeAmbiguityInExports oldPN newNameGhc
(f', d') <- hsFDsFromInside renamed
let (f, d) = (map nameToString f', map nameToString d')
logm $ "renameTopLevelVarName:f=" ++ show f
logm $ "renameTopLevelVarName:d=" ++ show d
let newNameStr = nameToString newNameGhc
logm $ "renameTopLevelVarName:(newName,newNameStr)=" ++ show (newName, newNameStr)
scopeClashNames <- inScopeNames newName
logm $ "renameTopLevelVarName:(f')=" ++ showGhc f'
logm $ "renameTopLevelVarName:(scopeClashNames,intersection)=" ++
showGhc (scopeClashNames, scopeClashNames `intersect` f')
logm $ "renameTopLevelVarName:(oldPN,modName)=" ++ showGhc (oldPN,modName)
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"]
when (existChecking && newNameStr `elem` d \\ [nameToString oldPN]) .
error $ mconcat ["Name '", newName, "' already exists in this module\n"]
when (exportChecking && causeNameClashInExports oldPN newNameGhc modName renamed) $
error "The new name will cause conflicting exports, please select another new name!"
when (exportChecking && causeAmbiguity) .
error $ mconcat ["The new name will cause ambiguity in the exports of module '"
, show modName
, "' , please select another name!"]
logm "renameTopLevelVarName:basic tests done"
isInScopeUnqual <- isInScopeAndUnqualifiedGhc newName (Just newNameGhc)
logm "renameTopLevelVarName:after isInScopeUnqual"
logm $ "renameTopLevelVarName:oldPN=" ++ showGhc oldPN
ds <- hsVisibleNames oldPN renamed
logm $ "renameTopLevelVarName:ds computed=" ++ show ds
when (existChecking && newName `elem` nub (ds `union` f) \\ [nameToString oldPN]) .
error $ mconcat [ "Name '", newName, "' already exists, or renaming '", nameToString oldPN, "' to '"
, newName, "' will change the program's semantics!\n"]
logm "renameTopLevelVarName start..:should have qualified"
parsed <- renamePN oldPN newNameGhc (exportChecking && isInScopeUnqual) =<< getRefactParsed
putRefactParsed parsed mempty
logm "renameTopLevelVarName done:should have qualified"
getRefactRenamed
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
renamed <- getRefactRenamed
modName <- getRefactModuleName
newNames <- equivalentNameInNewMod oldPN
logm $ "renameInClientMod:(newNames)=" ++ showGhcQual newNames
case newNames of
[] -> return []
[oldName] | findPN oldName renamed -> doRenameInClientMod oldName modName renamed
| otherwise -> do
logm "renameInClientMod: name not present in module, returning"
return []
ns -> error $ "HaRe: renameInClientMod: could not find name to replace, got:" ++ showGhcQual ns
where
doRenameInClientMod oldNameGhc modName renamed = 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 True)
RSAlreadyLoaded
return [refactoredMod]
else do
when (causeNameClashInExports oldPN newNameGhc modName renamed) .
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 -> Bool -> 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 <- hsVisibleNames oldPN' =<< getRefactRenamed
logm $ "renameInClientMod.worker:(vs,oldPN',isInScopeUnqualNew)=" ++
showGhc (vs, oldPN', isInScopeUnqualNew)
parsed <- renamePN oldPN' newNameGhc'
(newName' `elem` (nub vs \\ [nameToString oldPN']) || isInScopeUnqualNew)
=<< 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