module Language.Haskell.Refact.MoveDef
( liftToTopLevel
, liftOneLevel
, demote
) where
import qualified Data.Generics as SYB
import qualified GHC.SYB.Utils as SYB
import qualified Exception as GHC
import qualified GHC
import qualified Name as GHC
import Control.Exception
import Control.Monad.State
import qualified Data.Generics.Zipper as Z
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.TokenUtils
import Language.Haskell.Refact.Utils.TypeSyn
import Language.Haskell.Refact.Utils.TypeUtils
import Data.Generics.Strafunski.StrategyLib.StrategyLib
liftToTopLevel :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath]
liftToTopLevel settings cradle fileName (row,col) =
runRefacSession settings cradle (compLiftToTopLevel fileName (row,col))
compLiftToTopLevel :: FilePath -> SimpPos
-> RefactGhc [ApplyRefacResult]
compLiftToTopLevel fileName (row,col) = do
getModuleGhc fileName
renamed <- getRefactRenamed
parsed <- getRefactParsed
let (Just (modName,_)) = getModuleName parsed
let maybePn = locToName (row, col) renamed
case maybePn of
Just pn -> do
liftToTopLevel' modName pn
_ -> error "\nInvalid cursor position!\n"
liftOneLevel :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath]
liftOneLevel settings cradle fileName (row,col) =
runRefacSession settings cradle (compLiftOneLevel fileName (row,col))
compLiftOneLevel :: FilePath -> SimpPos
-> RefactGhc [ApplyRefacResult]
compLiftOneLevel fileName (row,col) = do
getModuleGhc fileName
renamed <- getRefactRenamed
parsed <- getRefactParsed
logm $ "compLiftOneLevel:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed)
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"
demote :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath]
demote settings cradle fileName (row,col) =
runRefacSession settings cradle (compDemote fileName (row,col))
compDemote ::FilePath -> SimpPos
-> RefactGhc [ApplyRefacResult]
compDemote fileName (row,col) = do
getModuleGhc fileName
renamed <- getRefactRenamed
parsed <- getRefactParsed
let (Just (modName,_)) = getModuleName parsed
let maybePn = locToName (row, col) renamed
case maybePn of
Just pn -> do
demote' 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
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 modName
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
let declsr = hsBinds renamed
let (before,parent,after) = divideDecls declsr pn
let liftedDecls = definingDeclsNames [n] parent True True
declaredPns = nub $ concatMap definedPNs liftedDecls
logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns))
pns <- pnsNeedRenaming renamed parent liftedDecls declaredPns
let dd = getDeclaredVars $ hsBinds renamed
logm $ "liftToMod:(ddd)=" ++ (showGhc dd)
drawTokenTree "liftToMod.a"
if pns==[]
then do (parent',liftedDecls',paramAdded)<-addParamsToParentAndLiftedDecl n dd parent liftedDecls
let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls'
else liftedDecls'
drawTokenTree "liftToMod.c"
logm $ "liftToMod:(declaredPns)=" ++ (showGhc declaredPns)
mod' <- moveDecl1 (replaceBinds renamed (before++parent'++after))
(Just (ghead "liftToMod" (definedPNs (ghead "liftToMod2" parent'))))
[GHC.unLoc pn] declaredPns True
drawTokenTree "liftToMod.b"
return declaredPns
else askRenamingMsg pns "lifting"
moveDecl1 :: (HsValBinds t)
=> t
-> Maybe GHC.Name
-> [GHC.Name]
-> [GHC.Name]
-> Bool
-> RefactGhc t
moveDecl1 t defName ns sigNames topLevel
= do
let n = ghead "moveDecl1" ns
let funBinding = definingDeclsNames' [n] t
logm $ "moveDecl1: (ns,funBinding)=" ++ (showGhc (ns,funBinding))
let Just sspan = getSrcSpan funBinding
funToks <- getToksForSpan sspan
logm $ "moveDecl1:funToks=" ++ (showToks funToks)
drawTokenTree "moveDecl1:after getting toks"
(t'',sigsRemoved) <- rmTypeSigs sigNames t
drawTokenTreeDetailed "moveDecl1:after rmTypeSigs"
(t',_declRemoved,_sigRemoved) <- rmDecl (ghead "moveDecl3.1" ns) False t''
drawTokenTreeDetailed "moveDecl1:after rmDecl"
let getToksForMaybeSig (GHC.L ss _) =
do
sigToks <- getToksForSpan ss
return sigToks
maybeToksSigMulti <- mapM getToksForMaybeSig
$ sortBy (\(GHC.L s1 _) (GHC.L s2 _) -> compare (srcSpanToForestSpan s1) (srcSpanToForestSpan s2))
sigsRemoved
let maybeToksSig = concat maybeToksSigMulti
logm $ "moveDecl1:maybeToksSig=" ++ (show maybeToksSig)
logm $ "moveDecl1:(defName,topLevel)" ++ (showGhc (defName,topLevel))
addDecl t' defName (ghead "moveDecl1 2" funBinding,sigsRemoved,Just (maybeToksSig ++ funToks)) topLevel
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) =>
t1 -> [GHC.LHsBind GHC.Name] -> t2 -> [GHC.Name]
-> RefactGhc [GHC.Name]
pnsNeedRenaming dest parent _liftedDecls pns
=do
r <- mapM pnsNeedRenaming' pns
return (concat r)
where
pnsNeedRenaming' pn
= do
let (f,d) = hsFDsFromInside dest
let vs = hsVisiblePNs pn parent
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 :: (HsValBinds t) => GHC.Name -> [GHC.Name] -> t -> RefactGhc t
addParamsToParent _pn [] t = return t
addParamsToParent pn params t = do
logm $ "addParamsToParent:(pn,params)" ++ (showGhc (pn,params))
t' <- addActualParamsToRhs True pn params t
return t'
liftingInClientMod :: GHC.ModuleName -> [GHC.Name] -> GHC.ModSummary
-> RefactGhc [ApplyRefacResult]
liftingInClientMod serverModName pns modSummary = do
getModuleDetails modSummary
renamed <- getRefactRenamed
let clientModule = GHC.ms_mod modSummary
logm $ "liftingInClientMod:clientModule=" ++ (showGhc clientModule)
modNames <- willBeUnQualImportedBy serverModName
logm $ "liftingInClientMod:modNames=" ++ (showGhc modNames)
if isJust modNames
then do
pns' <- namesNeedToBeHided clientModule (fromJust modNames) pns
logm $ "liftingInClientMod:pns'=" ++ (showGhc pns')
if (nonEmptyList pns')
then do (refactoredMod,_) <- applyRefac (addHiding serverModName renamed pns') 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)) (fromJust exps))) names
where simpModule (GHC.L _ (GHC.IEModuleContents 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 []
liftOneLevel' :: GHC.ModuleName
-> GHC.Located GHC.Name
-> RefactGhc [ApplyRefacResult]
liftOneLevel' modName pn@(GHC.L _ n) = do
renamed <- getRefactRenamed
if isLocalFunOrPatName n renamed
then do
(refactoredMod,_) <- applyRefac (liftOneLevel'') RSAlreadyLoaded
let (b, pns) = liftedToTopLevel pn renamed
if b && modIsExported modName renamed
then do clients<-clientModsAndFiles modName
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
liftOneLevel''= do
logm $ "in liftOneLevel''"
renamed <- getRefactRenamed
ztransformStagedM SYB.Renamer (Nothing
`SYB.mkQ` liftToModQ
`SYB.extQ` liftToMatchQ'
`SYB.extQ` liftToLet'
) (Z.toZipper renamed)
where
isValBinds :: GHC.HsValBinds GHC.Name -> Bool
isValBinds _ = True
isGRHSs :: GHC.GRHSs GHC.Name -> Bool
isGRHSs _ = True
isHsLet :: GHC.HsExpr GHC.Name -> Bool
isHsLet (GHC.HsLet _ _) = True
isHsLet _ = False
liftToModQ ((g,_imps,_exps,_docs):: GHC.RenamedSource)
| nonEmptyList candidateBinds
= Just (doLiftZ candidateBinds)
| otherwise = Nothing
where
candidateBinds = map snd
$ filter (\(l,_bs) -> nonEmptyList l)
$ map (\bs -> (definingDeclsNames [n] (hsBinds bs) False False,bs))
$ (hsBinds g)
liftToMatchQ' :: (SYB.Data a) => GHC.Match GHC.Name -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a))
liftToMatchQ' ((GHC.Match _pats _mtyp (GHC.GRHSs rhs ds))::GHC.Match GHC.Name)
| (nonEmptyList (definingDeclsNames [n] (hsBinds ds) False False))
= Just (doLiftZ ds)
| (nonEmptyList (definingDeclsNames [n] (hsBinds rhs) False False))
= Just (doLiftZ rhs)
| otherwise = Nothing
liftToLet' :: GHC.HsExpr GHC.Name -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a))
liftToLet' ((GHC.HsLet ds _e)::GHC.HsExpr GHC.Name)
| nonEmptyList (definingDeclsNames [n] (hsBinds ds) False False)
= Just (doLiftZ ds)
| otherwise = Nothing
liftToLet' _ = Nothing
doLiftZ :: (HsValBinds t)
=> t -> SYB.Stage -> Z.Zipper a
-> RefactGhc (Z.Zipper a)
doLiftZ ds _stage z =
do
logm $ "in liftOneLevel''.liftToLet in ds"
let zu = case (Z.up z) of
Just zz -> fromMaybe (error "MoveDef.liftToLet.1")
$ upUntil (False `SYB.mkQ` isGRHSs
`SYB.extQ` isHsLet
`SYB.extQ` isValBinds)
zz
Nothing -> z
let
wtop (ren::GHC.RenamedSource) = do
worker ren (hsBinds ds) pn True
wgrhs (grhss::GHC.GRHSs GHC.Name) = do
let (_,dd) = (hsFreeAndDeclaredPNs grhss)
worker1 grhss (hsBinds ds) pn dd False
wlet :: GHC.HsExpr GHC.Name -> RefactGhc (GHC.HsExpr GHC.Name)
wlet l@(GHC.HsLet dsl _e) = do
let (_,dd) = hsFreeAndDeclaredPNs dsl
dsl' <- worker1 l (hsBinds ds) pn dd False
return dsl'
wvalbinds (vb::GHC.HsValBinds GHC.Name) = do
let (_,dd) = (hsFreeAndDeclaredPNs vb)
worker1 vb (hsBinds ds) pn dd False
ds' <- Z.transM (SYB.mkM wtop `SYB.extM` wgrhs
`SYB.extM` wlet `SYB.extM` wvalbinds) zu
return ds'
worker :: (HsValBinds t)
=> t
-> [GHC.LHsBind GHC.Name]
-> GHC.Located GHC.Name
-> Bool
-> RefactGhc t
worker dest ds pnn toToplevel
=do let (before,parent,after)=divideDecls ds pnn
liftedDecls=definingDeclsNames [n] parent True True
declaredPns=nub $ concatMap definedPNs liftedDecls
logm $ "MoveDef.worker: (dest)=" ++ (SYB.showData SYB.Renamer 0 dest)
logm $ "MoveDef.worker: (ds)=" ++ (showGhc (ds))
logm $ "MoveDef.worker: parent=" ++ (showGhc parent)
let (_, dd) = hsFreeAndDeclaredPNs dest
pns<-pnsNeedRenaming dest parent liftedDecls declaredPns
logm $ "MoveDef.worker: pns=" ++ (showGhc pns)
if pns==[]
then do
(parent',liftedDecls',paramAdded)<-addParamsToParentAndLiftedDecl n dd
parent liftedDecls
let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls'
else liftedDecls'
dest'<-moveDecl1 (replaceBinds dest (before++parent'++after))
(Just (ghead "worker" (definedPNs (ghead "worker" parent'))))
[n] declaredPns toToplevel
return dest'
else askRenamingMsg pns "lifting"
worker1 :: (HsValBinds t)
=> t
-> [GHC.LHsBind GHC.Name]
-> GHC.Located GHC.Name
-> [GHC.Name]
-> Bool
-> RefactGhc t
worker1 dest ds pnn dd toToplevel
=do let (_before,decl,_after)=divideDecls ds pnn
liftedDecls=definingDeclsNames [n] decl True True
declaredPns=nub $ concatMap definedPNs liftedDecls
logm $ "MoveDef.worker1: (dest)=" ++ (SYB.showData SYB.Renamer 0 dest)
logm $ "MoveDef.worker1: (ds)=" ++ (showGhc (ds))
logm $ "MoveDef.worker1: decl=" ++ (showGhc decl)
pns <- pnsNeedRenaming dest decl liftedDecls declaredPns
logm $ "MoveDef.worker1: pns=" ++ (showGhc pns)
if pns==[]
then do
(dest',liftedDecls',paramAdded)
<- addParamsToParentAndLiftedDecl n dd dest liftedDecls
let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls'
else liftedDecls'
logm $ "MoveDef.worker1:dest'=" ++ (SYB.showData SYB.Renamer 0 dest')
dest'<-moveDecl1 dest' Nothing
[n] declaredPns toToplevel
return dest'
else askRenamingMsg pns "lifting"
liftedToTopLevel :: GHC.Located GHC.Name -> GHC.RenamedSource -> (Bool,[GHC.Name])
liftedToTopLevel pnt@(GHC.L _ pn) renamed
= if nonEmptyList (definingDeclsNames [pn] (hsBinds renamed) False True)
then let (_, parent,_) = divideDecls (hsBinds renamed) pnt
liftedDecls=definingDeclsNames [pn] (hsBinds parent) True True
declaredPns = nub $ concatMap definedPNs liftedDecls
in (True, declaredPns)
else (False, [])
addParamsToParentAndLiftedDecl :: HsValBinds t =>
GHC.Name
-> [GHC.Name]
-> t
-> [GHC.LHsBind GHC.Name]
-> RefactGhc (t, [GHC.LHsBind GHC.Name], Bool)
addParamsToParentAndLiftedDecl pn dd parent liftedDecls
=do let (ef,_) = hsFreeAndDeclaredPNs parent
let (lf,_) = hsFreeAndDeclaredPNs liftedDecls
let eff = getFreeVars $ hsBinds parent
let lff = getFreeVars liftedDecls
logm $ "addParamsToParentAndLiftedDecl:(eff,lff)=" ++ (showGhc (eff,lff))
let newParams=((nub lff)\\ (nub eff)) \\ dd
logm $ "addParamsToParentAndLiftedDecl:(newParams,ef,lf,dd)=" ++ (showGhc (newParams,ef,lf,dd))
if newParams/=[]
then if (any isComplexPatBind liftedDecls)
then error "This pattern binding cannot be lifted, as it uses some other local bindings!"
else do parent' <- addParamsToParent pn newParams parent
liftedDecls'<-addParamsToDecls liftedDecls pn newParams True
return (parent', liftedDecls',True)
else return (parent,liftedDecls,False)
demote' ::
GHC.ModuleName
-> GHC.Located GHC.Name
-> RefactGhc [ApplyRefacResult]
demote' modName (GHC.L _ pn) = do
renamed <- getRefactRenamed
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,_) <- applyRefac (doDemoting pn) RSAlreadyLoaded
if isTl && modIsExported modName renamed
then do let demotedDecls'= definingDeclsNames [pn] (hsBinds renamed) True False
declaredPns = nub $ concatMap definedPNs demotedDecls'
clients <- clientModsAndFiles modName
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] -> GHC.ModSummary
-> RefactGhc ApplyRefacResult
demotingInClientMod pns modSummary = do
getModuleDetails modSummary
(refactoredMod,_) <- applyRefac (doDemotingInClientMod pns (GHC.ms_mod modSummary)) RSAlreadyLoaded
return refactoredMod
doDemotingInClientMod :: [GHC.Name] -> GHC.Module -> RefactGhc ()
doDemotingInClientMod pns modName = do
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 ()
doDemoting pn = do
clearRefactDone
renamed <- getRefactRenamed
logm $ "MoveDef.doDemoting:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed)
renamed' <- everywhereMStaged' SYB.Renamer (SYB.mkM demoteInMod
`SYB.extM` demoteInMatch
`SYB.extM` demoteInPat
`SYB.extM` demoteInLet
`SYB.extM` demoteInStmt
) renamed
putRefactRenamed renamed'
return ()
where
demoteInMod (renamed :: GHC.RenamedSource)
| not $ emptyList decls
= do
logm "MoveDef:demoteInMod"
demoted <- doDemoting' renamed pn
return demoted
where
decls = (definingDeclsNames [pn] (hsBinds renamed) False False)
demoteInMod x = return x
demoteInMatch (match@(GHC.Match _pats _mt rhs)::GHC.Match GHC.Name)
| not $ emptyList (definingDeclsNames [pn] (hsBinds rhs) False False)
= do
logm "MoveDef:demoteInMatch"
done <- getRefactDone
match' <- if (not done)
then doDemoting' match pn
else return match
return match'
demoteInMatch x = return x
demoteInPat (pat@((GHC.PatBind _p rhs _ _ _))::GHC.HsBind GHC.Name)
| not $ emptyList (definingDeclsNames [pn] (hsBinds rhs) False False)
= do
logm "MoveDef:demoteInPat"
done <- getRefactDone
pat' <- if (not done)
then doDemoting' pat pn
else return pat
return pat'
demoteInPat x = return x
demoteInLet (letExp@(GHC.HsLet ds _e)::GHC.HsExpr GHC.Name)
| not $ emptyList (definingDeclsNames [pn] (hsBinds ds) False False)
= do
logm "MoveDef:demoteInLet"
done <- getRefactDone
letExp' <- if (not done)
then doDemoting' letExp pn
else return letExp
return letExp'
demoteInLet x = return x
demoteInStmt (letStmt@(GHC.LetStmt binds)::GHC.Stmt GHC.Name)
| not $ emptyList (definingDeclsNames [pn] (hsBinds binds) False False)
= do
logm "MoveDef:demoteInStmt"
done <- getRefactDone
letStmt' <- if (not done)
then doDemoting' letStmt pn
else return letStmt
return letStmt'
demoteInStmt x =return x
doDemoting' :: (HsValBinds t, UsedByRhs t) => t -> GHC.Name -> RefactGhc t
doDemoting' t pn
= let origDecls = hsBinds t
demotedDecls'= definingDeclsNames [pn] origDecls True False
declaredPns = nub $ concatMap definedPNs demotedDecls'
in if not (usedByRhs t declaredPns)
then do
let demotedDecls = definingDeclsNames [pn] (hsBinds t) True True
let
otherBinds = (deleteFirstsBy sameBind (hsBinds t) demotedDecls)
xx = map (\b -> (b,uses declaredPns [b])) otherBinds
uselist = concatMap (\(b,r) -> if (emptyList r) then [] else [b]) xx
logm $ "doDemoting': uses xx=" ++ (showGhc xx)
logm $ "doDemoting': uses uselist=" ++ (showGhc uselist)
case length uselist of
0 ->do error "\n Nowhere to demote this function!\n"
1 ->
do
drawTokenTree ""
logm "MoveDef.doDemoting':target location found"
let (f,_d) = hsFreeAndDeclaredPNs demotedDecls
(ds,removedDecl,_sigRemoved) <- rmDecl pn False (hsBinds t)
(t',demotedSigs) <- rmTypeSigs declaredPns t
let (GHC.L ssd _) = removedDecl
demotedToks <- getToksForSpan ssd
let getToksForMaybeSig (GHC.L ss _) = do
sigToks <- getToksForSpan ss
return sigToks
demotedSigToksLists <- mapM getToksForMaybeSig demotedSigs
let demotedSigToks = concat demotedSigToksLists
logm $ "MoveDef:declaredPns=" ++ (showGhc declaredPns)
logm $ "MoveDef:demotedSigToks=" ++ (show demotedSigToks)
logm $ "MoveDef:sig and decl toks[" ++ (GHC.showRichTokenStream (demotedSigToks ++ demotedToks)) ++ "]"
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
logm $ "MoveDef: about to duplicateDecls"
ds'' <- duplicateDecls declaredPns removedDecl demotedSigs (Just (demotedSigToks ++ demotedToks)) ds
logm $ "MoveDef:duplicateDecls done"
return (replaceBinds t' ds'')
_ ->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"
where
uses pns t
= concat $ SYB.everythingStaged SYB.Renamer (++) []
([] `SYB.mkQ` usedInMatch
`SYB.extQ` usedInPat) t
where
usedInMatch ((GHC.Match pats _ rhs) :: GHC.Match GHC.Name)
| (not $ findPNs pns pats) && findPNs pns rhs
= return [1::Int]
usedInMatch _ = return []
usedInPat ((GHC.PatBind pat rhs _ _ _) :: GHC.HsBind GHC.Name)
| (not $ findPNs pns pat) && findPNs pns rhs
= return [1::Int]
usedInPat _ = return []
duplicateDecls :: [GHC.Name]
-> GHC.LHsBind GHC.Name
-> [GHC.LSig GHC.Name]
-> Maybe [PosToken]
-> [GHC.LHsBind GHC.Name]
-> RefactGhc [GHC.LHsBind GHC.Name]
duplicateDecls pns demoted dsig dtoks decls
= do
everywhereMStaged' SYB.Renamer (SYB.mkM dupInMatch
`SYB.extM` dupInPat) decls
where
dupInMatch (match@(GHC.Match pats _mt rhs) :: GHC.Match GHC.Name)
| (not $ findPNs pns pats) && findPNs pns rhs
= do
done <- getRefactDone
logm $ "duplicateDecls:value of done=" ++ (show done)
if done
then return match
else do
logm "duplicateDecls:setting done"
setRefactDone
match' <- foldParams pns match decls demoted dsig dtoks
return match'
dupInMatch x = return x
dupInPat ((GHC.PatBind pat rhs ty fvs ticks) :: GHC.HsBind GHC.Name)
| (not $ findPNs pns pat) && findPNs pns rhs
= do
rhs' <- moveDecl1 rhs Nothing pns pns False
return (GHC.PatBind pat rhs' 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_tdTUGhc (failTU
`adhocTU` inMatch
`adhocTU` inPat)) t
logm $ "declaredNamesInTargetPlace:res=" ++ (showGhc res)
return res
where
inMatch ((GHC.Match _pats _ rhs) :: GHC.Match GHC.Name)
| findPN pn rhs = do
logm $ "declaredNamesInTargetPlace:inMatch"
let 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"
let fds = hsFDsFromInside pat
return $ snd fds
inPat _= return mzero
foldParams :: [GHC.Name]
-> GHC.Match GHC.Name
-> [GHC.LHsBind GHC.Name]
-> GHC.LHsBind GHC.Name
-> [GHC.LSig GHC.Name]
-> Maybe [PosToken]
-> RefactGhc (GHC.Match GHC.Name)
foldParams pns ((GHC.Match pats mt rhs)::GHC.Match GHC.Name) _decls demotedDecls dsig dtoks
=do
logm $ "MoveDef.foldParams entered"
let matches=concatMap matchesInDecls [GHC.unLoc demotedDecls]
pn=ghead "foldParams" pns
params <- allParams pn rhs []
if (length.nub.map length) params==1
&& ((length matches)==1)
then do
let patsInDemotedDecls=(patsInMatch.(ghead "foldParams")) matches
subst=mkSubst patsInDemotedDecls params
fstSubst=map fst subst
sndSubst=map snd subst
rhs' <- rmParamsInParent pn sndSubst rhs
let ls = map hsFreeAndDeclaredPNs sndSubst
let newNames=((concatMap fst ls)) \\ (fstSubst)
clashedNames<-getClashedNames fstSubst newNames (ghead "foldParams" matches)
logm $ "MoveDef.foldParams about to foldInDemotedDecls"
demotedDecls''' <- foldInDemotedDecls pns clashedNames subst [demotedDecls]
logm $ "MoveDef.foldParams foldInDemotedDecls done"
let [(GHC.L declSpan _)] = demotedDecls'''
declToks <- getToksForSpan declSpan
logm $ "MoveDef.foldParams addDecl adding to (hsBinds):[" ++ (SYB.showData SYB.Renamer 0 $ hsBinds rhs') ++ "]"
rhs'' <- addDecl rhs' Nothing (ghead "foldParams 2" demotedDecls''',[],Just declToks) False
logm $ "MoveDef.foldParams addDecl done"
return (GHC.Match pats mt rhs'')
else do
logm $ "MoveDef.foldParams about to addDecl:dtoks=" ++ (show dtoks)
drawTokenTree ""
rhs' <- addDecl rhs Nothing (demotedDecls,dsig,dtoks) False
return (GHC.Match pats mt rhs')
where
matchesInDecls (GHC.FunBind _ _ (GHC.MatchGroup matches _) _ _ _) = matches
matchesInDecls _x = []
patsInMatch (GHC.L _ (GHC.Match pats _ _)) = pats
foldInDemotedDecls :: [GHC.Name]
-> [GHC.Name]
-> [(GHC.Name, GHC.HsExpr GHC.Name)]
-> [GHC.LHsBind GHC.Name]
-> RefactGhc [GHC.LHsBind GHC.Name]
foldInDemotedDecls pns clashedNames subst decls
= everywhereMStaged SYB.Renamer (SYB.mkM worker) decls
where
worker (match@(GHC.FunBind (GHC.L _ pname) _ (GHC.MatchGroup _matches _) _ _ _) :: GHC.HsBind GHC.Name)
| isJust (find (==pname) pns)
= do
match' <- foldM (flip (autoRenameLocalVar True)) match clashedNames
match'' <- foldM replaceExpWithUpdToks match' subst
rmParamsInDemotedDecls (map fst subst) match''
worker x = return x
allParams :: GHC.Name -> GHC.GRHSs GHC.Name -> [[GHC.HsExpr GHC.Name]]
-> RefactGhc [[GHC.HsExpr GHC.Name]]
allParams pn rhs initial
=do
let p = getOneParam pn rhs
if (nonEmptyList p) then do rhs' <- rmOneParam pn rhs
allParams pn rhs' (initial++[p])
else return initial
where
getOneParam :: (SYB.Data t) => GHC.Name -> t -> [GHC.HsExpr GHC.Name]
getOneParam pn
= SYB.everythingStaged SYB.Renamer (++) []
([] `SYB.mkQ` worker)
where
worker :: GHC.HsExpr GHC.Name -> [GHC.HsExpr GHC.Name]
worker (GHC.HsApp e1 e2)
|(expToName e1==pn) = [GHC.unLoc e2]
worker _ = []
rmOneParam :: (SYB.Data t) => GHC.Name -> t -> RefactGhc t
rmOneParam pn t
= do
everywhereMStaged' SYB.Renamer (SYB.mkM worker) t
where
worker (GHC.HsApp e1 _e2 )
|expToName e1==pn = return (GHC.unLoc e1)
worker x = return x
rmParamsInDemotedDecls :: [GHC.Name] -> GHC.HsBind GHC.Name
-> RefactGhc (GHC.HsBind GHC.Name)
rmParamsInDemotedDecls ps bind
= everywhereMStaged SYB.Renamer (SYB.mkM worker) bind
where worker (GHC.Match pats typ rhs)
= do
let pats'=filter (\x->not ((patToPNT x /= Nothing) &&
elem (fromJust $ patToPNT x) ps)) pats
let (startPos,endPos) = getBiggestStartEndLoc pats
if (emptyList pats')
then removeToksForPos (startPos,endPos)
else
updateToksWithPos (startPos,endPos) pats' pprPat False
return (GHC.Match pats' typ rhs)
pprPat pat = intercalate " " $ map (\p -> (prettyprint p )) pat
rmParamsInParent :: GHC.Name -> [GHC.HsExpr GHC.Name] -> GHC.GRHSs GHC.Name
-> RefactGhc (GHC.GRHSs GHC.Name)
rmParamsInParent pn es
= everywhereMStaged SYB.Renamer (SYB.mkM worker)
where worker exp@(GHC.L _ (GHC.HsApp e1 e2))
| findPN pn e1 && (elem (showGhc (GHC.unLoc e2)) (map (showGhc) es))
= update exp e1 exp
worker (exp@(GHC.L _ (GHC.HsPar e1)))
|pn==expToName e1
= update exp e1 exp
worker x =return x
getClashedNames oldNames newNames match
= do let (_f,d) = hsFDsFromInside match
let ds' = map (flip hsVisiblePNs match) oldNames
return (filter (\x->elem ( x) newNames)
( nub (d `union` (nub.concat) ds')))
mkSubst :: [GHC.LPat GHC.Name] -> [[GHC.HsExpr GHC.Name]] -> [(GHC.Name,GHC.HsExpr GHC.Name)]
mkSubst pats params
= catMaybes (zipWith (\x y -> if (patToPNT x/=Nothing) && (length (nub $ map showGhc y)==1)
then Just (fromJust $ patToPNT x,(ghead "mkSubst") y)
else Nothing) pats params)
replaceExpWithUpdToks :: (SYB.Data t)
=> t -> (GHC.Name, GHC.HsExpr GHC.Name)
-> RefactGhc t
replaceExpWithUpdToks decls subst
= everywhereMStaged' SYB.Renamer (SYB.mkM worker) decls
where worker (e@(GHC.L l _)::GHC.LHsExpr GHC.Name)
|(expToName e/=defaultName) && (expToName e)==(fst subst)
= update e (GHC.L l (snd subst)) e
worker x=return x
isLocalFunOrPatName :: SYB.Data t => GHC.Name -> t -> Bool
isLocalFunOrPatName pn scope
= isLocalPN pn && isFunOrPatName pn scope
divideDecls ::
SYB.Data a =>
[a] -> GHC.Located GHC.Name -> ([a], [a], [a])
divideDecls ds pnt
= let (before,after)=break (\x->findPNT pnt x) ds
in if (not $ emptyList after)
then (before, [ghead "divideDecls" after], tail after)
else (ds,[],[])