module Language.Haskell.Refact.Refactoring.Renaming(rename) where
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.List
import Exception
import Language.Haskell.GhcMod
import Language.Haskell.Refact.API
rename :: RefactSettings -> Cradle
-> FilePath -> String -> SimpPos
-> IO [FilePath]
rename settings cradle fileName newName (row,col) =
runRefacSession settings cradle (comp fileName newName (row,col))
comp :: FilePath -> String -> SimpPos -> RefactGhc [ApplyRefacResult]
comp fileName newName (row,col) = do
logm $ "Renaming.comp: (fileName,newName,(row,col))=" ++ (show (fileName,newName,(row,col)))
getModuleGhc fileName
renamed <- getRefactRenamed
parsed <- getRefactParsed
logm $ "comp:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed)
modu <- getModule
let modName = case (getModuleName parsed) of
Just (mn,_) -> mn
Nothing -> GHC.mkModuleName "Main"
let 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 ("This identifier is defined in module " ++ (show defineMod) ++
", please do renaming in that module!"))
if isMainModule modu && (showGhc pn) == "Main.main"
then error ("The 'main' function defined in a 'Main' module should not be renamed!")
else do
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 modName
logm ("Renaming: clients=" ++ (showGhc 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 $ everywhereMStaged SYB.Renamer (SYB.mkM renameInMod
) renamed
logm $ "doRenaming done"
nIsExported <- isExported oldn
return nIsExported
where
renameInMod :: GHC.RenamedSource -> RefactGhc GHC.RenamedSource
renameInMod ren
| True = 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,intersect scopeClashNames f'))
logm $ "renameTopLevelVarName:(oldPN,modName)=" ++ (showGhc (oldPN,modName))
if (nonEmptyList $ intersect scopeClashNames f')
then error ("The new name will cause ambiguous occurrence problem,"
++" please select another new name or qualify the use of ' "
++ newName ++ "' before renaming!\n")
else if existChecking && elem newNameStr (d \\ [nameToString oldPN])
then error ("Name '"++newName++"' already existed\n")
else if exportChecking && causeNameClashInExports oldPN newNameGhc modName renamed
then error ("The new name will cause conflicting exports, please select another new name!")
else if exportChecking && causeAmbiguity
then error $"The new name will cause ambiguity in the exports of module "++ show modName ++ ", please select another name!"
else do
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)
if existChecking && elem newName ((nub (ds `union` f)) \\[nameToString oldPN])
then error ("Name '"++newName++"' already existed, or rename '"
++nameToString oldPN++ "' to '"++newName++
"' will change the program's semantics!\n")
else if exportChecking && isInScopeUnqual
then do
logm $ "renameTopLevelVarName start..:should have qualified"
void $ renamePN oldPN newNameGhc True True renamed
logm $ "renameTopLevelVarName done:should have qualified"
r' <- getRefactRenamed
return r'
else do
logm $ "renameTopLevelVarName start.."
void $ renamePN oldPN newNameGhc True False renamed
logm $ "renameTopLevelVarName done"
r' <- getRefactRenamed
return r'
renameInClientMod :: GHC.Name -> String -> GHC.Name -> TargetModule
-> RefactGhc [ApplyRefacResult]
renameInClientMod oldPN newName newNameGhc targetModule@(_,modSummary) = do
logm $ "renameInClientMod:(oldPN,newNameGhc,modSummary)=" ++ (showGhc (oldPN,newNameGhc,targetModule))
void $ activateModule targetModule
names <- ghandle handler (GHC.parseName $ nameToString oldPN)
nameInfo <- mapM GHC.lookupName names
logm $ "renameInClientMod: nameInfo=" ++ (showGhc nameInfo)
renamed <- getRefactRenamed
let modName = GHC.moduleName $ GHC.ms_mod modSummary
isInScopeUnqual <- isInScopeAndUnqualifiedGhc (nameToString oldPN) Nothing
isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName Nothing
logm $ "renameInClientMod: (isInScopeAndUnqual,isInScopeUnqualNew)=" ++ (show (isInScopeUnqual,isInScopeUnqualNew))
if isInScopeUnqualNew
then
do
(refactoredMod,_) <- applyRefac (refactRenameSimple oldPN newName newNameGhc True) RSAlreadyLoaded
return [refactoredMod]
else
do if causeNameClashInExports oldPN newNameGhc modName renamed
then error $"The new name will cause conflicting exports in module "++ show newName ++ ", please select another name!"
else do
(refactoredMod,_) <- applyRefac (refactRenameComplex oldPN newName newNameGhc) RSAlreadyLoaded
return [refactoredMod]
where
handler:: (GHC.GhcMonad m) => SomeException -> m [GHC.Name]
handler _ = return []
refactRenameSimple :: GHC.Name -> String -> GHC.Name -> Bool -> RefactGhc ()
refactRenameSimple old newStr new useQual = do
qualifyTopLevelVar newStr
renamed <- getRefactRenamed
logm $ "renameInClientMod.refactRename:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed)
void $ renamePN old new True useQual renamed
return ()
refactRenameComplex :: GHC.Name -> String -> GHC.Name -> RefactGhc ()
refactRenameComplex old new newGhc = do
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"
renamed <- getRefactRenamed
isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName' Nothing
vs <- hsVisibleNames oldPN' renamed
if elem newName' ((nub vs) \\ [nameToString oldPN']) || isInScopeUnqualNew
then void $ renamePN oldPN' newNameGhc' True True renamed
else void $ renamePN oldPN' newNameGhc' True False renamed
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 =
if isCategory
then if isRightType
then True
else error errStr
else True
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 if (isVarId oldName' && isVarId newName) ||
(isOperator oldName' && isOperator newName)
then True
else error $ "Invalid new name!" ++ (show (oldName',newName,isVarId oldName',isVarId newName,isOperator oldName',isOperator newName))
| otherwise = True
res = tyconOk && dataConOk &&
tyVarOk && matchNamesOk