module Language.Haskell.Refact.Refactoring.MoveDef
( liftToTopLevel
, liftOneLevel
, demote
) where
import qualified Data.Generics as SYB
import qualified GHC.SYB.Utils as SYB
import qualified Data.Generics.Zipper as Z
import qualified Exception as GHC
import qualified FastString as GHC
import qualified GHC as GHC
import qualified Name as GHC
import qualified RdrName as GHC
import qualified TyCon as GHC
import qualified TypeRep as GHC
import qualified Var as Var
import Control.Exception
import Control.Monad.State
import Data.Foldable
import Data.List
import Data.Maybe
import qualified Language.Haskell.GhcMod as GM
import Language.Haskell.Refact.API
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint
import Data.Generics.Strafunski.StrategyLib.StrategyLib
import System.Directory
liftToTopLevel :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath]
liftToTopLevel settings opts fileName (row,col) = do
absFileName <- canonicalizePath fileName
runRefacSession settings opts (compLiftToTopLevel absFileName (row,col))
compLiftToTopLevel :: FilePath -> SimpPos
-> RefactGhc [ApplyRefacResult]
compLiftToTopLevel fileName (row,col) = do
parseSourceFileGhc fileName
renamed <- getRefactRenamed
parsed <- getRefactParsed
let (Just (modName,_)) = getModuleName parsed
let maybePn = locToName (row, col) renamed
case maybePn of
Just pn -> liftToTopLevel' modName pn
_ -> error "\nInvalid cursor position!\n"
liftToTopLevel' :: GHC.ModuleName
-> GHC.Located GHC.Name
-> RefactGhc [ApplyRefacResult]
liftToTopLevel' modName pn@(GHC.L _ n) = do
renamed <- getRefactRenamed
targetModule <- getRefactTargetModule
logm $ "liftToTopLevel':pn=" ++ (showGhc pn)
if isLocalFunOrPatName n renamed
then do
(refactoredMod,declPns) <- applyRefac liftToMod RSAlreadyLoaded
logm $ "liftToTopLevel' applyRefac done "
if modIsExported modName renamed
then do clients <- clientModsAndFiles targetModule
logm $ "liftToTopLevel':(clients,declPns)=" ++ (showGhc (clients,declPns))
refactoredClients <- mapM (liftingInClientMod modName declPns) clients
return (refactoredMod:(concat refactoredClients))
else do return [refactoredMod]
else error "\nThe identifier is not a local function/pattern name!"
where
liftToMod = do
renamed <- getRefactRenamed
parsed <- getRefactParsed
declsp <- liftT $ hsDecls parsed
(before,parent,after) <- divideDecls declsp pn
nameMap <- getRefactNameMap
let liftedDecls = definingDeclsRdrNames nameMap [n] parent True True
declaredPns = nub $ concatMap (definedNamesRdr nameMap) liftedDecls
liftedSigs = definingSigsRdrNames nameMap declaredPns parent
mLiftedSigs = liftedSigs
pns <- pnsNeedRenaming parsed parent liftedDecls declaredPns
logm $ "liftToMod:(pns needing renaming)=" ++ (showGhc pns)
let dd = getDeclaredVars $ hsBinds renamed
logm $ "liftToMod:(ddd)=" ++ (showGhc dd)
if pns == []
then do
(parent',liftedDecls',mLiftedSigs') <- addParamsToParentAndLiftedDecl n dd parent liftedDecls mLiftedSigs
let defName = (ghead "liftToMod" (definedNamesRdr nameMap (ghead "liftToMod2" parent')))
parsed' <- liftT $ replaceDecls parsed (before++parent'++after)
parsed2 <- moveDecl1 parsed' (Just defName) [GHC.unLoc pn] liftedDecls'
declaredPns mLiftedSigs'
putRefactParsed parsed2 emptyAnns
return declaredPns
else askRenamingMsg pns "lifting"
liftOneLevel :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath]
liftOneLevel settings opts fileName (row,col) = do
absFileName <- canonicalizePath fileName
runRefacSession settings opts (compLiftOneLevel absFileName (row,col))
compLiftOneLevel :: FilePath -> SimpPos
-> RefactGhc [ApplyRefacResult]
compLiftOneLevel fileName (row,col) = do
parseSourceFileGhc fileName
renamed <- getRefactRenamed
parsed <- getRefactParsed
let (Just (modName,_)) = getModuleName parsed
let maybePn = locToName (row, col) renamed
case maybePn of
Just pn -> do
rs <- liftOneLevel' modName pn
logm $ "compLiftOneLevel:rs=" ++ (show $ (refactDone rs,map (\((_,d),_) -> d) rs))
if (refactDone rs)
then return rs
else error ( "Lifting this definition failed. "++
" This might be because that the definition to be "++
"lifted is defined in a class/instance declaration.")
_ -> error "\nInvalid cursor position!\n"
liftOneLevel' :: GHC.ModuleName
-> GHC.Located GHC.Name
-> RefactGhc [ApplyRefacResult]
liftOneLevel' modName pn@(GHC.L _ n) = do
renamed <- getRefactRenamed
targetModule <- getRefactTargetModule
if isLocalFunOrPatName n renamed
then do
(refactoredMod,(b,pns)) <- applyRefac doLiftOneLevel RSAlreadyLoaded
logm $ "liftOneLevel':main refactoring done:(p,pns)=" ++ showGhc (b,pns)
if b && modIsExported modName renamed
then do
logm $ "liftOneLevel':looking for clients"
clients <- clientModsAndFiles targetModule
logm $ "liftOneLevel':(clients,pns)=" ++ (showGhc (clients,pns))
refactoredClients <- mapM (liftingInClientMod modName pns) clients
return (refactoredMod:concat refactoredClients)
else do return [refactoredMod]
else error "\nThe identifer is not a function/pattern name!"
where
doLiftOneLevel = do
logm $ "in doLiftOneLevel"
parsed <- getRefactParsed
logDataWithAnns "doLiftOneLevel:parsed" parsed
nm <- getRefactNameMap
ans <- liftT getAnnsT
zp <- ztransformStagedM SYB.Parser
(Nothing
`SYB.mkQ` (liftToModQ nm ans)
`SYB.extQ` (liftToMatchQ nm ans)
`SYB.extQ` (liftToLetQ nm ans)
) (Z.toZipper parsed)
let parsed' = Z.fromZipper zp
putRefactParsed parsed' emptyAnns
liftedToTopLevel pn parsed'
where
isMatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Bool
isMatch _ = True
isHsLet :: GHC.LHsExpr GHC.RdrName -> Bool
isHsLet (GHC.L _ (GHC.HsLet _ _)) = True
isHsLet _ = False
liftToModQ ::
NameMap -> Anns
-> GHC.ParsedSource
-> Maybe (SYB.Stage
-> Z.Zipper GHC.ParsedSource
-> RefactGhc (Z.Zipper GHC.ParsedSource))
liftToModQ nm ans (p :: GHC.ParsedSource)
| nonEmptyList candidateBinds
= Just (doLiftZ p declsp)
| otherwise = Nothing
where
(declsp ,_,_) = runTransform ans (hsDecls p)
doOne bs = (definingDeclsRdrNames nm [n] declsbs False False,bs)
where
(declsbs,_,_) = runTransform ans (hsDeclsGeneric bs)
candidateBinds = map snd
$ filter (\(l,_bs) -> nonEmptyList l)
$ map doOne
$ declsp
getHsDecls ans t = decls
where (decls,_,_) = runTransform ans (hsDeclsGeneric t)
liftToMatchQ :: (SYB.Data a)
=> NameMap -> Anns
-> GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)
-> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a))
liftToMatchQ nm ans (m@(GHC.L _ (GHC.Match _ _pats _mtyp (GHC.GRHSs _rhs ds)))::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))
| (nonEmptyList (definingDeclsRdrNames nm [n] (getHsDecls ans ds) False False))
= Just (doLiftZ m (getHsDecls ans ds))
| otherwise = Nothing
liftToLetQ :: SYB.Data a
=> NameMap -> Anns
-> GHC.LHsExpr GHC.RdrName -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a))
liftToLetQ nm ans ll@(GHC.L _ (GHC.HsLet ds _e))
| nonEmptyList (definingDeclsRdrNames nm [n] (getHsDecls ans ds) False False)
= Just (doLiftZ ll (getHsDecls ans ll))
| otherwise = Nothing
liftToLetQ _ _ _ = Nothing
doLiftZ :: (SYB.Data t,SYB.Data a)
=> t
-> [GHC.LHsDecl GHC.RdrName]
-> SYB.Stage
-> Z.Zipper a
-> RefactGhc (Z.Zipper a)
doLiftZ ds decls _stage z =
do
logm $ "doLiftZ entered"
logDataWithAnns "doLiftZ:ds" ds
logDataWithAnns "doLiftZ:decls" decls
let zu = case (Z.up z) of
Just zz -> fromMaybe (error $ "MoveDef.liftToLet.1" ++ SYB.showData SYB.Parser 0 decls)
$ upUntil (False `SYB.mkQ` isMatch
`SYB.extQ` isHsLet
)
zz
Nothing -> z
let
wtop (ren::GHC.ParsedSource) = do
logm $ "wtop entered"
nm <- getRefactNameMap
let (_,DN dd) = (hsFreeAndDeclaredRdr nm ren)
worker ren decls pn dd
wmatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)
-> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))
wmatch (m@(GHC.L _ (GHC.Match _mln _pats _typ grhss))) = do
logm $ "wmatch entered:" ++ SYB.showData SYB.Parser 0 m
nm <- getRefactNameMap
let (_,DN dd) = hsFreeAndDeclaredRdr nm grhss
decls' <- liftT $ hsDecls m
workerTop m decls' dd
wlet :: GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName)
wlet l@(GHC.L _ (GHC.HsLet dsl _e)) = do
logm $ "wlet entered "
nm <- getRefactNameMap
let (_,DN dd) = hsFreeAndDeclaredRdr nm dsl
dsl' <- workerTop l decls dd
return dsl'
wlet x = return x
ds' <- Z.transM ( SYB.mkM wtop
`SYB.extM` wmatch
`SYB.extM` wlet
) zu
return ds'
workerTop :: (HasDecls t)
=> t
-> [GHC.LHsDecl GHC.RdrName]
-> [GHC.Name]
-> RefactGhc t
workerTop dest ds dd
=do
logm $ "MoveDef.worker: dest" ++ SYB.showData SYB.Parser 0 dest
logm $ "MoveDef.workerTop: ds=" ++ (showGhc ds)
done <- getRefactDone
if done then return dest
else do
setRefactDone
let parent = dest
nm <- getRefactNameMap
let liftedDecls = definingDeclsRdrNames' nm [n] parent
declaredPns = nub $ concatMap (definedNamesRdr nm) liftedDecls
logm $ "MoveDef.workerTop: n=" ++ (showGhc n)
logm $ "MoveDef.workerTop: liftedDecls=" ++ (showGhc liftedDecls)
pns <- pnsNeedRenaming dest parent liftedDecls declaredPns
logm $ "MoveDef.workerTop: pns=" ++ (showGhc pns)
if pns==[]
then do
(parent',liftedDecls',mLiftedSigs')<-addParamsToParentAndLiftedDecl n dd
parent liftedDecls []
logm $ "MoveDef.workerTop: liftedDecls'=" ++ (showGhc liftedDecls')
let toMove = parent'
pdecls <- liftT $ hsDecls toMove
let mAfter = case pdecls of
[] -> Nothing
_ -> (Just (ghead "worker" (definedNamesRdr nm (glast "workerTop" ds))))
dest' <- moveDecl1 toMove
mAfter
[n] liftedDecls' declaredPns mLiftedSigs'
return dest'
else askRenamingMsg pns "lifting"
worker :: (HasDecls t)
=> t
-> [GHC.LHsDecl GHC.RdrName]
-> GHC.Located GHC.Name
-> [GHC.Name]
-> RefactGhc t
worker dest ds pnn dd
=do
logm $ "MoveDef.worker: ds=" ++ (showGhc ds)
done <- getRefactDone
if done then return dest
else do
setRefactDone
(before,parent,after) <- divideDecls ds pnn
logm $ "MoveDef.worker:(before,parent,after)" ++ showGhc (before,parent,after)
nm <- getRefactNameMap
let liftedDecls = definingDeclsRdrNames nm [n] parent True True
declaredPns = nub $ concatMap (definedNamesRdr nm) liftedDecls
pns <- pnsNeedRenaming dest parent liftedDecls declaredPns
logm $ "MoveDef.worker: pns=" ++ (showGhc pns)
if pns==[]
then do
(parent',liftedDecls',mLiftedSigs')<-addParamsToParentAndLiftedDecl n dd
parent liftedDecls []
toMove <- liftT $ replaceDecls dest (before++parent'++after)
dest' <- moveDecl1 toMove
(Just (ghead "worker" (definedNamesRdr nm (ghead "worker" parent'))))
[n] liftedDecls' declaredPns mLiftedSigs'
return dest'
else askRenamingMsg pns "lifting"
demote :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath]
demote settings opts fileName (row,col) = do
absFileName <- canonicalizePath fileName
runRefacSession settings opts (compDemote absFileName (row,col))
compDemote ::FilePath -> SimpPos
-> RefactGhc [ApplyRefacResult]
compDemote fileName (row,col) = do
parseSourceFileGhc fileName
renamed <- getRefactRenamed
parsed <- getRefactParsed
let (Just (modName,_)) = getModuleName parsed
let maybePn = locToName (row, col) renamed
case maybePn of
Just pn -> demote' modName pn
_ -> error "\nInvalid cursor position!\n"
moveDecl1 :: (SYB.Data t)
=> t
-> Maybe GHC.Name
-> [GHC.Name]
-> [GHC.LHsDecl GHC.RdrName]
-> [GHC.Name]
-> [GHC.LSig GHC.RdrName]
-> RefactGhc t
moveDecl1 t defName ns mliftedDecls sigNames mliftedSigs = do
logm $ "moveDecl1:(defName,ns,sigNames,mliftedDecls)=" ++ showGhc (defName,ns,sigNames,mliftedDecls)
logm $ "moveDecl1:(t)=" ++ SYB.showData SYB.Parser 0 (t)
(t'',_sigsRemoved) <- rmTypeSigs sigNames t
logm $ "moveDecl1:mliftedSigs=" ++ showGhc mliftedSigs
(t',_declRemoved,_sigRemoved) <- rmDecl (ghead "moveDecl3.1" ns) False t''
logm $ "moveDecl1:after rmDecl:t'" ++ SYB.showData SYB.Parser 0 t'
let sigs = map wrapSig mliftedSigs
r <- addDecl t' defName (sigs++mliftedDecls,Nothing)
return r
askRenamingMsg :: [GHC.Name] -> String -> t
askRenamingMsg pns str
= error ("The identifier(s): " ++ (intercalate "," $ map showPN pns) ++
" will cause name clash/capture or ambiguity occurrence problem after "
++ str ++", please do renaming first!")
where
showPN pn = showGhc (pn,GHC.nameSrcLoc pn)
pnsNeedRenaming :: (SYB.Data t1,SYB.Data t2) =>
t1 -> t2 -> t3 -> [GHC.Name]
-> RefactGhc [GHC.Name]
pnsNeedRenaming dest parent _liftedDecls pns
= do
logm $ "MoveDef.pnsNeedRenaming entered:pns=" ++ showGhc pns
r <- mapM pnsNeedRenaming' pns
return (concat r)
where
pnsNeedRenaming' pn
= do
logm $ "MoveDef.pnsNeedRenaming' entered"
nm <- getRefactNameMap
(FN f,DN d) <- hsFDsFromInsideRdr nm dest
logm $ "MoveDef.pnsNeedRenaming':(f,d)=" ++ showGhc (f,d)
vs <- hsVisiblePNsRdr nm pn parent
logm $ "MoveDef.pnsNeedRenaming':vs=" ++ showGhc vs
let vars = map pNtoName (nub (f `union` d `union` vs) \\ [pn])
isInScope <- isInScopeAndUnqualifiedGhc (pNtoName pn) Nothing
logm $ "MoveDef.pnsNeedRenaming:(f,d,vs,vars,isInScope)=" ++ (showGhc (f,d,vs,vars,isInScope))
if elem (pNtoName pn) vars || isInScope && findEntity pn dest
then return [pn]
else return []
pNtoName = showGhc
addParamsToParent :: (SYB.Data t) => GHC.Name -> [GHC.RdrName] -> t -> RefactGhc t
addParamsToParent _pn [] t = return t
addParamsToParent pn params t = do
logm $ "addParamsToParent:(pn,params)" ++ (showGhc (pn,params))
addActualParamsToRhs pn params t
liftingInClientMod :: GHC.ModuleName -> [GHC.Name] -> TargetModule
-> RefactGhc [ApplyRefacResult]
liftingInClientMod serverModName pns targetModule = do
logm $ "liftingInClientMod:targetModule=" ++ (show targetModule)
getTargetGhc targetModule
parsed <- getRefactParsed
clientModule <- getRefactModule
logm $ "liftingInClientMod:clientModule=" ++ (showGhc clientModule)
modNames <- willBeUnQualImportedBy serverModName
logm $ "liftingInClientMod:modNames=" ++ (showGhc modNames)
if isJust modNames
then do
pns' <- namesNeedToBeHided clientModule (gfromJust "liftingInClientMod" modNames) pns
let pnsRdr' = map GHC.nameRdrName pns'
logm $ "liftingInClientMod:pns'=" ++ (showGhc pns')
if (nonEmptyList pns')
then do (refactoredMod,_) <- applyRefac (addHiding serverModName parsed pnsRdr') RSAlreadyLoaded
return [refactoredMod]
else return []
else return []
willBeExportedByClientMod :: [GHC.ModuleName] -> GHC.RenamedSource -> Bool
willBeExportedByClientMod names renamed =
let (_,_,exps,_) = renamed
in if isNothing exps
then False
else any isJust $ map (\y-> (find (\x-> (simpModule x==Just y)) (gfromJust "willBeExportedByClientMod" exps))) names
where simpModule (GHC.L _ (GHC.IEModuleContents (GHC.L _ m))) = Just m
simpModule _ = Nothing
willBeUnQualImportedBy :: GHC.ModuleName -> RefactGhc (Maybe [GHC.ModuleName])
willBeUnQualImportedBy modName = do
(_,imps,_,_) <- getRefactRenamed
let ms = filter (\(GHC.L _ (GHC.ImportDecl _ (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as h))
-> modName == modName1 && (not isQualified) && (isNothing h || (isJust h && ((fst (fromJust h)) == True))))
imps
res = if (emptyList ms) then Nothing
else Just $ nub $ map getModName ms
getModName (GHC.L _ (GHC.ImportDecl _ (GHC.L _ modName2) _qualify _source _safe _isQualified _isImplicit as _h))
= if isJust as then simpModName (fromJust as)
else modName2
simpModName m = m
logm $ "willBeUnQualImportedBy:(ms,res)=" ++ (showGhc (ms,res))
return res
namesNeedToBeHided :: GHC.Module -> [GHC.ModuleName] -> [GHC.Name]
-> RefactGhc [GHC.Name]
namesNeedToBeHided clientModule modNames pns = do
renamed <- getRefactRenamed
parsed <- getRefactParsed
logm $ "namesNeedToBeHided:willBeExportedByClientMod=" ++ (show $ willBeExportedByClientMod modNames renamed)
gnames <- GHC.getNamesInScope
let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames
logm $ "namesNeedToBeHided:(clientInscopes)=" ++ (showGhc (clientInscopes))
pnsMapped <- mapM getLocalEquiv pns
logm $ "namesNeedToBeHided:pnsMapped=" ++ (showGhc pnsMapped)
let pnsMapped' = filter (\(_,_,ns) -> not $ emptyList ns) pnsMapped
if willBeExportedByClientMod modNames renamed
then return pns
else do
ff <- mapM (needToBeHided parsed) pnsMapped'
return $ concat ff
where
getLocalEquiv :: GHC.Name -> RefactGhc (GHC.Name,String,[GHC.Name])
getLocalEquiv pn = do
let pnStr = stripPackage $ showGhc pn
logm $ "MoveDef getLocalEquiv: about to parseName:" ++ (show pnStr)
ecns <- GHC.gtry $ GHC.parseName pnStr
let cns = case ecns of
Left (_e::SomeException) -> []
Right v -> v
logm $ "MoveDef getLocalEquiv: cns:" ++ (showGhc cns)
return (pn,pnStr,cns)
stripPackage :: String -> String
stripPackage str = reverse s
where
(s,_) = break (== '.') $ reverse str
needToBeHided :: GHC.ParsedSource -> (GHC.Name,String,[GHC.Name]) -> RefactGhc [GHC.Name]
needToBeHided parsed (pn,_pnStr,pnsLocal) = do
let uwoq = map (\n -> usedWithoutQualR n parsed) pnsLocal
logm $ "needToBeHided:(pn,uwoq)=" ++ (showGhc (pn,uwoq))
if (any (== True) uwoq
|| False)
then return [pn]
else return []
liftedToTopLevel :: GHC.Located GHC.Name -> GHC.ParsedSource -> RefactGhc (Bool,[GHC.Name])
liftedToTopLevel pnt@(GHC.L _ pn) parsed = do
nm <- getRefactNameMap
decls <- liftT $ hsDecls parsed
let topDecs = definingDeclsRdrNames nm [pn] decls False False
if nonEmptyList topDecs
then do
(_, parent,_) <- divideDecls decls pnt
let declsp = parent
let liftedDecls = definingDeclsRdrNames nm [pn] declsp False False
declaredPns = nub $ concatMap (definedNamesRdr nm) liftedDecls
return (True, declaredPns)
else return (False, [])
addParamsToParentAndLiftedDecl :: (SYB.Data t) =>
GHC.Name
-> [GHC.Name]
-> t
-> [GHC.LHsDecl GHC.RdrName]
-> [GHC.LSig GHC.RdrName]
-> RefactGhc (t, [GHC.LHsDecl GHC.RdrName], [GHC.LSig GHC.RdrName])
addParamsToParentAndLiftedDecl pn dd parent liftedDecls mLiftedSigs
=do
logm $ "addParamsToParentAndLiftedDecl:liftedDecls=" ++ (showGhc liftedDecls)
nm <- getRefactNameMap
let (FN ef,_) = hsFreeAndDeclaredRdr nm parent
let (FN lf,_) = hsFreeAndDeclaredRdr nm liftedDecls
logm $ "addParamsToParentAndLiftedDecl:(ef,lf)=" ++ showGhc (ef,lf)
let newParamsNames = ((nub lf) \\ (nub ef)) \\ dd
newParams = map GHC.nameRdrName newParamsNames
logm $ "addParamsToParentAndLiftedDecl:(newParams,ef,lf,dd)=" ++ (showGhc (newParams,ef,lf,dd))
if newParams /= []
then if (any isComplexPatDecl liftedDecls)
then error "This pattern binding cannot be lifted, as it uses some other local bindings!"
else do
(parent'',liftedDecls'',_msig) <- rmDecl pn False parent
parent' <- addParamsToParent pn newParams parent''
liftedDecls' <- addParamsToDecls [liftedDecls''] pn newParams
mLiftedSigs' <- mapM (addParamsToSigs newParamsNames) mLiftedSigs
logm $ "addParamsToParentAndLiftedDecl:mLiftedSigs'=" ++ showGhc mLiftedSigs'
return (parent',liftedDecls', mLiftedSigs')
else return (parent,liftedDecls,mLiftedSigs)
addParamsToSigs :: [GHC.Name] -> GHC.LSig GHC.RdrName -> RefactGhc (GHC.LSig GHC.RdrName)
addParamsToSigs [] ms = return ms
addParamsToSigs newParams (GHC.L l (GHC.TypeSig lns ltyp pns)) = do
mts <- mapM getTypeForName newParams
let ts = catMaybes mts
logm $ "addParamsToSigs:ts=" ++ showGhc ts
logDataWithAnns "addParamsToSigs:ts=" ts
let newStr = ":: " ++ (intercalate " -> " $ map printSigComponent ts) ++ " -> "
logm $ "addParamsToSigs:newStr=[" ++ newStr ++ "]"
typ' <- liftT $ foldlM addOneType ltyp (reverse ts)
sigOk <- isNewSignatureOk ts
logm $ "addParamsToSigs:(sigOk,newStr)=" ++ show (sigOk,newStr)
if sigOk
then return (GHC.L l (GHC.TypeSig lns typ' pns))
else error $ "\nNew type signature may fail type checking: " ++ newStr ++ "\n"
where
addOneType :: GHC.LHsType GHC.RdrName -> GHC.Type -> Transform (GHC.LHsType GHC.RdrName)
addOneType et t = do
hst <- typeToLHsType t
ss1 <- uniqueSrcSpanT
hst1 <- case t of
(GHC.FunTy _ _) -> do
ss <- uniqueSrcSpanT
let t1 = GHC.L ss (GHC.HsParTy hst)
setEntryDPT hst (DP (0,0))
addSimpleAnnT t1 (DP (0,0)) [((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))]
return t1
_ -> return hst
let typ = GHC.L ss1 (GHC.HsFunTy hst1 et)
addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnRarrow),DP (0,1))]
return typ
addParamsToSigs np ls = error $ "addParamsToSigs: no match for:" ++ showGhc (np,ls)
printSigComponent :: GHC.Type -> String
printSigComponent x = ppType x
isNewSignatureOk :: [GHC.Type] -> RefactGhc Bool
isNewSignatureOk types = do
let
r = SYB.everythingStaged SYB.TypeChecker (++) []
([] `SYB.mkQ` usesForAll) types
usesForAll (GHC.ForAllTy _ _) = [1::Int]
usesForAll _ = []
return $ emptyList r
typeToLHsType :: GHC.Type -> Transform (GHC.LHsType GHC.RdrName)
typeToLHsType (GHC.TyVarTy v) = do
ss <- uniqueSrcSpanT
let typ = GHC.L ss (GHC.HsTyVar (GHC.nameRdrName $ Var.varName v))
addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]
return typ
typeToLHsType (GHC.AppTy t1 t2) = do
t1' <- typeToLHsType t1
t2' <- typeToLHsType t2
ss <- uniqueSrcSpanT
return $ GHC.L ss (GHC.HsAppTy t1' t2')
typeToLHsType t@(GHC.TyConApp _tc _ts) = tyConAppToHsType t
typeToLHsType (GHC.FunTy t1 t2) = do
t1' <- typeToLHsType t1
t2' <- typeToLHsType t2
ss <- uniqueSrcSpanT
let typ = GHC.L ss (GHC.HsFunTy t1' t2')
addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnRarrow),DP (0,1))]
return typ
typeToLHsType (GHC.ForAllTy _v t) = do
t' <- typeToLHsType t
ss1 <- uniqueSrcSpanT
ss2 <- uniqueSrcSpanT
return $ GHC.L ss1 (GHC.HsForAllTy GHC.Explicit Nothing (GHC.HsQTvs [] []) (GHC.L ss2 []) t')
typeToLHsType (GHC.LitTy (GHC.NumTyLit i)) = do
ss <- uniqueSrcSpanT
let typ = GHC.L ss (GHC.HsTyLit (GHC.HsNumTy (show i) i)) :: GHC.LHsType GHC.RdrName
addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]
return typ
typeToLHsType (GHC.LitTy (GHC.StrTyLit s)) = do
ss <- uniqueSrcSpanT
let typ = GHC.L ss (GHC.HsTyLit (GHC.HsStrTy "" s)) :: GHC.LHsType GHC.RdrName
addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]
return typ
tyConAppToHsType :: GHC.Type -> Transform (GHC.LHsType GHC.RdrName)
tyConAppToHsType (GHC.TyConApp tc _ts) = r (show $ GHC.tyConName tc)
where
r str = do
ss <- uniqueSrcSpanT
let typ = GHC.L ss (GHC.HsTyLit (GHC.HsStrTy str $ GHC.mkFastString str)) :: GHC.LHsType GHC.RdrName
addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,1))]
return typ
demote' ::
GHC.ModuleName
-> GHC.Located GHC.Name
-> RefactGhc [ApplyRefacResult]
demote' modName (GHC.L _ pn) = do
renamed <- getRefactRenamed
targetModule <- getRefactTargetModule
if isFunOrPatName pn renamed
then do
isTl <- isTopLevelPN pn
if isTl && isExplicitlyExported pn renamed
then error "This definition can not be demoted, as it is explicitly exported by the current module!"
else do
(refactoredMod,declaredPns) <- applyRefac (doDemoting pn) RSAlreadyLoaded
if isTl && modIsExported modName renamed
then do
logm $ "demote':isTl && isExported"
clients <- clientModsAndFiles targetModule
logm $ "demote':clients=" ++ (showGhc clients)
refactoredClients <-mapM (demotingInClientMod declaredPns) clients
return (refactoredMod:refactoredClients)
else do return [refactoredMod]
else error "\nInvalid cursor position!"
demotingInClientMod ::
[GHC.Name] -> TargetModule
-> RefactGhc ApplyRefacResult
demotingInClientMod pns targetModule = do
logm $ "demotingInClientMod:(pns,targetModule)=" ++ showGhc (pns,targetModule)
getTargetGhc targetModule
modu <- getRefactModule
(refactoredMod,_) <- applyRefac (doDemotingInClientMod pns modu) RSAlreadyLoaded
return refactoredMod
doDemotingInClientMod :: [GHC.Name] -> GHC.Module -> RefactGhc ()
doDemotingInClientMod pns modName = do
logm $ "doDemotingInClientMod:(pns,modName)=" ++ showGhc (pns,modName)
renamed@(_g,imps,exps,_docs) <- getRefactRenamed
if any (\pn->findPN pn (hsBinds renamed) || findPN pn (exps)) pns
then error $ "This definition can not be demoted, as it is used in the client module '"++(showGhc modName)++"'!"
else if any (\pn->findPN pn imps) pns
then do
return ()
else return ()
doDemoting :: GHC.Name -> RefactGhc [GHC.Name]
doDemoting pn = do
clearRefactDone
parsed <- getRefactParsed
parsed' <- everywhereMStaged' SYB.Parser (SYB.mkM demoteInMod
`SYB.extM` demoteInMatch
`SYB.extM` demoteInPat
`SYB.extM` demoteInLet
`SYB.extM` demoteInStmt
) parsed
putRefactParsed parsed' emptyAnns
nm <- getRefactNameMap
decls <- liftT $ hsDecls parsed
let demotedDecls'= definingDeclsRdrNames nm [pn] decls True False
declaredPnsRdr = nub $ concatMap definedPNsRdr demotedDecls'
declaredPns = map (rdrName2NamePure nm) declaredPnsRdr
return declaredPns
where
demoteInMod x@(parsed :: GHC.ParsedSource) = do
decls <- liftT $ hsDecls parsed
nm <- getRefactNameMap
if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False)
then do
logm "MoveDef:demoteInMod"
demoted <- doDemoting' parsed pn
return demoted
else return x
demoteInMatch match@(GHC.L _ (GHC.Match _ _pats _mt (GHC.GRHSs _ _ds))::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do
decls <- liftT $ hsDecls match
nm <- getRefactNameMap
if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False)
then do
logm "MoveDef:demoteInMatch"
done <- getRefactDone
match' <- if (not done)
then doDemoting' match pn
else return match
return match'
else return match
demoteInPat x@(pat@(GHC.L _ (GHC.ValD (GHC.PatBind _p (GHC.GRHSs _grhs _lb) _ _ _)))::GHC.LHsDecl GHC.RdrName) = do
decls <- liftT $ hsDeclsPatBindD x
nm <- getRefactNameMap
if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False)
then do
logm "MoveDef:demoteInPat"
done <- getRefactDone
pat' <- if (not done)
then doDemoting' pat pn
else return pat
return pat'
else return x
demoteInPat x = return x
demoteInLet x@(letExp@(GHC.L _ (GHC.HsLet _ds _e))::GHC.LHsExpr GHC.RdrName) = do
decls <- liftT $ hsDecls x
nm <- getRefactNameMap
if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False)
then do
logm "MoveDef:demoteInLet"
done <- getRefactDone
letExp' <- if (not done)
then doDemoting' letExp pn
else return letExp
return letExp'
else return x
demoteInLet x = return x
demoteInStmt (letStmt@(GHC.L _ (GHC.LetStmt _binds))::GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do
decls <- liftT $ hsDecls letStmt
nm <- getRefactNameMap
if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False)
then do
logm "MoveDef:demoteInStmt"
done <- getRefactDone
letStmt' <- if (not done)
then doDemoting' letStmt pn
else return letStmt
return letStmt'
else return letStmt
demoteInStmt x = return x
doDemoting' :: (UsedByRhs t) => t -> GHC.Name -> RefactGhc t
doDemoting' t pn = do
nm <- getRefactNameMap
origDecls <- liftT $ hsDeclsGeneric t
let
demotedDecls'= definingDeclsRdrNames nm [pn] origDecls True False
declaredPns = nub $ concatMap (definedNamesRdr nm) demotedDecls'
pnsUsed = usedByRhsRdr nm t declaredPns
logm $ "doDemoting':(pn,declaredPns)=" ++ showGhc (pn,declaredPns)
logm $ "doDemoting':(declaredPns,pnsUsed)=" ++ showGhc (declaredPns,pnsUsed)
r <- if not pnsUsed
then do
logm $ "doDemoting' no pnsUsed"
let dt = origDecls
let demotedDecls = definingDeclsRdrNames nm [pn] dt True True
otherBinds = (deleteFirstsBy (sameBindRdr nm) dt demotedDecls)
xx = map (\b -> (b,uses nm declaredPns [b])) otherBinds
useCount = sum $ concatMap snd xx
logm $ "doDemoting': declaredPns=" ++ (showGhc declaredPns)
logm $ "doDemoting': uses xx=" ++ (showGhc xx)
logm $ "doDemoting': uses useCount=" ++ (show useCount)
case useCount of
0 ->do error "\n Nowhere to demote this function!\n"
1 ->
do
logm "MoveDef.doDemoting':target location found"
let (FN f,_d) = hsFreeAndDeclaredRdr nm demotedDecls
(ds,removedDecl,_sigRemoved) <- rmDecl pn False t
(t',demotedSigs) <- rmTypeSigs declaredPns ds
logDataWithAnns "MoveDef.doDemoting':after rmTypeSigs:demotedSigs=" demotedSigs
logm $ "MoveDef:declaredPns=" ++ (showGhc declaredPns)
dl <- mapM (flip declaredNamesInTargetPlace ds) declaredPns
logm $ "mapM declaredNamesInTargetPlace done"
let clashedNames=filter (\x-> elem (id x) (map id f)) $ (nub.concat) dl
if clashedNames/=[]
then error ("The identifier(s):" ++ showGhc clashedNames ++
", declared in where the definition will be demoted to, will cause name clash/capture"
++" after demoting, please do renaming first!")
else
do
duplicateDecls declaredPns removedDecl demotedSigs t'
_ ->error "\nThis function/pattern binding is used by more than one friend bindings\n"
else error "This function can not be demoted as it is used in current level!\n"
return r
where
uses :: NameMap -> [GHC.Name] -> [GHC.LHsDecl GHC.RdrName] -> [Int]
uses nm pns t2
= concatMap used t2
where
used :: GHC.LHsDecl GHC.RdrName -> [Int]
used (GHC.L _ (GHC.ValD (GHC.FunBind _n _ (GHC.MG matches _ _ _) _ _ _)))
= concatMap (usedInMatch pns) matches
used (GHC.L _ (GHC.ValD (GHC.PatBind pat rhs _ _ _)))
| (not $ findNamesRdr nm pns pat) && findNamesRdr nm pns rhs
= [1::Int]
used _ = []
usedInMatch pns' (GHC.L _ (GHC.Match _ pats _ rhs))
| (not $ findNamesRdr nm pns' pats) && findNamesRdr nm pns' rhs
= [1::Int]
usedInMatch _ _ = []
duplicateDecls :: (SYB.Data t,SYB.Typeable t)
=> [GHC.Name]
-> GHC.LHsDecl GHC.RdrName
-> [GHC.LSig GHC.RdrName]
-> t
-> RefactGhc t
duplicateDecls pns demoted dsig o = do
logm $ "duplicateDecls:t=" ++ SYB.showData SYB.Parser 0 o
hasDeclsSybTransform workerHsDecls workerBind o
where
workerHsDecls :: forall t. HasDecls t => t -> RefactGhc t
workerHsDecls t' = do
dds <- liftT $ hsDecls t'
ds'' <- duplicateDecls' pns demoted dsig dds
liftT $ replaceDecls t' ds''
workerBind :: (GHC.LHsBind GHC.RdrName -> RefactGhc (GHC.LHsBind GHC.RdrName))
workerBind t'@(GHC.L _ (GHC.PatBind{})) = do
dds <- liftT $ hsDeclsPatBind t'
ds'' <- duplicateDecls' pns demoted dsig dds
liftT $ replaceDeclsPatBind t' ds''
workerBind x = error $ "MoveDef.duplicateDecls.workerBind:unmatched LHsBind:" ++ showGhc x
duplicateDecls' :: [GHC.Name]
-> GHC.LHsDecl GHC.RdrName
-> [GHC.LSig GHC.RdrName]
-> [GHC.LHsDecl GHC.RdrName]
-> RefactGhc [GHC.LHsDecl GHC.RdrName]
duplicateDecls' pns demoted dsig decls
= do
nm <- getRefactNameMap
everywhereMStaged' SYB.Parser (SYB.mkM (dupInMatch nm)
`SYB.extM` (dupInPat nm)) decls
where
dupInMatch nm (match@(GHC.L _ (GHC.Match _ pats _mt rhs)) :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))
| (not $ findNamesRdr nm pns pats) && findNamesRdr nm pns rhs
= do
done <- getRefactDone
logm $ "duplicateDecls.dupInMatch:value of done=" ++ (show done)
if done
then return match
else do
logm "duplicateDecls:setting done"
setRefactDone
match' <- foldParams pns match decls demoted dsig
return match'
dupInMatch _ x = return x
dupInPat nm ((GHC.PatBind pat rhs@(GHC.GRHSs grhs lb) ty fvs ticks) :: GHC.HsBind GHC.RdrName)
| (not $ findNamesRdr nm pns pat) && findNamesRdr nm pns rhs
= do
logm $ "duplicateDecls.dupInPat"
let declsToLift = definingDeclsRdrNames' nm pns t
lb' <- moveDecl1 lb Nothing pns declsToLift pns []
return (GHC.PatBind pat (GHC.GRHSs grhs lb') ty fvs ticks)
dupInPat _ x = return x
declaredNamesInTargetPlace :: (SYB.Data t)
=> GHC.Name -> t
-> RefactGhc [GHC.Name]
declaredNamesInTargetPlace pn' t' = do
logm $ "declaredNamesInTargetPlace:pn=" ++ (showGhc pn')
res <- applyTU (stop_tdTU (failTU
`adhocTU` inMatch
`adhocTU` inPat)) t'
logm $ "declaredNamesInTargetPlace:res=" ++ (showGhc res)
return res
where
inMatch ((GHC.Match _ _pats _ rhs) :: GHC.Match GHC.Name (GHC.LHsExpr GHC.Name))
| findPN pn' rhs = do
logm $ "declaredNamesInTargetPlace:inMatch"
fds <- hsFDsFromInside rhs
return $ snd fds
inMatch _ = return mzero
inPat ((GHC.PatBind pat rhs _ _ _) :: GHC.HsBind GHC.Name)
|findPN pn' rhs = do
logm $ "declaredNamesInTargetPlace:inPat"
fds <- hsFDsFromInside pat
return $ snd fds
inPat _= return mzero
foldParams :: [GHC.Name]
-> GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)
-> [GHC.LHsDecl GHC.RdrName]
-> GHC.LHsDecl GHC.RdrName
-> [GHC.LSig GHC.RdrName]
-> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))
foldParams pns match@(GHC.L l (GHC.Match _mfn _pats _mt rhs)) _decls demotedDecls dsig
=do
logm $ "MoveDef.foldParams entered"
nm <- getRefactNameMap
let matches = concatMap matchesInDecls [demotedDecls]
pn = ghead "foldParams" pns
logm $ "MoveDef.foldParams before allParams"
params <- allParams pn rhs []
logm $ "foldParams:params=" ++ showGhc params
if (length.nub.map length) params==1
&& ((length matches)==1)
then do
let patsInDemotedDecls=(patsInMatch.(ghead "foldParams")) matches
subst = mkSubst nm patsInDemotedDecls params
fstSubst = map fst subst
sndSubst = map snd subst
rhs' <- rmParamsInParent pn sndSubst rhs
let ls = map (hsFreeAndDeclaredRdr nm) sndSubst
let newNames = ((concatMap (fn . fst) ls)) \\ (fstSubst)
clashedNames <- getClashedNames nm fstSubst newNames (ghead "foldParams" matches)
logm $ "MoveDef.foldParams about to foldInDemotedDecls"
demotedDecls''' <- foldInDemotedDecls pns clashedNames subst [demotedDecls]
logm $ "MoveDef.foldParams foldInDemotedDecls done"
let match' = GHC.L l ((GHC.unLoc match) {GHC.m_grhss = rhs' })
match'' <- addDecl match' Nothing (demotedDecls''',Nothing)
logm $ "MoveDef.foldParams addDecl done 1"
return match''
else do
logm $ "foldParams:no params"
let sigs = map wrapSig dsig
match' <- addDecl match Nothing (sigs++[demotedDecls],Nothing)
logm "MoveDef.foldParams addDecl done 2"
return match'
where
matchesInDecls :: GHC.LHsDecl GHC.RdrName -> [GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)]
matchesInDecls (GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _))) = matches
matchesInDecls _x = []
patsInMatch (GHC.L _ (GHC.Match _ pats' _ _)) = pats'
foldInDemotedDecls :: [GHC.Name]
-> [GHC.Name]
-> [(GHC.Name, GHC.HsExpr GHC.RdrName)]
-> [GHC.LHsDecl GHC.RdrName]
-> RefactGhc [GHC.LHsDecl GHC.RdrName]
foldInDemotedDecls pns' clashedNames subst decls = do
logm $ "foldInDemotedDecls:(pns',clashedNames,subst)=" ++ showGhc (pns',clashedNames,subst)
logm $ "foldInDemotedDecls:decls=" ++ SYB.showData SYB.Parser 0 decls
nm <- getRefactNameMap
SYB.everywhereMStaged SYB.Parser (SYB.mkM (worker nm) `SYB.extM` (workerBind nm)) decls
where
worker nm (match'@(GHC.L _ (GHC.FunBind ln _ (GHC.MG _matches _ _ _) _ _ _)) :: GHC.LHsBind GHC.RdrName)
= do
logm $ "foldInDemotedDecls:rdrName2NamePure nm ln=" ++ show (rdrName2NamePure nm ln)
if isJust (find (== rdrName2NamePure nm ln) pns')
then do
logm $ "foldInDemotedDecls:found match'"
match'' <- foldM (flip autoRenameLocalVar) match' clashedNames
match''' <- foldM replaceExpWithUpdToks match'' subst
rmParamsInDemotedDecls (map fst subst) match'''
else return match'
worker _ x = return x
workerBind nm ((GHC.L ll (GHC.ValD d)) :: GHC.LHsDecl GHC.RdrName)
= do
(GHC.L _ d') <- worker nm (GHC.L ll d)
return (GHC.L ll (GHC.ValD d'))
workerBind _ x = return x
allParams :: GHC.Name -> GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)
-> [[GHC.HsExpr GHC.RdrName]]
-> RefactGhc [[GHC.HsExpr GHC.RdrName]]
allParams pn rhs1 initial
=do
nm <- getRefactNameMap
let p = getOneParam nm pn rhs1
logm $ "allParams:p=" ++ showGhc p
if (nonEmptyList p)
then do rhs' <- rmOneParam pn rhs1
logDataWithAnns "allParams:rhs'=" rhs'
allParams pn rhs' (initial++[p])
else return initial
where
getOneParam :: (SYB.Data t) => NameMap -> GHC.Name -> t -> [GHC.HsExpr GHC.RdrName]
getOneParam nm pn1
= SYB.everythingStaged SYB.Renamer (++) []
([] `SYB.mkQ` worker)
where
worker :: GHC.HsExpr GHC.RdrName -> [GHC.HsExpr GHC.RdrName]
worker (GHC.HsApp e1 e2)
|(expToNameRdr nm e1 == Just pn1) = [GHC.unLoc e2]
worker _ = []
rmOneParam :: (SYB.Data t) => GHC.Name -> t -> RefactGhc t
rmOneParam pn1 t
= do
nm <- getRefactNameMap
everywhereMStaged' SYB.Parser (SYB.mkM (worker nm)) t
where
worker nm (GHC.L _ (GHC.HsApp e1 _e2 ))
|expToNameRdr nm e1 == Just pn1 = return e1
worker _ x = return x
rmParamsInDemotedDecls :: [GHC.Name] -> GHC.LHsBind GHC.RdrName
-> RefactGhc (GHC.LHsBind GHC.RdrName)
rmParamsInDemotedDecls ps bind
= SYB.everywhereMStaged SYB.Parser (SYB.mkM worker) bind
where worker :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName))
worker (GHC.Match mfn' pats2 typ rhs1)
= do
nm <- getRefactNameMap
let pats'=filter (\x->not ((patToNameRdr nm x /= Nothing) &&
elem (gfromJust "rmParamsInDemotedDecls" $ patToNameRdr nm x) ps)) pats2
return (GHC.Match mfn' pats' typ rhs1)
rmParamsInParent :: GHC.Name -> [GHC.HsExpr GHC.RdrName]
-> GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)
-> RefactGhc (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName))
rmParamsInParent pn es grhss = do
nm <- getRefactNameMap
SYB.everywhereMStaged SYB.Renamer (SYB.mkM (worker nm)) grhss
where worker nm expr@(GHC.L _ (GHC.HsApp e1 e2))
| findNamesRdr nm [pn] e1 && (elem (showGhc (GHC.unLoc e2)) (map (showGhc) es))
= do
liftT $ transferEntryDPT expr e1
return e1
worker nm (expr@(GHC.L _ (GHC.HsPar e1)))
|Just pn==expToNameRdr nm e1
= do
liftT $ transferEntryDPT expr e1
return e1
worker _ x =return x
getClashedNames :: NameMap -> [GHC.Name] -> [GHC.Name]
-> GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)
-> RefactGhc [GHC.Name]
getClashedNames nm oldNames newNames match'
= do (_f,DN d) <- hsFDsFromInsideRdr nm match'
ds' <- mapM (flip (hsVisiblePNsRdr nm) match') oldNames
return (filter (\x->elem ( x) newNames)
( nub (d `union` (nub.concat) ds')))
mkSubst :: NameMap
-> [GHC.LPat GHC.RdrName] -> [[GHC.HsExpr GHC.RdrName]]
-> [(GHC.Name,GHC.HsExpr GHC.RdrName)]
mkSubst nm pats1 params
= catMaybes (zipWith (\x y -> if (patToNameRdr nm x/=Nothing) && (length (nub $ map showGhc y)==1)
then Just (gfromJust "mkSubst" $ patToNameRdr nm x,(ghead "mkSubst") y)
else Nothing) pats1 params)
replaceExpWithUpdToks :: (SYB.Data t)
=> t -> (GHC.Name, GHC.HsExpr GHC.RdrName)
-> RefactGhc t
replaceExpWithUpdToks decls subst = do
nm <- getRefactNameMap
let
worker (e@(GHC.L l _)::GHC.LHsExpr GHC.RdrName)
|(expToNameRdr nm e) == Just (fst subst)
= update e (GHC.L l (snd subst)) e
worker x=return x
everywhereMStaged' SYB.Parser (SYB.mkM worker) decls
isLocalFunOrPatName :: SYB.Data t => GHC.Name -> t -> Bool
isLocalFunOrPatName pn scope
= isLocalPN pn && isFunOrPatName pn scope