HaRe-0.6: refactorer/RefacSlicing.hs
-----------------------------------------------------------------------------
-- |
-- Module : RefacSlicing
-- Copyright : (c) Christopher Brown 2005
--
-- Maintainer : cmb21@kent.ac.uk
-- Stability : provisional
-- Portability : portable
--
-- This module contains a transformation for HaRe.
-- Symoblic Evaluation on tuples.
-- creates functions which evaluate tha expressions
-- within the return value of a function.
-- e.g.
--
-- @ f x y = (x, y) @
--
-- @ f1 x = x @
--
-- @ f2 y = y @
--
-----------------------------------------------------------------------------
module RefacSlicing where
import AbstractIO
import Maybe
import List
import RefacUtils
import RefacRedunDec
import SlicingUtils
data Patt = Match HsMatchP | MyPat HsDeclP | Def [Char]
refacSlicing 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 "refacSlicing"
-- 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
let newExp = locToExp (beginRow, beginCol) (endRow, endCol) tokList mod
let transExp = rewriteExpression exp newExp
if newExp == defaultExp
then do
error "Program slicing can only be performed on an expression."
else do
(wh', newExp') <- doRefac wh transExp
-- ((_,_), (tokList', mod')) <- applyRefac (checkCase exp newExp wh') (Just inscps, exps, mod, tokList) fileName
-- AbstractIO.putStrLn $ show (newExp, wh'')
(_,refWh) <- checkCase exp newExp wh'
-- (mod',((tokList',modified),_))<-doRemovingWhere fileName mod tokList exp newExp' wh'
((_,_), (tokList', mod')) <- applyRefac (doRemovingWhere exp newExp' refWh) (Just (inscps, exps, mod, tokList)) fileName
((_,m), (tokList'', mod'')) <- applyRefac (doRemoving1 exp newExp' wh) (Just (inscps, exps, mod', tokList')) fileName
-- ((_,_), (newTokList, newMod)) <- applyRefac (doTranslation exp transExp) (Just (inscps, exps, mod'', tokList'')) fileName
-- AbstractIO.putStrLn $ show tokList''
writeRefactoredFiles False [((fileName, True), (tokList'', mod''))]
AbstractIO.putStrLn "Completed.\n"
doTranslation e nT (_,_,mod)
= do
newMod <- update e nT mod
return newMod
sliceSubExp p old exp wh loc pnt pats (_,_, mod) = do
(decls, newExp) <- removeRedun wh exp
mod' <- updating p mod loc pnt pats newExp decls
return mod'
changeName newName (PNT (PN (UnQual _) (G modName _ optSrc)) Value s)
= PNT (PN (UnQual newName) (G modName newName optSrc)) Value s
updating (match@(Match x)) mod loc pnt pats rhs ds = do
mod' <- update x (newMatch loc pnt pats rhs ds) mod
return mod'
updating (pat@(MyPat x)) mod loc pnt pats rhs ds = do
mod' <- update x (newDecl loc pnt pats rhs ds) mod
return mod'
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] )
checkFreeInWhere :: [PName] -> [HsDeclP] -> [HsDeclP]
checkFreeInWhere [] _ = []
checkFreeInWhere _ [] = []
checkFreeInWhere (p:ps) list = (checkSinInWhere p list) ++ (checkFreeInWhere ps list)
where
checkSinInWhere :: PName -> [HsDeclP] -> [HsDeclP]
checkSinInWhere p [] = []
checkSinInWhere p (x:xs)
| defines p x = [x]
| otherwise = checkSinInWhere p xs
rewriteExpression :: HsExpP -> HsExpP -> HsExpP
rewriteExpression e@(Exp (HsInfixApp e1 o e2)) newExp
| findEntity newExp e1 = (rewriteExpression e1 newExp)
| findEntity newExp e2 = (rewriteExpression e2 newExp)
| otherwise = e
rewriteExpression (Exp (HsLet ds e)) newExp = (Exp (HsLet ds (rewriteExpression e newExp)))
rewriteExpression (Exp (HsLambda ds e)) newExp = (Exp (HsLambda ds newExp))
rewriteExpression (Exp (HsParen e1)) newExp = rewriteExpression e1 newExp
rewriteExpression e1 e2 = e2
{-|
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 _ = 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 "A complex pattern binding can not be generalised!"
inPat _ = Nothing