HaRe-0.6: refactorer/RefacRedunDec.hs
module RefacRedunDec (convertPatsToPn,
convertToPat,
refacRedunDec,
removeRedun,
removeRedunWhere,
removeRedunWhere2,
doRemovingWhere, doRemoving1, doRefac) where
import AbstractIO
import Maybe
import List
import RefacUtils
import RefacLocUtils
data Patt = Match HsMatchP | MyPat HsDeclP | Def [Char]
refacRedunDec args
= do let fileName = args!!0
beginRow = read (args!!1)::Int
beginCol = read (args!!2)::Int
endRow = read (args!!3)::Int
endCol = read (args!!4)::Int
AbstractIO.putStrLn "refacRedunDec"
-- Parse the input file.
modInfo@(inscps, exps, mod, tokList) <- parseSourceFile fileName
-- Find the function that's been highlighted as the refactree
let (loc, pnt, pats, exp, wh, p)
= findDefNameAndExp tokList
(beginRow, beginCol)
(endRow, endCol)
mod
(wh', newExp) <- removeRedunCase exp wh
(wh'', newExp') <- doRefac wh' newExp
-- (mod',((tokList',modified),_))<-doRemovingWhere fileName mod tokList exp newExp wh'
((_,_), (tokList', mod')) <- applyRefac (doRemovingWhere exp newExp' wh'') (Just (inscps, exps, mod, tokList)) fileName
((_,m), (tokList'', mod'')) <- applyRefac (doRemoving1 exp newExp' wh'') (Just (inscps, exps, mod', tokList')) fileName
writeRefactoredFiles False [((fileName, True), (tokList'', mod''))]
-- error (show mod')
AbstractIO.putStrLn "Completed.\n"
doRefac wh exp = do
(decls, newExp) <- removeRedun wh exp
(newWhere) <- removeRedunWhere wh newExp
return (newWhere, newExp)
convertToPat [] _ = []
convertToPat _ [] = []
convertToPat (pat@(Pat (HsPId (HsVar (PNT (PN x y) Value s)))):ps) ((PN v z):xs)
| x == v && y == z = pat : (convertToPat ps xs)
| otherwise = convertToPat ps ((PN v z):xs)
convertPatsToPn [] = []
convertPatsToPn ((Pat (HsPId (HsVar (PNT (PN x y)Value s )))):ps)
= (PN x y): (convertPatsToPn ps)
convertPatsToPn _ = []
--removeRedun :: [HsDeclP] -> HsExpP -> m ([HsDeclP], HsExpP)
removeRedunCase (Exp(HsParen e)) wh
= do
res <- removeRedunCase e wh
return res
removeRedunCase (Exp(HsCase e alts)) wh
= do
newAlts <- checkAlts alts
return (wh, (Exp (HsCase e newAlts)))
where
checkAlts [] = do
return []
checkAlts ((HsAlt s p1 (HsBody e) ds):xs)
= do
decls <- removeRedunWhere ds e
res <- checkAlts xs
return ((HsAlt s p1 (HsBody e) decls) : res)
removeRedunCase (exp@e) wh = do
return (wh, e)
removeRedun wh (Exp (HsParen e))
= do
(wh', newExp) <- removeRedun wh e
return (wh', (Exp (HsParen newExp)))
removeRedun wh (Exp (HsInfixApp e1 o e2))
= do
(wh'1, newExp1) <- removeRedun wh e1
(wh'2, newExp2) <- removeRedun wh e2
return ( nub ( wh'2 ++ wh), (Exp (HsInfixApp newExp1 o newExp2)))
removeRedun wh (Exp(HsLet ds e)) = do
(_, newE) <- removeRedun wh e
(free, dec) <- hsFreeAndDeclaredPNs newE
let decls = checkFree free ds
let decls' = checkFree free wh
newWhere <- checkWhere wh decls
moreDecls <- checkRestDecls decls' wh
if decls /= []
then do
return ((nub (moreDecls++(decls'++newWhere))), (Exp(HsLet decls newE)))
else do
return ((nub (moreDecls++(decls'++newWhere))), newE)
where
checkWhere [] _ = do return wh
checkWhere wh [] = do return wh
checkWhere wh ((Dec(HsPatBind _ _ (HsBody e)_)):xs)
= do
(free, dec) <- hsFreeAndDeclaredPNs e
let decls = checkFree free wh
newDecls <- checkWhere decls xs
moreDecls <- checkRestDecls newDecls wh
return (nub (moreDecls ++ newDecls))
removeRedun wh exp@(Exp (HsLambda (p:ps) e))
= do
(free, dec) <- hsFreeAndDeclaredPNs e
-- error $ show (free, (p:ps))
let decls = myCheckFree e (p:ps)
let decls' = checkFree free wh
-- newWhere <- checkWhere wh [(Exp (HsLambda decls e))]
moreDecls <- checkRestDecls decls' wh
return ((nub (moreDecls ++ (decls'))), (Exp (HsLambda decls e)))
where
myCheckFree e list = checkSin e list
where
checkSin :: HsExpP -> [HsPatP] -> [HsPatP]
checkSin e [] = []
checkSin e (x:xs)
| findPN' (patToPN x) e = x : checkSin e xs
| otherwise = checkSin e xs
checkWhere [] _ = do return wh
checkWhere wh [] = do return wh
checkWhere wh ((Dec(HsPatBind _ _ (HsBody e)_)):xs)
= do
(free, dec) <- hsFreeAndDeclaredPNs e
let decls = checkFree free wh
newDecls <- checkWhere decls xs
moreDecls <- checkRestDecls newDecls wh
return (nub (moreDecls ++ newDecls))
removeRedun wh (exp@(_)) = do return (wh, exp)
removeRedunWhere wh (exp@(_)) = do
(free, dec) <- hsFreeAndDeclaredPNs exp
let decls = checkFree free wh
-- check each declaration that is left for
-- declarations that are still needed
let dupsRemove = removeDups wh decls
moreDecls <- checkRestDecls decls dupsRemove
return (nub (decls++moreDecls))
where
removeDups [] ys = []
removeDups (x:xs) ys
| x `elem` ys = removeDups xs ys
| otherwise = x : removeDups xs ys
removeRedunWhere2 wh (exp@(_)) = do
(free, dec) <- hsFreeAndDeclaredPNs exp
let decls = checkFree2 free wh
-- check each declaration that is left for
-- declarations that are still needed
moreDecls <- checkRestDecls decls wh
return (nub (decls++moreDecls))
checkRestDecls [] _ = return []
checkRestDecls wh [] = return []
checkRestDecls ((Dec (HsPatBind loc1 ps (HsBody e) ds)):rest) (x:[])
= do
(free, dec) <- hsFreeAndDeclaredPNs e
let decls = checkFree free [x]
return decls
checkRestDecls ((Dec (HsPatBind loc1 ps (HsBody e) ds)):rest) (x:xs)
= do
(free, dec) <- hsFreeAndDeclaredPNs e
let decls = checkFree free (x:xs)
-- moreDecls <- checkRestDecls [x] xs
moreDecls <- checkRestDecls decls (x:xs)
moreDecls' <- checkRestDecls rest (x:xs)
return (decls ++ (moreDecls ++ moreDecls'))
checkRestDecls ((Dec (HsFunBind loc1 ms)):rest) (x:xs)
= do
res <- checkRestMatches ms
let newDec = (Dec (HsFunBind loc1 res))
moreDecls <- checkRestDecls rest (x:xs)
return (newDec : moreDecls)
where
checkRestMatches [] = return []
checkRestMatches (m@(HsMatch l i1 ps (HsBody e) ds):ms)
= do
(free, dec) <- hsFreeAndDeclaredPNs e
let decls = checkFree free (x:xs)
-- moreDecls <- checkRestDecls [x] xs
moreDecls1 <- checkRestMatches ms
return moreDecls1
doRemoving1 exp newExp wh (_, _, mod)
= do
newMod <- doRemoving exp newExp wh mod
return newMod
-- Stafunski function to traverse the AST and find the occurance of the exp that we
-- are interested in. When the exp is found, the redundant declarations are calculated
-- and rmDecls in then called.
-- the rusult is then a new expression with the new list of declarations returned by
-- rmDecls.
doRemoving exp newExp wh mod
= applyTP (stop_tdTP (failTP `adhocTP` (rmInLet newExp))) mod
where
rmInLet (new::HsExpP) (letExp@(Exp (HsParen (Exp (HsCase e2 alts2))))::HsExpP)
|sameOccurrence letExp exp
= do
-- error $ show new
r <- update letExp (Exp (HsParen new)) letExp
return r
| otherwise = return (Exp (HsParen new))
rmInLet (new::HsExpP) (letExp@(Exp (HsCase e2 alts2))::HsExpP)
| rmLocs letExp == rmLocs exp
= do
-- error $ show new
r <- update letExp new letExp
return r
| otherwise = return letExp
rmInLet (new@(Exp (HsParen e1))::HsExpP) (letExp@(Exp (HsLet ds e))::HsExpP)
= do
res <- rmInLet e1 letExp
return res
rmInLet (new@(Exp (HsLet ds e1))::HsExpP) (letExp@(Exp (HsParen (Exp (HsLet ds2 e2))))::HsExpP)
| sameOccurrence letExp exp == True
= do
res <- update letExp (Exp (HsParen new)) letExp
return res
| otherwise = return letExp
--1. The definition to be removed is a local declaration in a let expression
rmInLet (new@(Exp (HsLet decs e'))::HsExpP) (letExp@(Exp (HsLet ds e))::HsExpP)
| sameOccurrence letExp exp == True
=do
let redunDecs = ds \\ decs
ds'<- rmDecls ds redunDecs
if ds'==[] then do res <- rmInLet new e
-- r <- update letExp res exp
-- error $ show (tokenise (Pos 0 v1 1) offset False $ printFun)
return res
else do
r <- update letExp (Exp (HsLet ds' e')) letExp
return r
| otherwise = do
-- error $ show (new, letExp)
return letExp
rmInLet e1 (Exp (HsLet ds e)::HsExpP)
| sameOccurrence e1 e == True
= do
ds' <- rmDecls ds ds
if ds' == [] then return e1
else return (Exp (HsLet ds' e))
| otherwise
= return e
rmInLet (new@(Exp (HsParen (Exp (HsLambda ds1 e1))))::HsExpP) (lamExp@(Exp (HsParen (Exp (HsLambda ds e2))))::HsExpP)
| sameOccurrence lamExp exp == True
= do
res <- update lamExp new lamExp
return res
| otherwise = return lamExp
rmInLet (new@(Exp (HsParen e1))::HsExpP) (lamExp@(Exp (HsLambda ds e2))::HsExpP)
= do
res <- rmInLet e1 lamExp
return res
rmInLet (new@(Exp (HsLambda decs e'))::HsExpP) (letExp@(Exp (HsParen (Exp (HsLambda ds e))))::HsExpP)
| sameOccurrence letExp exp == True
=do
res <- update letExp (Exp (HsParen new)) letExp
return res
| otherwise = return letExp
rmInLet (new@(Exp (HsLambda decs e'))::HsExpP) (letExp@(Exp (HsLambda ds e))::HsExpP)
| sameOccurrence letExp exp == True
=do
res <- update letExp newExp letExp
return res
| otherwise = return letExp
{- rmInLet (e1@(Exp (HsLambda _ _))::HsExpP) (e2::HsExpP)
= do res <- update e2 newExp e2
return res -}
rmInLet e1 e2@(Exp (HsInfixApp e11 o e22)::HsExpP)
| findEntity e1 e11 = do -- error $ show (e1, e11)
res <- rmInLet e1 e11
r <- update e2 res e2
return r
| findEntity e1 e22 = do
res <- rmInLet e1 e22
r <- update e2 res e2
return r
rmInLet e1 e2@(Exp (HsParen e))
= do
res <- rmInLet e1 e
-- r <- update e2 res e2
return res
rmInLet e1 e2
| sameOccurrence e2 exp == True
= do
res <- update e2 e1 e2
return res
| otherwise = return e2
rmDecls wh [] = return wh
rmDecls wh ((d@(Dec (HsPatBind loc1 pn (HsBody rhs) ds))::HsDeclP):xs)
= do
let newName = pNTtoPN (patToPNT pn)
decls' <- rmDecl newName False wh
decls'' <- rmDecls decls' xs
return decls''
rmDecls d _ = return wh
doRemovingWhere exp newExp wh (_,_,mod)
= (applyTP (stop_tdTP (failTP `adhocTP` (rmInPat exp)
`adhocTP` (rmInMatch exp))) mod)
{- runStateT (applyTP (stop_tdTP (failTP `adhocTP` (rmInPat exp)
`adhocTP` (rmInMatch exp)
`adhocTP` rmInCase)) mod) ((tokList,unmodified),fileName) -}
where
rmInCase (a@(HsAlt s p1 (HsBody e2) ds)::HsAltP)
| findEntity newExp e2
=do
-- error $ show e2
ds' <- removeRedunWhere ds newExp
-- let redunDecs = ds \\ wh
-- ds'<- rmDecls ds [] redunDecs
-- let ds' = filter (not . (\x -> x `elem` redunDecs)) ds
-- error $ show ds'
if ds' == [] then fail ""
else do
r <- update a (HsAlt s p1 (HsBody e2) ds') a
-- return (HsAlt s p1 (HsBody e2) ds')
return r
rmInCase e2 = fail ""
rmInPat exp (pat@(Dec (HsPatBind loc p (HsBody rhs) ds))::HsDeclP)
| sameOccurrence exp rhs && ds /= []
=do
-- error "3"
redunDecs2 <- removeRedunWhere ds newExp
let redunDecs = ds \\ redunDecs2
ds'<- rmDecls ds redunDecs
return (Dec (HsPatBind loc p (HsBody rhs) ds'))
| sameOccurrence exp rhs && ds == [] && wh /= []
= do
-- error "2"
r <- update pat (Dec (HsPatBind loc p (HsBody rhs) wh)) pat
return r
rmInPat exp (pat@(Dec (HsPatBind loc p g@(HsGuard es) ds))::HsDeclP)
| checkES exp es && ds /= []
=do
-- error "3"
redunDecs2 <- removeRedunWhere ds newExp
-- circle through all expressions in guards
let firstExp = getExp' es
redunDecs3 <- removeRedunWhere ds firstExp
gatherRedun <- getExp ds (tail es)
-- error $ show (redunDecs2, redunDecs3)
let redunDecs = nub (((ds \\ redunDecs2) \\ redunDecs3) \\ gatherRedun)
ds'<- rmDecls ds redunDecs
return (Dec (HsPatBind loc p g ds'))
| checkES exp es && ds == [] && wh /= []
= do
-- error "2"
r <- update pat (Dec (HsPatBind loc p g wh)) pat
return r
rmInPat _ e2 = fail ""
rmInMatch exp (match@(HsMatch loc1 pnt pats (rhs@(HsBody e)) ds)::HsMatchP)
| sameOccurrence exp e && wh /= []
= do
-- ds'' <- addDecl (HsMatch loc1 pnt pats rhs ds) Nothing ((nub (wh++ds)), Nothing) False
ds' <- rmDecls ds ds
ds'' <- addDecl (HsMatch loc1 pnt pats rhs ds') Nothing (wh, Nothing) False
return ds''
| sameOccurrence exp e && ds /= []
=do
redunDecs2 <- removeRedunWhere (nub (ds++wh)) newExp
let redunDecs = (ds \\ redunDecs2)
ds'<- rmDecls ds redunDecs2
-- error $ show redunDecs
return (HsMatch loc1 pnt pats rhs ds')
| sameOccurrence exp e && ds == [] && wh /= []
= do
-- error (show wh)
ds' <- addDecl match Nothing (wh, Nothing) False
return ds'
rmInMatch exp (match@(HsMatch loc1 pnt pats (rhs@(HsGuard es)) ds)::HsMatchP)
| checkES exp es && ds /= []
=do
redunDecs2 <- removeRedunWhere (nub (ds++wh)) newExp
-- circle through all expressions in guards
let firstExp = getExp' es
redunDecs3 <- removeRedunWhere ds firstExp
gatherRedun <- getExp ds (tail es)
-- error $ show (redunDecs2, redunDecs3)
let redunDecs = nub (((ds \\ redunDecs2) \\ redunDecs3) \\ gatherRedun)
ds'<- rmDecls ds redunDecs
-- error $ show redunDecs
return (HsMatch loc1 pnt pats rhs ds')
| checkES exp es && ds == [] && wh /= []
= do
-- error (show wh)
ds' <- addDecl match Nothing (wh, Nothing) False
return ds'
rmInMatch _ e2 = fail ""
checkES _ [] = False
checkES exp ((_,_, e):gs)
| sameOccurrence exp e = True
| otherwise = checkES exp gs
getExp ds [] = return []
getExp ds ((_,e1,e2):gs)
= do
redunDecs1 <- removeRedunWhere ds e1
redunDecs2 <- removeRedunWhere ds e2
rest <- getExp ds gs
return ((redunDecs1 \\ redunDecs2) \\ rest)
getExp' [] = defaultExp
getExp' ((_,e1,_):es) = e1
--error ((show e1) ++ " " ++ (show e2) )
rmDecls wh [] = return wh
rmDecls wh ((d@(Dec (HsPatBind loc1 pn e ds))::HsDeclP):xs)
= do
let newName = pNTtoPN (patToPNT pn)
decls' <- rmDecl newName False wh
decls'' <- rmDecls decls' xs
return decls''
rmDecls wh ((d@(Dec (HsFunBind _ ((HsMatch loc pnt pats e ds):ms)))::HsDeclP):xs)
= do
let newName = pNTtoPN pnt
decls' <- rmDecl newName False wh
decls'' <- rmDecls decls' xs
return decls''
rmDecls d _ = return wh
{- rmDecls wh d [] = return []
rmDecls wh d (((Dec (HsPatBind loc1 pn (HsBody rhs) ds))::HsDeclP):xs)
= do
let newName = pNTtoPN (patToPNT pn)
decls' <- rmDecl newName False wh
decls'' <- rmDecls wh decls' xs
return decls''
rmDecls _ d _ = return d -}
newMatch loc pnt pats rhs ds = HsMatch loc pnt pats (HsBody rhs) ds
newDecl loc pnt pats rhs ds = Dec (HsFunBind loc [HsMatch loc pnt pats (HsBody rhs) ds] )
checkFree :: [PName] -> [HsDeclP] -> [HsDeclP]
checkFree [] _ = []
checkFree _ [] = []
checkFree (p:ps) list = (checkSin p list) ++ (checkFree ps list)
where
checkSin :: PName -> [HsDeclP] -> [HsDeclP]
checkSin p [] = []
checkSin p (x:xs)
| defines p x = [x]
| otherwise = checkSin p xs
checkFree2 :: [PName] -> [HsDeclP] -> [HsDeclP]
checkFree2 [] _ = []
checkFree2 _ [] = []
checkFree2 (p:ps) list = (checkSin p list) ++ (checkFree ps list)
where
checkSin :: PName -> [HsDeclP] -> [HsDeclP]
checkSin p [] = []
checkSin p (x:xs)
| defines' p x = x : (checkSin p xs)
| otherwise = checkSin p xs
{-|
Takes the position of the highlighted code and returns
the function name, the list of arguments, the expression that has been
highlighted by the user, and any where\/let clauses associated with the
function.
-}
{-findDefNameAndExp :: Term t => [PosToken] -- ^ The token stream for the
-- file to be
-- refactored.
-> (Int, Int) -- ^ The beginning position of the highlighting.
-> (Int, Int) -- ^ The end position of the highlighting.
-> t -- ^ The abstract syntax tree.
-> (SrcLoc, PNT, FunctionPats, HsExpP, WhereDecls) -- ^ A tuple of,
-- (the function name, the list of arguments,
-- the expression highlighted, any where\/let clauses
-- associated with the function).
-}
findDefNameAndExp toks beginPos endPos t
= fromMaybe ([], defaultPNT, [], defaultExp, [], Def [])
(applyTU (once_tdTU (failTU `adhocTU` inMatch `adhocTU` inPat)) t)
where
--The selected sub-expression is in the rhs of a match
inMatch (match@(HsMatch loc1 pnt pats rhs@(HsBody e) ds)::HsMatchP)
| locToExp beginPos endPos toks rhs /= defaultExp
= Just ([loc1], pnt, pats, e, ds, (Match match))
inMatch (match@(HsMatch loc1 pnt pats (rhs@(HsGuard es)) ds)::HsMatchP)
= checkES es
where
checkES [] = Nothing
checkES ((s, e1 , e): es)
| locToExp beginPos endPos toks e /= defaultExp
= Just ([loc1], pnt, pats, e, ds, (Match match))
| otherwise = checkES es
inMatch x = Nothing
--The selected sub-expression is in the rhs of a pattern-binding
inPat (pat@(Dec (HsPatBind loc1 ps (rhs@(HsBody e)) ds))::HsDeclP)
| locToExp beginPos endPos toks rhs /= defaultExp
= if isSimplePatBind pat
then Just ([loc1], patToPNT ps, [], e, ds, (MyPat pat))
else error "Please select the result of the function!"
inPat (pat@(Dec (HsPatBind loc1 ps (rhs@(HsGuard es)) ds))::HsDeclP)
= checkES es
where
checkES [] = Nothing
checkES ((s, e1 , e): es)
| locToExp beginPos endPos toks e /= defaultExp
= Just ([loc1], patToPNT ps, [], e, ds, (MyPat pat))
| otherwise = checkES es
inPat _ = Nothing