HaRe-0.7.0.3: src/Language/Haskell/Refact/DupDef.hs
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.Refact.DupDef(duplicateDef) where
import qualified Data.Generics as SYB
import qualified GHC.SYB.Utils as SYB
import qualified FastString as GHC
import qualified GHC
import qualified OccName as GHC
import Data.List
import Data.Maybe
import Language.Haskell.GhcMod
import Language.Haskell.Refact.Utils
import Language.Haskell.Refact.Utils.GhcUtils
import Language.Haskell.Refact.Utils.GhcVersionSpecific
import Language.Haskell.Refact.Utils.LocUtils
import Language.Haskell.Refact.Utils.Monad
import Language.Haskell.Refact.Utils.MonadFunctions
import Language.Haskell.Refact.Utils.TypeSyn
import Language.Haskell.Refact.Utils.TypeUtils
-- ---------------------------------------------------------------------
-- | This refactoring duplicates a definition (function binding or
-- simple pattern binding) at the same level with a new name provided by
-- the user. The new name should not cause name clash/capture.
duplicateDef :: RefactSettings -> Cradle -> FilePath -> String -> SimpPos -> IO [FilePath]
duplicateDef 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
if isVarId newName
then do
getModuleGhc fileName
renamed <- getRefactRenamed
parsed <- getRefactParsed
let (Just (modName,_)) = getModuleName parsed
let maybePn = locToName (GHC.mkFastString fileName) (row, col) renamed
case maybePn of
Just pn ->
do
-- refactoredMod@((_fp,ismod),(_toks',renamed')) <- applyRefac (doDuplicating pn newName) (Just modInfo) fileName
(refactoredMod@((_fp,ismod),(_toks',renamed')),_) <- applyRefac (doDuplicating pn newName) (RSFile fileName)
case (ismod) of
False -> error "The selected identifier is not a function/simple pattern name, or is not defined in this module "
True -> return ()
if modIsExported modName renamed
then do clients <- clientModsAndFiles modName
logm ("DupDef: clients=" ++ (showGhc clients)) -- ++AZ++ debug
refactoredClients <- mapM (refactorInClientMod (GHC.unLoc pn) modName
(findNewPName newName renamed')) clients
return $ refactoredMod:refactoredClients
else return [refactoredMod]
Nothing -> error "Invalid cursor position!"
else error $ "Invalid new function name:" ++ newName ++ "!"
doDuplicating :: GHC.Located GHC.Name -> String
-> RefactGhc ()
doDuplicating pn newName = do
inscopes <- getRefactInscopes
renamed <- getRefactRenamed
reallyDoDuplicating pn newName inscopes renamed
reallyDoDuplicating :: GHC.Located GHC.Name -> String
-> InScopes -> GHC.RenamedSource
-> RefactGhc ()
reallyDoDuplicating pn newName inscopes renamed = do
renamed' <- everywhereMStaged SYB.Renamer (SYB.mkM dupInMod
`SYB.extM` dupInMatch
`SYB.extM` dupInPat
`SYB.extM` dupInLet
`SYB.extM` dupInLetStmt
) renamed
putRefactRenamed renamed'
return ()
where
--1. The definition to be duplicated is at top level.
-- dupInMod :: (GHC.HsGroup GHC.Name)-> RefactGhc (GHC.HsGroup GHC.Name)
dupInMod (grp :: (GHC.HsGroup GHC.Name))
| not $ emptyList (findFunOrPatBind pn (hsBinds grp)) = doDuplicating' inscopes grp pn
dupInMod grp = return grp
--2. The definition to be duplicated is a local declaration in a match
dupInMatch (match@(GHC.Match _pats _typ rhs)::GHC.Match GHC.Name)
| not $ emptyList (findFunOrPatBind pn (hsBinds rhs)) = doDuplicating' inscopes match pn
dupInMatch match = return match
--3. The definition to be duplicated is a local declaration in a pattern binding
dupInPat (pat@(GHC.PatBind _p rhs _typ _fvs _) :: GHC.HsBind GHC.Name)
| not $ emptyList (findFunOrPatBind pn (hsBinds rhs)) = doDuplicating' inscopes pat pn
dupInPat pat = return pat
--4: The defintion to be duplicated is a local decl in a Let expression
dupInLet (letExp@(GHC.HsLet ds _e):: GHC.HsExpr GHC.Name)
| not $ emptyList (findFunOrPatBind pn (hsBinds ds)) = doDuplicating' inscopes letExp pn
dupInLet letExp = return letExp
--5. The definition to be duplicated is a local decl in a case alternative.
-- Note: The local declarations in a case alternative are covered in #2 above.
--6.The definition to be duplicated is a local decl in a Let statement.
dupInLetStmt (letStmt@(GHC.LetStmt ds):: GHC.Stmt GHC.Name)
-- was |findFunOrPatBind pn ds /=[]=doDuplicating' inscps letStmt pn
|not $ emptyList (findFunOrPatBind pn (hsBinds ds)) = doDuplicating' inscopes letStmt pn
dupInLetStmt letStmt = return letStmt
-- findFunOrPatBind :: (SYB.Data t) => GHC.Located GHC.Name -> t -> [GHC.LHsBind GHC.Name]
findFunOrPatBind (GHC.L _ n) ds = filter (\d->isFunBindR d || isSimplePatBind d) $ definingDeclsNames [n] ds True False
doDuplicating' :: (HsValBinds t) => InScopes -> t -> GHC.Located GHC.Name
-> RefactGhc (t)
doDuplicating' _inscps parentr ln@(GHC.L _ n)
= do let
declsr = hsBinds parentr
duplicatedDecls = definingDeclsNames [n] declsr True False
-- (after,before) = break (definesP pn) (reverse declsp)
(f,d) <- hsFDNamesFromInside parentr
--f: names that might be shadowd by the new name,
--d: names that might clash with the new name
let dv = hsVisibleNames ln declsr --dv: names may shadow new name
let vars = nub (f `union` d `union` dv)
newNameGhc <- mkNewGhcName Nothing newName
-- TODO: Where definition is of form tup@(h,t), test each element of it for clashes, or disallow
nameAlreadyInScope <- isInScopeAndUnqualifiedGhc newName Nothing
-- logm ("DupDef: nameAlreadyInScope =" ++ (show nameAlreadyInScope)) -- ++AZ++ debug
-- logm ("DupDef: ln =" ++ (show ln)) -- ++AZ++ debug
if elem newName vars || (nameAlreadyInScope && findEntity ln duplicatedDecls)
then error ("The new name'"++newName++"' will cause name clash/capture or ambiguity problem after "
++ "duplicating, please select another name!")
else do newBinding <- duplicateDecl declsr parentr n newNameGhc
-- let newDecls = replaceDecls declsr (declsr ++ newBinding)
let newDecls = replaceBinds declsr (declsr ++ newBinding)
return $ replaceBinds parentr newDecls
-- | Find the the new definition name in GHC.Name format.
findNewPName :: String -> GHC.RenamedSource -> GHC.Name
findNewPName name renamed = gfromJust "findNewPName" res
where
res = somethingStaged SYB.Renamer Nothing
(Nothing `SYB.mkQ` worker) renamed
worker (pname::GHC.Name)
| (GHC.occNameString $ GHC.getOccName pname) == name = Just pname
worker _ = Nothing
-- | Do refactoring in the client module. That is to hide the
-- identifer in the import declaration if it will cause any problem in
-- the client module.
refactorInClientMod :: GHC.Name -> GHC.ModuleName -> GHC.Name -> GHC.ModSummary
-> RefactGhc ApplyRefacResult
refactorInClientMod oldPN serverModName newPName modSummary
= do
logm ("refactorInClientMod: (serverModName,newPName)=" ++ (showGhc (serverModName,newPName))) -- ++AZ++ debug
let fileName = gfromJust "refactorInClientMod" $ GHC.ml_hs_file $ GHC.ms_location modSummary
-- modInfo@(t,ts) <- getModuleGhc fileName
getModuleGhc fileName
renamed <- getRefactRenamed
parsed <- getRefactParsed
let modNames = willBeUnQualImportedBy serverModName renamed
logm ("refactorInClientMod: (modNames)=" ++ (showGhc (modNames))) -- ++AZ++ debug
-- if isJust modNames && needToBeHided (pNtoName newPName) exps parsed
mustHide <- needToBeHided newPName renamed parsed
logm ("refactorInClientMod: (mustHide)=" ++ (showGhc (mustHide))) -- ++AZ++ debug
if isJust modNames && mustHide
then do
-- refactoredMod <- applyRefac (doDuplicatingClient serverModName [newPName]) (Just modInfo) fileName
(refactoredMod,_) <- applyRefac (doDuplicatingClient serverModName [newPName]) (RSFile fileName)
return refactoredMod
else return ((fileName,unmodified),([],renamed))
where
needToBeHided :: GHC.Name -> GHC.RenamedSource -> GHC.ParsedSource -> RefactGhc Bool
needToBeHided name exps parsed = do
let usedUnqual = usedWithoutQualR name parsed
logm ("refactorInClientMod: (usedUnqual)=" ++ (showGhc (usedUnqual))) -- ++AZ++ debug
return $ usedUnqual || causeNameClashInExports oldPN name serverModName exps
doDuplicatingClient :: GHC.ModuleName -> [GHC.Name]
-> RefactGhc ()
doDuplicatingClient serverModName newPNames = do
renamed <- getRefactRenamed
renamed' <- addHiding serverModName renamed newPNames
putRefactRenamed renamed'
return ()
{-
--Do refactoring in the client module.
-- that is to hide the identifer in the import declaration if it will cause any problem in the client module.
refactorInClientMod serverModName newPName (modName, fileName)
= do (inscps, exps,parsed ,ts) <- parseSourceFile fileName
let modNames = willBeUnQualImportedBy serverModName parsed
if isJust modNames && needToBeHided (pNtoName newPName) exps parsed
then do (parsed', ((ts',m),_))<-runStateT (addHiding serverModName parsed [newPName]) ((ts,unmodified),fileName)
return ((fileName,m), (ts',parsed'))
else return ((fileName,unmodified),(ts,parsed))
where
needToBeHided name exps parsed
=usedWithoutQual name (hsModDecls parsed)
|| causeNameClashInExports newPName name parsed exps
-}
--Check here:
-- | get the module name or alias name by which the duplicated
-- definition will be imported automatically.
willBeUnQualImportedBy :: GHC.ModuleName -> GHC.RenamedSource -> Maybe [GHC.ModuleName]
willBeUnQualImportedBy modName (_,imps,_,_)
= let
ms = filter (\(GHC.L _ (GHC.ImportDecl (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as h))
-> modName == modName1
&& not isQualified
&& (isNothing h -- not hiding
||
(isJust h && ((fst (fromJust h))==True))
))
imps
in if (emptyList ms) then Nothing
else Just $ nub $ map getModName ms
where getModName (GHC.L _ (GHC.ImportDecl _modName1 _qualify _source _safe _isQualified _isImplicit as _h))
= if isJust as then (fromJust as)
else modName
-- simpModName (SN m loc) = m
{- ++AZ++ original
--Check here:
--get the module name or alias name by which the duplicated definition will be imported automatically.
willBeUnQualImportedBy::HsName.ModuleName->HsModuleP->Maybe [HsName.ModuleName]
willBeUnQualImportedBy modName parsed
= let imps = hsModImports parsed
ms = filter (\(HsImportDecl _ (SN modName1 _) qualify as h)->modName==modName1 && (not qualify) &&
(isNothing h || (isJust h && ((fst (fromJust h))==True)))) imps
in if ms==[] then Nothing
else Just $ nub $ map getModName ms
where getModName (HsImportDecl _ (SN modName _) qualify as h)
= if isJust as then simpModName (fromJust as)
else modName
simpModName (SN m loc) = m
-}