{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Refact.DupDef(duplicateDef) where import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB import qualified GHC import qualified OccName as GHC import Control.Monad import Data.List import Data.Maybe import Language.Haskell.GhcMod import Language.Haskell.Refact.Utils.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 (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 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 -> TargetModule -> RefactGhc ApplyRefacResult refactorInClientMod oldPN serverModName newPName targetModule@(_,modSummary) = do logm ("refactorInClientMod: (serverModName,newPName)=" ++ (showGhc (serverModName,newPName))) -- ++AZ++ debug void $ activateModule targetModule 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 (gfromJust "willBeUnQualImportedBy" 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 -}