diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2016-01-20 v0.8.2.3 + * Use ghc-mod version to 5.5 now it is released + * Expose commands working in RefactGhc, so the ghc-mod session can + be shared in haskell-ide-engine. By @cocreature + * Internal only, heavily clean up the ...Refactoring.Rename + module. By @glittershark 2016-01-07 v0.8.2.2 * Lock ghc-mod version to 0.5.4 to prevent issues when 0.5.5 comes out * Set minimum bound on ghc-exactprint, the behaviour of layout has diff --git a/HaRe.cabal b/HaRe.cabal --- a/HaRe.cabal +++ b/HaRe.cabal @@ -1,5 +1,5 @@ Name: HaRe -Version: 0.8.2.2 +Version: 0.8.2.3 Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer: Alan Zimmerman Stability: Alpha @@ -121,7 +121,7 @@ , ghc-paths , ghc-prim , ghc-syb-utils - , ghc-mod == 5.4.* + , ghc-mod >= 5.5.0.0 , mtl , old-time , pretty @@ -193,7 +193,7 @@ , ghc-paths , ghc-prim , ghc-syb-utils - , ghc-mod == 5.4.* + , ghc-mod >= 5.5.0.0 , mtl , old-time , parsec >= 3.1.6 @@ -285,7 +285,7 @@ , ghc-paths , ghc-prim , ghc-syb-utils - , ghc-mod == 5.4.* + , ghc-mod >= 5.5.0.0 , hspec , mtl , old-time diff --git a/src/Language/Haskell/Refact/HaRe.hs b/src/Language/Haskell/Refact/HaRe.hs --- a/src/Language/Haskell/Refact/HaRe.hs +++ b/src/Language/Haskell/Refact/HaRe.hs @@ -12,11 +12,17 @@ -- * Refactorings , ifToCase + , compIfToCase , duplicateDef + , compDuplicateDef , liftToTopLevel + , compLiftToTopLevel , liftOneLevel + , compLiftOneLevel , demote + , compDemote , rename + , compRename -- , swapArgs , roundTrip @@ -32,5 +38,3 @@ import Language.Haskell.Refact.Utils.Monad import Language.Haskell.Refact.Utils.Types import qualified Language.Haskell.GhcMod as GM (Options(..),defaultOptions) - - diff --git a/src/Language/Haskell/Refact/Refactoring/Case.hs b/src/Language/Haskell/Refact/Refactoring/Case.hs --- a/src/Language/Haskell/Refact/Refactoring/Case.hs +++ b/src/Language/Haskell/Refact/Refactoring/Case.hs @@ -1,5 +1,8 @@ {-# LANGUAGE StandaloneDeriving #-} -module Language.Haskell.Refact.Refactoring.Case(ifToCase) where +module Language.Haskell.Refact.Refactoring.Case + ( ifToCase + , compIfToCase + ) where import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB @@ -25,14 +28,14 @@ ifToCase :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> SimpPos -> IO [FilePath] ifToCase settings opts fileName beginPos endPos = do absFileName <- canonicalizePath fileName - runRefacSession settings opts (comp absFileName beginPos endPos) + runRefacSession settings opts (compIfToCase absFileName beginPos endPos) -comp :: FilePath -> SimpPos -> SimpPos -> RefactGhc [ApplyRefacResult] -comp fileName beginPos endPos = do +compIfToCase :: FilePath -> SimpPos -> SimpPos -> RefactGhc [ApplyRefacResult] +compIfToCase fileName beginPos endPos = do parseSourceFileGhc fileName parsed <- getRefactParsed oldAnns <- liftT getAnnsT - logm $ "Case.comp:parsed=" ++ (showAnnData oldAnns 0 parsed) -- ++AZ++ + logm $ "Case.compIfToCase:parsed=" ++ (showAnnData oldAnns 0 parsed) -- ++AZ++ let expr = locToExp beginPos endPos parsed case expr of Just exp1@(GHC.L _ (GHC.HsIf _ _ _ _)) @@ -144,4 +147,3 @@ -- EOF - diff --git a/src/Language/Haskell/Refact/Refactoring/DupDef.hs b/src/Language/Haskell/Refact/Refactoring/DupDef.hs --- a/src/Language/Haskell/Refact/Refactoring/DupDef.hs +++ b/src/Language/Haskell/Refact/Refactoring/DupDef.hs @@ -3,7 +3,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -module Language.Haskell.Refact.Refactoring.DupDef(duplicateDef) where +module Language.Haskell.Refact.Refactoring.DupDef + ( duplicateDef + , compDuplicateDef ) where import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB @@ -30,10 +32,10 @@ duplicateDef :: RefactSettings -> GM.Options -> FilePath -> String -> SimpPos -> IO [FilePath] duplicateDef settings opts fileName newName (row,col) = do absFileName <- canonicalizePath fileName - runRefacSession settings opts (comp absFileName newName (row,col)) + runRefacSession settings opts (compDuplicateDef absFileName newName (row,col)) -comp :: FilePath -> String -> SimpPos -> RefactGhc [ApplyRefacResult] -comp fileName newName (row, col) = do +compDuplicateDef :: FilePath -> String -> SimpPos -> RefactGhc [ApplyRefacResult] +compDuplicateDef fileName newName (row, col) = do if isVarId newName then do @@ -41,14 +43,14 @@ renamed <- getRefactRenamed parsed <- getRefactParsed targetModule <- getRefactTargetModule - logm $ "DupDef.comp:got targetModule" + logm $ "DupDef.compDuplicateDef:got targetModule" let (Just (modName,_)) = getModuleName parsed let maybePn = locToName (row, col) renamed case maybePn of Just pn -> do - logm $ "DupDef.comp:about to applyRefac for:pn=" ++ SYB.showData SYB.Parser 0 pn + logm $ "DupDef.compDuplicateDef:about to applyRefac for:pn=" ++ SYB.showData SYB.Parser 0 pn (refactoredMod,(isDone,nn)) <- applyRefac (doDuplicating pn newName) (RSFile fileName) logm $ "DupDef.com:isDone=" ++ show isDone case isDone of @@ -58,7 +60,7 @@ if modIsExported modName renamed then do - logm $ "DupDef.comp:about to clientMods" + logm $ "DupDef.compDuplicateDef:about to clientMods" clients <- clientModsAndFiles targetModule logm ("DupDef: clients=" ++ (showGhc clients)) -- ++AZ++ debug refactoredClients <- mapM (refactorInClientMod (GHC.unLoc pn) modName nn) @@ -75,9 +77,9 @@ doDuplicating :: GHC.Located GHC.Name -> String -> RefactGhc (DupDefResult,GHC.Name) doDuplicating pn newName = do - logm $ "DupDef.comp:doDuplicating entered" + logm $ "DupDef.compDuplicateDef:doDuplicating entered" inscopes <- getRefactInscopes - logm $ "DupDef.comp:doDuplicating got inscopes" + logm $ "DupDef.compDuplicateDef:doDuplicating got inscopes" reallyDoDuplicating pn newName inscopes @@ -286,4 +288,3 @@ where getModName (GHC.L _ (GHC.ImportDecl _ _modName1 _qualify _source _safe _isQualified _isImplicit as _h)) = if isJust as then (fromJust as) else modName - diff --git a/src/Language/Haskell/Refact/Refactoring/MoveDef.hs b/src/Language/Haskell/Refact/Refactoring/MoveDef.hs --- a/src/Language/Haskell/Refact/Refactoring/MoveDef.hs +++ b/src/Language/Haskell/Refact/Refactoring/MoveDef.hs @@ -6,8 +6,11 @@ module Language.Haskell.Refact.Refactoring.MoveDef ( liftToTopLevel + , compLiftToTopLevel , liftOneLevel + , compLiftOneLevel , demote + , compDemote -- ,liftingInClientMod ) where diff --git a/src/Language/Haskell/Refact/Refactoring/Renaming.hs b/src/Language/Haskell/Refact/Refactoring/Renaming.hs --- a/src/Language/Haskell/Refact/Refactoring/Renaming.hs +++ b/src/Language/Haskell/Refact/Refactoring/Renaming.hs @@ -1,4 +1,7 @@ -module Language.Haskell.Refact.Refactoring.Renaming (rename) where +module Language.Haskell.Refact.Refactoring.Renaming + ( rename + , compRename + ) where import qualified Data.Generics.Schemes as SYB import qualified Data.Generics.Aliases as SYB @@ -9,6 +12,7 @@ import qualified RdrName as GHC import Control.Monad +import Data.Maybe import Data.List import qualified Language.Haskell.GhcMod as GM (Options(..)) @@ -44,64 +48,72 @@ -} -- | Rename the given identifier. -rename :: RefactSettings -> GM.Options - -> FilePath -> String -> SimpPos - -> IO [FilePath] +rename :: RefactSettings + -> GM.Options + -> FilePath + -> String + -> SimpPos + -> IO [FilePath] rename settings opts fileName newName (row,col) = do absFileName <- canonicalizePath fileName - runRefacSession settings opts (comp absFileName newName (row,col)) + runRefacSession settings opts (compRename absFileName newName (row,col)) -- | Body of the refactoring -comp :: FilePath -> String -> SimpPos -> RefactGhc [ApplyRefacResult] -comp fileName newName (row,col) = do +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 + renamed <- getRefactRenamed + parsed <- getRefactParsed + modu <- getModule targetModule <- getRefactTargetModule - let modName = case getModuleName parsed of - Just (mn,_) -> mn - Nothing -> GHC.mkModuleName "Main" - let maybePn = locToName (row, col) renamed + + let modName = maybe (GHC.mkModuleName "Main") fst $ getModuleName parsed + maybePn = locToName (row, col) renamed + logm $ "Renamed.comp:maybePn=" ++ showGhc maybePn -- ++AZ++ + case maybePn of Just pn@(GHC.L _ n) -> do - logm $ "Renaming:(n,modu)=" ++ showGhc (n,modu) + 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) + 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 ++ "!" + 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 + logm $ "Renaming.comp: before GHC.nameModule,n=" ++ showGhc n - let defineMod = case GHC.nameModule_maybe n of - Just mn -> GHC.moduleName mn - Nothing -> modName + let defineMod = case GHC.nameModule_maybe n of + Just mn -> GHC.moduleName mn + Nothing -> modName - -- TODO: why do we have this restriction? - unless (defineMod == modName ) ( error ("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)) - if isMainModule modu && showGhcQual 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 --no matter whether this pn is used or not. - then do clients <- clientModsAndFiles targetModule - logm ("Renaming: clients=" ++ show clients) -- ++AZ++ debug - refactoredClients <- mapM (renameInClientMod n newName newNameGhc) clients - return $ refactoredMod:(concat refactoredClients) - else return [refactoredMod] + -- TODO: why do we have this restriction? + 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 --no matter whether this pn is used or not. + then do clients <- clientModsAndFiles targetModule + logm ("Renaming: clients=" ++ show clients) -- ++AZ++ debug + refactoredClients <- mapM (renameInClientMod n newName newNameGhc) clients + return $ refactoredMod : concat refactoredClients + else return [refactoredMod] Nothing -> error "Invalid cursor position!" @@ -111,123 +123,115 @@ --------Rename a value variable name-------------------------------- 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" - nIsExported <- isExported oldn - return nIsExported - where - -- 1. The name is declared in a module(top level name) - renameInMod :: GHC.RenamedSource -> RefactGhc GHC.RenamedSource - renameInMod ren - | True = do - logm $ "renameInMod" - renameTopLevelVarName oldn newNameStr newNameGhc modName ren True True - + logm $ "doRenaming:(pn,rdrNameStr,newNameStr) = " ++ showGhc (pn,rdrNameStr,newNameStr) + renamed <- getRefactRenamed + void $ SYB.everywhereM (SYB.mkM renameInMod) renamed + logm "doRenaming done" + isExported oldn + where + -- 1. The name is declared in a module(top level name) + 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 + -> 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' contains names imported from other modules; - -- d' contains the top level names declared in this module; - (f',d') <- hsFDsFromInside renamed - --filter those qualified free variables in f' - -- let (f,d) = ((nub.map pNtoName.filter (not.isQualifiedPN)) f', (nub.map pNtoName) d') - 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") -- Another implementation option is to add the qualifier - -- to newName automatically. - else if existChecking && elem newNameStr (d \\ [nameToString oldPN]) --only check the declared names here. - then error ("Name '"++newName++"' already existed\n") --the same name has been declared in this module. - 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 -- causeAmbiguityInExports oldPN newNameGhc {- inscps -} renamed - then error $"The new name will cause ambiguity in the exports of module "++ show modName ++ ", please select another name!" - else do -- get all of those declared names visible to oldPN at where oldPN is used. + logm $ "renameTopLevelVarName:(existChecking, exportChecking)=" ++ show (existChecking, exportChecking) + causeAmbiguity <- causeAmbiguityInExports oldPN newNameGhc + -- f' contains names imported from other modules; + -- d' contains the top level names declared in this module; + (f', d') <- hsFDsFromInside renamed + --filter those qualified free variables in f' + -- let (f,d) = ((nub.map pNtoName.filter (not.isQualifiedPN)) f', (nub.map pNtoName) d') + let (f, d) = (map nameToString f', map nameToString d') + logm $ "renameTopLevelVarName:f=" ++ show f + logm $ "renameTopLevelVarName:d=" ++ show d - logm $ "renameTopLevelVarName:basic tests done" + let newNameStr = nameToString newNameGhc + logm $ "renameTopLevelVarName:(newName,newNameStr)=" ++ show (newName, newNameStr) - 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 -- isInScopeAndUnqualifiedGhc newName Nothing - then do - logm $ "renameTopLevelVarName start..:should have qualified" - parsed <- getRefactParsed - parsed' <- renamePN oldPN newNameGhc True parsed - putRefactParsed parsed' mempty - logm $ "renameTopLevelVarName done:should have qualified" - r' <- getRefactRenamed - return r' - else do - logm $ "renameTopLevelVarName start.." - parsed <- getRefactParsed - parsed' <- renamePN oldPN newNameGhc False parsed - putRefactParsed parsed' mempty - logm $ "renameTopLevelVarName done" - r' <- getRefactRenamed - return r' + scopeClashNames <- inScopeNames newName --- --------------------------------------------------------------------- + logm $ "renameTopLevelVarName:(f')=" ++ showGhc f' + logm $ "renameTopLevelVarName:(scopeClashNames,intersection)=" ++ + showGhc (scopeClashNames, scopeClashNames `intersect` f') + logm $ "renameTopLevelVarName:(oldPN,modName)=" ++ showGhc (oldPN,modName) + -- Another implementation option is to add the qualifier to newName automatically. + 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]) . -- only check the declared names here + --the same name has been declared in this module. + 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) . -- causeAmbiguityInExports oldPN newNameGhc {- inscps -} renamed + error $ mconcat ["The new name will cause ambiguity in the exports of module '" + , show modName + , "' , please select another name!"] + -- get all of those declared names visible to oldPN at where oldPN is used. + + 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)) -- ++AZ++ - logm $ "renameInClientMod:(newNameGhc module)=" ++ (showGhc (GHC.nameModule newNameGhc)) -- ++AZ++ - getTargetGhc targetModule + logm $ "renameInClientMod:(oldPN,newNameGhc,targetModule)=" ++ showGhc (oldPN,newNameGhc,targetModule) -- ++AZ++ + logm $ "renameInClientMod:(newNameGhc module)=" ++ showGhc (GHC.nameModule newNameGhc) -- ++AZ++ + getTargetGhc targetModule - renamed <- getRefactRenamed - modName <- getRefactModuleName + renamed <- getRefactRenamed + modName <- getRefactModuleName - -- We need to find the old name in the module, and get it as a - -- GHC.Name to know what to look for in the call to renamePN', as it - -- checks the GHC.nameUnique value. - -- gnames <- GHC.getNamesInScope - -- let clientModule = GHC.nameModule oldPN - -- let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames - -- logm $ "renameInClientMod:(clientInscopes)=" ++ showGhcQual (clientInscopes) - -- let newNames = filter (\n -> showGhcQual n == showGhcQual oldPN) clientInscopes - newNames <- equivalentNameInNewMod oldPN - logm $ "renameInClientMod:(newNames)=" ++ showGhcQual (newNames) + -- We need to find the old name in the module, and get it as a + -- GHC.Name to know what to look for in the call to renamePN', as it + -- checks the GHC.nameUnique value. + -- gnames <- GHC.getNamesInScope + -- let clientModule = GHC.nameModule oldPN + -- let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames + -- logm $ "renameInClientMod:(clientInscopes)=" ++ showGhcQual (clientInscopes) + -- let newNames = filter (\n -> showGhcQual n == showGhcQual oldPN) clientInscopes + newNames <- equivalentNameInNewMod oldPN + logm $ "renameInClientMod:(newNames)=" ++ showGhcQual newNames - -- newNames <- inScopeNames (showGhcQual oldPN) - -- newNamesUnqual <- inScopeNames (showGhc oldPN) - -- logm $ "renameInClientMod:(newNamesUnqual,oldPN)=" ++ showGhcQual (newNamesUnqual,oldPN) - -- logm $ "renameInClientMod:(newNames,oldPN)=" ++ showGhcQual (newNames,oldPN) - -- logm $ "renameInClientMod:(uniques:newNames,oldPN)=" ++ showGhcQual (map GHC.nameUnique newNames,GHC.nameUnique oldPN) - case newNames of + -- newNames <- inScopeNames (showGhcQual oldPN) + -- newNamesUnqual <- inScopeNames (showGhc oldPN) + -- logm $ "renameInClientMod:(newNamesUnqual,oldPN)=" ++ showGhcQual (newNamesUnqual,oldPN) + -- logm $ "renameInClientMod:(newNames,oldPN)=" ++ showGhcQual (newNames,oldPN) + -- logm $ "renameInClientMod:(uniques:newNames,oldPN)=" ++ showGhcQual (map GHC.nameUnique newNames,GHC.nameUnique oldPN) + case newNames of [] -> return [] - [oldName] -> - if findPN oldName renamed - then doRenameInClientMod oldName modName renamed - else do - logm $ "renameInClientMod:name not present in module, returning" - return [] - ns -> error $ "HaRe:renameInClientMod:could not find name to replace,got:" ++ showGhcQual ns + [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 + doRenameInClientMod oldNameGhc modName renamed = do -- There are two different tests we need to do here -- 1. Does the new name clash with some existing name in the -- client mod, in which case it must be qualified @@ -235,108 +239,96 @@ -- be qualified in the replacement, according to the import isInScopeUnqual <- isInScopeAndUnqualifiedGhc (nameToString oldPN) Nothing isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName Nothing - logm $ "renameInClientMod: (isInScopeAndUnqual,isInScopeUnqualNew)=" ++ (show (isInScopeUnqual,isInScopeUnqualNew)) -- ++AZ++ + logm $ "renameInClientMod: (isInScopeAndUnqual,isInScopeUnqualNew)=" ++ + show (isInScopeUnqual, isInScopeUnqualNew) -- ++AZ++ + if isInScopeUnqualNew -- ++AZ++: should this be negated? - then - do - -- (refactoredMod,_) <- applyRefac (refactRenameSimple oldPN newName newNameGhc True) RSAlreadyLoaded - (refactoredMod,_) <- applyRefac (refactRenameSimple oldNameGhc 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 - (refactoredMod,_) <- applyRefac (refactRenameComplex oldNameGhc newName newNameGhc) RSAlreadyLoaded - -- TODO: implement rest of this - return [refactoredMod] + 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 oldPN newName newNameGhc) RSAlreadyLoaded + (refactoredMod, _) <- applyRefac (refactRenameComplex oldNameGhc newName newNameGhc) + RSAlreadyLoaded + -- TODO: implement rest of this + 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 <- getRefactParsed - parsed' <- renamePN old new useQual parsed - putRefactParsed parsed' mempty - return () + 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 + 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 () + 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') - renamed <- getRefactRenamed - parsed <- getRefactParsed - isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName' Nothing - vs <- hsVisibleNames oldPN' renamed --Does this check names other than variable names? - logm $ "renameInClientMod.worker:(vs,oldPN',isInScopeUnqualNew)=" ++ showGhc (vs,oldPN',isInScopeUnqualNew) - parsed' <- if elem newName' ((nub vs) \\ [nameToString oldPN']) || isInScopeUnqualNew - then renamePN oldPN' newNameGhc' True parsed --rename to qualified Name - else renamePN oldPN' newNameGhc' False parsed -- do not qualify - putRefactParsed parsed' mempty - 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 -- Does this check names other than variable names? + 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 {- inscps -} = do +causeAmbiguityInExports old newName {- inscps -} = 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)) + 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 + 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!" + tyconOk = doTest (GHC.isTyConName oldName) (isConId newName) "Invalid type constructor/class name!" - dataConOk = doTest (GHC.isDataConName oldName) - (isConId newName) - "Invalid data constructor name!" + dataConOk = doTest (GHC.isDataConName oldName) (isConId newName) "Invalid data constructor name!" - tyVarOk = doTest (GHC.isTyVarName oldName) - (isVarId newName) - "Invalid type variable name!" + tyVarOk = doTest (GHC.isTyVarName oldName) (isVarId newName) "Invalid type variable name!" - oldName' = rdrNameStr - matchNamesOk - | {- GHC.isValName oldName || -} 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!" - else error $ "Invalid new name!" ++ (show (oldName',newName,isVarId oldName',isVarId newName,isOperator oldName',isOperator newName)) - | otherwise = True + oldName' = rdrNameStr + matchNamesOk + | {- GHC.isValName oldName || -} 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 {- && fieldOk && instanceOk -} && - tyVarOk && matchNamesOk + res = tyconOk && dataConOk {- && fieldOk && instanceOk -} && tyVarOk && matchNamesOk -- EOF - diff --git a/src/Language/Haskell/Refact/Utils/Utils.hs b/src/Language/Haskell/Refact/Utils/Utils.hs --- a/src/Language/Haskell/Refact/Utils/Utils.hs +++ b/src/Language/Haskell/Refact/Utils/Utils.hs @@ -16,7 +16,6 @@ -- * The bits that do the work , runRefacSession - , runRefactGhcCd , applyRefac , refactDone @@ -26,6 +25,9 @@ , clientModsAndFiles , serverModsAndFiles + , modifiedFiles + , writeRefactoredFiles + ) where import Control.Exception @@ -198,7 +200,7 @@ , rsModule = Nothing } - (refactoredMods,_s) <- runRefactGhcCd comp initialState opt + (refactoredMods,_s) <- runRefactGhc comp initialState opt let verbosity = rsetVerboseLevel (rsSettings initialState) writeRefactoredFiles verbosity refactoredMods @@ -206,24 +208,6 @@ -- --------------------------------------------------------------------- -runRefactGhcCd :: - RefactGhc a -> RefactState -> GM.Options -> IO (a, RefactState) -runRefactGhcCd comp initialState opt = do - - let - runMain :: IO a -> IO a - runMain progMain = do - catches progMain [ - Handler $ \(GM.GMEWrongWorkingDirectory projDir _curDir) -> do - cdAndDo projDir progMain - ] - - fullComp = runRefactGhc comp initialState opt - - runMain fullComp - --- --------------------------------------------------------------------- - cdAndDo :: FilePath -> IO a -> IO a cdAndDo path fn = do old <- getCurrentDirectory @@ -467,4 +451,3 @@ $ map summaryNodeSummary $ GHC.reachableG mg modNode return serverMods - diff --git a/test/RenamingSpec.hs b/test/RenamingSpec.hs --- a/test/RenamingSpec.hs +++ b/test/RenamingSpec.hs @@ -354,7 +354,7 @@ it "naming clash at top level IdIn3" $ do -- rename logTestSettings testOptions Nothing "./Renaming/IdIn3.hs" "foo" (10,1) res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/IdIn3.hs" "foo" (10,1)) - (show res) `shouldBe` "Just \"Name 'foo' already existed\\n\"" + (show res) `shouldBe` "Just \"Name 'foo' already exists in this module\\n\"" -- --------------------------------- @@ -368,7 +368,7 @@ it "naming clash IdIn5" $ do -- rename logTestSettings testOptions "./Renaming/IdIn5.hs" "y" (10,1) res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/IdIn5.hs" "y" (10,1)) - (show res) `shouldBe` "Just \"Name 'y' already existed, or rename 'IdIn5.x' to 'y' will change the program's semantics!\\n\"" + (show res) `shouldBe` "Just \"Name 'y' already exists, or renaming 'IdIn5.x' to 'y' will change the program's semantics!\\n\"" -- --------------------------------- @@ -382,14 +382,14 @@ it "will not rename existing name Field2" $ do -- rename logTestSettings testOptions Nothing "./Renaming/Field2.hs" "absPoint" (5,18) res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/Field2.hs" "absPoint" (5,18)) - (show res) `shouldBe` "Just \"Name 'absPoint' already existed\\n\"" + (show res) `shouldBe` "Just \"Name 'absPoint' already exists in this module\\n\"" -- --------------------------------- it "must qualify clashes Qualifier" $ do -- rename logTestSettings testOptions "./Renaming/Qualifier.hs" "sum" (13,1) res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/Qualifier.hs" "sum" (13,1)) - (show res) `shouldBe` "Just \"The new name will cause ambiguous occurrence problem, please select another new name or qualify the use of ' sum' before renaming!\\n\"" + (show res) `shouldBe` "Just \"The new name will cause an ambiguous occurrence problem, please select another new name or qualify the use of 'sum' before renaming!\\n\"" -- --------------------------------- @@ -610,6 +610,6 @@ r' <- ct $ mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"Renaming/RenameInExportedType2.hs\"]" -} - + -- --------------------------------------------------------------------- -- Helper functions diff --git a/test/UtilsSpec.hs b/test/UtilsSpec.hs --- a/test/UtilsSpec.hs +++ b/test/UtilsSpec.hs @@ -581,14 +581,15 @@ describe "directoryManagement" $ do it "loads a file from a sub directory" $ do t <- ct $ parsedFileGhc "./FreeAndDeclared/DeclareS.hs" + fileName <- canonicalizePath "./test/testdata/FreeAndDeclared/DeclareS.hs" let renamed = fromJust $ GHC.tm_renamed_source t let comp = do - parseSourceFileGhc "./FreeAndDeclared/DeclareS.hs" + parseSourceFileGhc fileName r <- hsFreeAndDeclaredPNs renamed return r ((res),_s) <- cdAndDo "./test/testdata/FreeAndDeclared" $ - runRefactGhcCd comp initialState testOptions + runRefactGhc comp initialState testOptions -- Free Vars (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` "[]" diff --git a/test/testdata/testdata.cabal b/test/testdata/testdata.cabal --- a/test/testdata/testdata.cabal +++ b/test/testdata/testdata.cabal @@ -4,7 +4,7 @@ Maintainer: Alan Zimmerman Cabal-Version: >= 1.10 Build-Type: Simple -Other-Extensions: CPP +-- Other-Extensions: CPP Executable bcpp Main-Is: BCpp.hs