HaRe-0.6: refactorer/RefacDeForest.hs
module RefacDeForest(deforest) where
import PrettyPrint
import PosSyntax hiding(moduleName)
import Maybe
import TypedIds
import ScopeModule
import UniqueNames hiding (srcLoc)
import PNT
import TiPNT
import PFE0
import List
import RefacUtils
import AbstractIO
import Prelude hiding(putStrLn,putStr)
-- this refactoring trys to eliminate intermeidate list.
deforest args
= do let fileName= ghead "filename" args
modName <- fileNameToModName fileName
(inscps, exps, mod, tokList) <- parseSourceFile fileName
let (newDecs,oldPNs,newPNs) = unzip3( head(getHsMatch mod) )
(mod',((tokList',m),_)) <- doFuseCurrent mod tokList newDecs oldPNs newPNs fileName
clients<-clientModsAndFiles modName
let (clientsMod,clientFiles)= unzip clients
refactoredClients <- mapM (doFuseInClient tokList newDecs oldPNs newPNs ) clients
writeRefactoredFiles False $ ((fileName,m),(tokList',mod')):refactoredClients
where
simpDec mod = fromJust ( applyTP ( full_tdTP ( idTP `adhocTP` simplifyDecl) ) mod)
fil x mod = filter notInUsed x where
notInUsed:: HsDeclP -> Bool
notInUsed t = not (isDeclaredIn (getPN t) mod )
getHsMatch m = applyTU (full_tdTU (constTU [] `adhocTU` special ) ) m where
special x = do p <- simplifyDecl x
convertDec p
simpDec m = applyTP (full_tdTP (idTP `adhocTP` simplifyDecl) ) m
doFuseInClient tokList newDecs oldPNs newPNs (modName,fileName)
= do (inscps, exps, mod, tokList) <- parseSourceFile fileName
(mod',((tokList',m),_)) <- doFuseClient mod tokList newDecs oldPNs newPNs fileName
return ( (fileName,True),(tokList',mod'))
doFuseCurrent mod tokList newDecs oldPNs newPNs fileName
=runStateT (fus mod) (( tokList,unmodified), (-1000, 0)) where
fus mod =do mod' <- addDecl mod Nothing (fil newDecs mod , Nothing )True
replaceFold mod' oldPNs newPNs
--replace all : foldr f n (fb) -> fb_workder f n
doFuseClient mod tokList newDecs oldPNs newPNs fileName
= runStateT ( replaceFold mod oldPNs newPNs ) (( tokList,unmodified), (-1000, 0))
replaceFold mod oldPNs newPNs
= applyTP ( full_tdTP (idTP `adhocTP` convertFold) ) mod
where
convertFold a@(Exp(HsApp(Exp(HsApp (Exp(HsApp fol f )) n ) ) exp ) )
| (isFunc fol "foldr") && (findPNs oldPNs (strip exp) ) -- can be fused
= do newExp <- melt exp p newP f n
update a newExp a
| otherwise = return a
where
p = getPNFromExp (strip(exp))
newP = newPNs !! ( fromJust ( elemIndex p oldPNs))
convertFold a = return a
melt exp pn newPn f n = ( applyTP (full_tdTP (idTP `adhocTP` changeF)) exp)
where
changeF exp@(Exp(HsId(HsVar(PNT pName a b ) ) ))
| (pName== pn)= return (Exp(HsApp (Exp(HsApp (Exp(HsId(HsVar(PNT newPn a b)))) f )) n ))
| otherwise = return exp
changeF exp = return exp
getCataFun = applyTU (full_tdTU ( constTU[] `adhocTU` recToCata) )
strip (Exp(HsApp exp1 exp2 ) ) = strip exp1
strip a@(Exp(_)) = a
build [] = nameToExp "n"
build (x:xs) = Exp(HsApp (Exp(HsApp (nameToExp "c") x)) (build xs) )
--get PN from a Decl
getPN ( Dec(HsFunBind t ( (HsMatch src (PNT pn _ _) pat body loc):xs))) = pn
colListCons :: HsIdentI PNT -> [ [HsIdentI PNT]]
colListCons x = if (isListCons x) then return [x] else return []
-- takes an Exp and return itself if it is an (:) list constructor
isListCons (HsCon (PNT (PN (UnQual ":") (G (PlainModule "Prelude") ":"_ )) _ _)) = True
isListCons _ = False
--check if this Exp has a fun call `name`
isFunc f@(Exp (HsId (HsVar (PNT (PN (UnQual fName) _) _ _)))) name = (fName == name)
isFunc _ _= False
bodyHasCons (HsBody(e)) = expHasCons e
expHasCons (Exp (HsInfixApp _ cons _ )) = isListCons cons
expHasCons (Exp ( HsApp (Exp(HsApp (Exp(HsId(cons))) exp1 )) exp2 ) ) = isListCons cons
expHasCons (Exp(HsList _)) = True
expHasCons _ = False
modBody (HsBody e) = (HsBody (modExp e))
modExp (Exp (HsInfixApp exp1 cons exp2)) = (addWrapper exp1 exp2)
modExp (Exp ( HsApp (Exp(HsApp cons exp1)) exp2 ) ) = (addWrapper exp1 exp2)
modExp (Exp(HsList x )) = build x
modExp a = a
addWrapper exp1 exp2 = Exp (HsApp (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "c") (S loc0)) Value (N (Just loc0)))))) ( exp1 ))) (exp2 ))
getPnFromPNT (PNT pn _ _ ) = pn
getPNFromExp exp = ( fromJust $ applyTU ( once_tdTU ( failTU `adhocTU` idPN) ) exp) where
idPN :: PName -> Maybe PName
idPN a = Just a
--convertDec takes a Dec check if we can convert it into cata form if not simply return itself
--convertDec :: HsDeclP -> [ [ (HsDeclP,HsName,HsName) ] ]
convertDec d@( Dec(HsFunBind t [m@(HsMatch src pnt pat body loc)]))=
if isFormed body then return [ ( (Dec (HsFunBind t [convertMatch m] ) ), getPnFromPNT pnt, getPnFromPNT $ change pnt)]
else return [] where
isFormed ((HsBody (Exp (HsCase exp1 alt) ))) = checkAltL alt where
checkAltL [] = True
checkAltL (x:xs) = (checkAlt x) && (checkAltL xs) where
checkAlt (HsAlt src p bo d) = bodyHasCons bo
isFormed ((HsBody(e@(Exp( HsIf e1 e2 e3) ) ))) = checkIfExp e where
checkIfExp (Exp(HsIf e1 e2 e3 )) = expHasCons e2 && checkIfExp e3
checkIfExp e = expHasCons e
--checkIfExp _ = True
isFormed _ = False
-- add "_worker" to the function name in PNT
change p@(PNT ( PN (UnQual f) (G v1 f1 v2 ) )v3 pat ) = PNT (PN(UnQual (f++"_worker")) (G v1 (f++"_worker") v2 )) v3 pat
change p = p
convertMatch (HsMatch src pnt pat body loc) = HsMatch src (change pnt) ([nameToPat "c",nameToPat "n"] ++ pat) (convertBody body) loc where
convertBody (HsBody(Exp (HsCase exp alt))) = (HsBody(Exp(HsCase exp (convertAlt alt))))
convertBody (HsBody(Exp (HsIf e1 e2 e3))) = (HsBody(Exp( HsIf e1 e2' e3'))) where
e2' = modIfExp e2
e3' = modIfExp e3
modIfExp (Exp(HsIf a1 a2 a3 )) = (Exp(HsIf a1 (changeFToF (modExp a2) pnt) (modIfExp a3) ))
modIfExp e = changeFToF (modExp e) pnt
convertAlt [] = []
convertAlt (x :xs) = (con x) : (convertAlt xs)
con (HsAlt src p bo d ) = changeFToF (HsAlt src p (modBody bo)d) pnt
changeFToF m p = fromJust $ (applyTP( full_tdTP ( idTP `adhocTP` changeFToF# ) )) m where
changeFToF# :: HsExpP -> Maybe HsExpP
changeFToF# e@(Exp(HsId(HsVar pnt))) = if (p==pnt) then
return ( Exp(HsApp (Exp(HsApp (Exp(HsId(HsVar (change pnt)))) (nameToExp "c"))) (nameToExp "n") ))
else return e
changeFToF# a = Just a
convertDec d = return []
-- from recursion to cataformlism
recToCata :: HsDeclP -> [[HsDeclP]]
recToCata d@( Dec(HsFunBind t [m@(HsMatch src pnt pat body loc)])) = if (check body) then return [d] else return [] where
check b@(HsBody (Exp (HsCase exp1 alt) )) = checkAlt alt
check _ = False
checkAlt [ (HsAlt src1 (Pat (HsPTuple _ p1)) bo1 d1), (HsAlt src2 (Pat (HsPTuple _ p2)) bo2 d2) ] = doCheck p1 p2
checkAlt _ = False
doCheck p1 p2 = (match ==1 )where
match = count p1 p2
count (x:xs) (y:ys)= if (eq x y) then 0 + count xs ys
else if (isEmptyPList x && isConsPat y) ||
(isConsPat x && isEmptyPList y) then count xs ys + 1
else 2 + count xs ys
count _ _ = 0
isConsPat (Pat (HsPParen (Pat (HsPInfixApp a cons b)))) = isListPNT cons
isConsPat _ = False
-- takes an Exp and return itself if it is an (:) list constructor
isListPNT (PNT (PN (UnQual ":") (G (PlainModule "Prelude") ":"_ )) _ _) = True
isListPNT _ = False
isEmptyPList (Pat (HsPList _ [])) = True
isEmptyPList _ = False
eq (Pat (HsPId (HsVar (PNT (PN pn1 _) _ _)))) (Pat (HsPId (HsVar (PNT (PN pn2 _) _ _)))) = pn2==pn1
eq _ _ = False
recToCata _ = return []