HaRe-0.6: refactorer/RefacGenDef.hs
module RefacGenDef(generaliseDef) where
import PrettyPrint
import PosSyntax
import Maybe
import TypedIds
import UniqueNames
import PNT
import TiPNT
import List
import RefacUtils
{-A definition can be generialised by selecting a sub-expression of the RHS of the definition,
and introducing that sub-expression as a new argument to the function/constant at each of its
call sites. At the same time, a new formal parameter will be added to the generalised definition.
When generalising a definition in a mutli-module context, there maybe several cases:
1. The definition is not exported by the current module: refactoring only afftects this module.
2. The definition is exported by the current module, but not used by any client modules.
3. The definition is exported by the current module, and used any some client modules:
2.1 The selected sub-expression does not contain any free variables.
2.2 The selected sub-expression contains free variables. In this case, this is a possiblity that
some of the free variables may not be visible in the client modules. These free variables might
be from the current module, or from other modules that are imported by the current modules.One
implementation option is to make these variables also visible to the client modules by modifying/
adding import declarations. This involves chasing the origins of these free variables, and detecting
possible name clashes/captures. Another implementation option is to define an auxiliary function
to denote the sub-expression, and make this function visible to the client modules. We take the
second option in our implementation. To ensure that the new function name does not cause name clash
in the client modules, we take the visble names both in the current module and in the client modules
into account when creating the new function name.
-}
generaliseDef args
= let fileName = args!!0
newParamName = args!!1
beginPos = (read (args!!2), read (args!!3))::(Int,Int)
endPos = (read (args!!4), read (args!!5)) :: (Int,Int)
in if isVarId newParamName -- the parameter name is a valid name.
then do modName <- RefacUtils.fileNameToModName fileName
(inscps,exps,mod, tokList) <- parseSourceFile fileName
let (pnt,subExp) = findDefNameAndExp tokList beginPos endPos mod
pn = pNTtoPN pnt
if pn == defaultPN || subExp == defaultExp
then error ("The highlighted source does not contain a rhs sub-expression, " ++
"or the selected sub-expression does not contain any identifiers so that the refactor could not locate it.")
else if isExported pnt exps
then do clients <- clientModsAndFiles modName -- returns [(module name ,filename)]
info <- mapM parseSourceFile (map snd clients) -- parse all the client modules
let funPName
=if clients /= [] && hasFreeVars subExp --THIS CONDITION MIGHT A LITTLE BIT LOOSE.
--HOW ABOUT NONE OF THE CLIENTS USE IT?
then let inscpNames =map (\ (x,_,_,_)->x) $ concatMap inScopeInfo (map myfst info) -- calculate all visibe names
in Just =<< mkNewFunPName pn (hsDecls mod) modName inscpNames
else Nothing
subExp' = if isJust funPName then pNtoExp (fromJust funPName) else subExp
(mod',((tokList',m),_)) <- doGeneralise pnt fileName subExp newParamName funPName mod tokList
refactoredClients <- mapM (generaliseInClientMod pnt subExp' modName funPName)
$ zip info (map snd clients)
writeRefactoredFiles False $ ((fileName,m), (tokList',mod')):refactoredClients
else do (mod',((tokList',m),_))<-doGeneralise pnt fileName subExp newParamName Nothing mod tokList
writeRefactoredFiles False [((fileName,m), (tokList',mod'))]
else error "Invalid parameter name!"
where
--find the definition name whose sub-expression has been selected, and the selected sub-expression.
findDefNameAndExp toks beginPos endPos t
= fromMaybe (defaultPNT, defaultExp) (applyTU (once_tdTU (failTU `adhocTU` inMatch
`adhocTU` inPat)) t) --CAN NOT USE 'once_tdTU' here.
where --The selected sub-expression is in the rhs of a match
inMatch (match@(HsMatch loc1 pnt pats rhs ds)::HsMatchP)
| locToExp beginPos endPos toks rhs /= defaultExp
= Just (pnt, locToExp beginPos endPos toks rhs)
inMatch _ = Nothing
--The selected sub-expression is in the rhs of a pattern-binding
inPat (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)
| locToExp beginPos endPos toks rhs /= defaultExp
= if isSimplePatBind' pat
then Just (patToPNT ps, locToExp beginPos endPos toks rhs)
else error "A complex pattern binding can not be generalised!"
inPat _ = Nothing
isSimplePatBind' (Dec (HsPatBind _ p _ _)) = isPatID p
isPatID (Pat (HsPId (HsVar pnt))) = True
isPatID p = False
-- Do generalisation in current module.
doGeneralise pnt@(PNT pn _ _) fileName subExp newParamName newFunPName mod tokList
= runStateT (if isJust newFunPName
then do -- add the new function name to the export list
mod'<-addItemsToExport mod (Just pn) False (Left [pNtoName (fromJust newFunPName)])
doGeneralise' mod'
else doGeneralise' mod) ((tokList,unmodified),(-1000,0))
where
doGeneralise' mod
= applyTP (once_tdTP (failTP `adhocTP` inMod
`adhocTP` inMatch
`adhocTP` inPat
`adhocTP` inLet
`adhocTP` inAlt
`adhocTP` inStmt) `choiceTP` failure) mod
where
--1.pn is declared in top level
inMod (mod@(HsModule loc name exps imps ds):: HsModuleP)
| definingDecls [pn] ds False False/=[]
= do worker pnt subExp newParamName mod ds newFunPName
inMod _ =mzero
--2. pn is declared locally in the where clause of a match.
inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)
| definingDecls [pn] ds False False/=[]
= worker pnt subExp newParamName match ds newFunPName
inMatch _ =mzero
--3. pn is declared locally in the where clause of a pattern binding.
inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)
| definingDecls [pn] ds False False /=[]
= worker pnt subExp newParamName pat ds newFunPName
inPat _=mzero
--4: pn is declared locally in a Let expression
inLet (letExp@(Exp (HsLet ds e))::HsExpP)
| definingDecls [pn] ds False False /=[]
= worker pnt subExp newParamName letExp ds newFunPName
inLet _=mzero
--5. pn is declared locally in a case alternative.
inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)
| definingDecls [pn] ds False False/=[]
= worker pnt subExp newParamName alt ds newFunPName
inAlt _=mzero
--6.pn is declared locally in a let statement.
inStmt (letStmt@(HsLetStmt ds stmts):: HsStmtP)
| definingDecls [pn] ds False False/=[]
= worker pnt subExp newParamName letStmt ds newFunPName
inStmt _=mzero
failure=idTP `adhocTP` mod
where mod (m::HsModuleP)=error "Refactoring failed"
worker pnt@(PNT pn _ _) subExp newParamName parent ds newFunPName
= do --add formal parameter to the generalised function
let newParamPName = nameToPN newParamName
declToBeGeneralised = definingDecls [pn] ds False False
doChecking declToBeGeneralised
parent' <- if isJust newFunPName
then do let declToAdd=Dec (HsPatBind loc0 (pNtoPat (fromJust newFunPName)) (HsBody subExp) [])
addDecl parent (Just pn) ([declToAdd],Nothing) True
else return parent
ds''<-replaceExpByParam pn subExp newParamPName =<<commentOutTypeSig pn (hsDecls parent')
ds'''<-addParamsToDecls ds'' pn [newParamPName] True
--ds''<- addFormalParam pn subExp newParamName =<<commentOutTypeSig pn ds'
--Check clashed names because of the adding of subExp as a actual parameter.
parent''<- renamingCheck pn subExp $ replaceDecls parent' ds'''
--Adding the actual parameter to each call site of the generalised function name.
addActualArg False pn subExp parent''
where
doChecking decl
= do (expFreeVars,_) <- hsFreeAndDeclaredPNs subExp
(defFreeVars,_) <- hsFreeAndDeclaredPNs decl
if expFreeVars \\ defFreeVars /= []
then do error "The selected expression should not contain locally declared variables!"
else do (f,d) <- hsFDsFromInside =<< replaceExpByDefault subExp decl
d' <- hsVisiblePNs subExp decl
if elem newParamName $ map pNtoName (f `union` d `union` d')
then error "The parameter name will cause name clash or semantics change, please choose another name!"
else return ()
{- substitute the occurrence of an expression by the default expression,
in order to get rid of the free variables in the generalised sub-expression -}
replaceExpByDefault e = applyTP (once_tdTP (failTP `adhocTP` inExp))
where
--only replace the higelighted expression
inExp (e1::HsExpP)
|sameOccurrence e1 e
= return defaultExp
inExp x = mzero
--Replace occurrence of the highlighted expression by the formal parameter.
replaceExpByParam pn e paramPName = applyTP (once_tdTP (failTP `adhocTP` inDecl))
where
--The sub-expression is in the rhs of a function definition.
inDecl (fun@(Dec (HsFunBind _ ((HsMatch _ (PNT pname _ _) _ _ _):ms)))::HsDeclP)
| pn == pname
= replaceExpByParam' fun
--The sub-expression is in the rhs of a pattern binding
inDecl (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)
| pn == patToPN ps
= replaceExpByParam' pat
inDecl _ =mzero
replaceExpByParam'= applyTP (stop_tdTP (failTP `adhocTP` inExp)) -- use once_td to only replace the
-- highlighted occurrence.
where
inExp (e1 ::HsExpP)
| e1 == e -- && srcLocs e == srcLocs e1 --ONLY REPLACE THE HIGHLIGHTED EXP.
= do let newExp=pNtoExp paramPName
update e1 newExp e1
inExp e = mzero
renamingCheck pn subExp parent
= do --free variables declared in the highlighted expression
(f,_) <- hsFreeAndDeclaredPNs subExp
--visible variables to the generalised function name in its use places.
vVars <- hsVisiblePNs pn parent
--clasedNames names come from the vVars
let clashedNames = filter (\x->elem (pNtoName x) (map pNtoName f)) $ (nub vVars \\ nub f)
if clashedNames == []
then return parent
else error ("The identifier(s):" ++ showEntities showPNwithLoc clashedNames ++
" will cause name capture/clash after generalisation, please do renaming first!")
{- if the generalised declaration is a direct recursion function, then add the parameter
as the actual argument; otherwise add the highlighted expression as a actual paramter
to the generalised function at each of its call sites -}
addActualArg recursion pn subExp
= if recursion then applyTP (stop_tdTP (failTP `adhocTP` funApp))
else applyTP (stop_tdTP (failTP `adhocTP` inDecl
`adhocTP` funApp))
where
inDecl (fun@(Dec (HsFunBind _ ((HsMatch _ (PNT pname _ _) _ _ _):ms)))::HsDeclP)
| pn == pname
= return fun
inDecl (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)
| pn == patToPN ps
= return pat
inDecl _ = mzero
funApp (Exp (HsApp e exp@(Exp (HsId (HsVar pnt@(PNT pname _ _ )))))::HsExpP)
| pname == pn --ganrantee this is a use place of pn
= do exp'<-doAddingActulaArg pnt exp subExp True
return (Exp (HsApp e exp'))
funApp (exp@(Exp (HsId (HsVar pnt@(PNT pname _ _))))::HsExpP)
| pname == pn --ganrantee this is a use place of pn
= doAddingActulaArg pnt exp subExp False
funApp _ = mzero
doAddingActulaArg pnt pntExp subExp addParen
= do let newExp = if isSimpleExp subExp || isParenExp subExp
then if addParen then (Exp (HsParen (Exp (HsApp pntExp subExp))))
else (Exp (HsApp pntExp subExp))
else if addParen then (Exp (HsParen (Exp (HsApp pntExp (Exp (HsParen subExp))))))
else (Exp (HsApp pntExp (Exp (HsParen subExp))))
update pntExp newExp pntExp
where
isSimpleExp (Exp (HsId _))=True
isSimpleExp (Exp (HsLit _ _))=True
isSimpleExp _ =False
isParenExp (Exp (HsParen _))=True
isParenExp _=False
addActualArgInClientMod pn qual funName toBeQualified t
= applyTP (stop_tdTP (failTP `adhocTP`funApp)) t
where
funApp (Exp (HsApp e exp@(Exp (HsId (HsVar pnt@(PNT pname _ _ )))))::HsExpP)
| pname == pn --ganrantee this is a use place of pn
= do vs <- hsVisibleNames pnt t
let e'=if toBeQualified || elem (pNtoName funName) vs
then pNtoExp (qualifyPName qual funName)
else pNtoExp funName
exp'<- doAddingActulaArg pnt exp e' True
return (Exp (HsApp e exp'))
funApp (exp@(Exp (HsId (HsVar pnt@(PNT pname _ _))))::HsExpP)
| pname == pn --ganrantee this is a use place of pn
= do vs <- hsVisibleNames pnt t
let e'=if toBeQualified || elem (pNtoName funName) vs
then pNtoExp (qualifyPName qual funName)
else pNtoExp funName
doAddingActulaArg pnt exp e' False
funApp _ = mzero
generaliseInClientMod pnt subExp serverModName newFunPName ((inscps, exps, mod,ts) ,fileName)
= let qual = hsQualifier pnt inscps
pn = pNTtoPN pnt
in if qual==[]
then --This name is not imported
return ((fileName,unmodified), (ts,mod))
else do (mod',((ts',m), _))
<- runStateT (if isNothing newFunPName
then addActualArg False pn subExp mod
else do let funName=fromJust newFunPName
mod' <- addItemsToImport serverModName (Just pn) (Left [pNtoName funName]) mod
mod''<- addItemsToExport mod' (Just pn) False (Left [pNtoName funName])
if isInScopeAndUnqualified (pNtoName pn) inscps
then addActualArgInClientMod pn (head qual) funName False mod''
else addActualArgInClientMod pn (head qual) funName True mod'')
((ts,unmodified), (-1000,0))
return ((fileName,m),(ts',mod'))
myfst (a,_,_,_) = a
{- Create the auxiliary function name. Suppose the original function name is 'f',
then the auxiliary function name is like 'f_gen_i', where i is an integer. -}
mkNewFunPName pn e modName inscopeNames
=do (f1,d1) <- hsFDsFromInside e
let name=mkNewName ((pNtoName pn)++"_gen") (nub ((map pNtoName (f1 `union` d1)) `union` inscopeNames)) 0
return (PN (UnQual name) (G modName name (N (Just loc0))))