HaRe-0.6: refactorer/RefacMerge.hs
-----------------------------------------------------------------------------
-- |
-- Module : RefacMerge
-- Copyright : (c) Christopher Brown 2006
--
-- Maintainer : cmb21@kent.ac.uk
-- Stability : provisional
-- Portability : portable
--
-- This module contains a transformation for HaRe.
-- Merging definitions together.
module RefacMerge where
import System.IO.Unsafe
import PrettyPrint
import RefacTypeSyn
import RefacLocUtils
-- import GHC (Session)
import Data.Char
import GHC.Unicode
import AbstractIO
import Maybe
import List
import RefacUtils
import RefacRedunDec
import SlicingUtils
import Directory
import LocalSettings
data FunEntity = Guard [HsPatP] [(SrcLoc, HsExpP, HsExpP)] [HsDeclP] PNT | Match [HsPatP] HsExpP [HsDeclP] PNT | Null
deriving (Eq, Show)
type Fun = [ FunEntity ]
-- we can "pair" an arbitrary number of matches together so
-- we can't use a tuple. We don't know the number of
-- function to fuse!
type PairFun = [ Fun ]
refacMerge args
= do
let fileName = args!!0
name = args!!1
AbstractIO.putStrLn "refacMerge"
fileContent <- AbstractIO.readFile mergeFilePath
AbstractIO.removeFile mergeFilePath
AbstractIO.putStrLn "Cache flushed."
unless (isVarId name)
$ error "The new name is invalid!\n"
modName1 <- fileNameToModName fileName
let modName = modNameToStr modName1
modInfo@(inscps, exps, mod, tokList) <- parseSourceFile fileName
inscopeNames <- hsFDNamesFromInside mod
unless (not (name `elem` ((\(x,y) -> x ++ y) inscopeNames)))
$ error ("the use of the name: " ++ name ++ " is already in scope!")
let parse = force (parseFile fileContent mod)
let n = (parseName fileContent mod)
let extractedDecs = map fst (map extractDecs parse)
-- b is the boolean value for whether we
-- are fusing together functions within a where clause or not.
-- b == True = not in where clause
-- b == False = in where clause
let b = or (map snd (map extractDecs parse))
-- let extractedDecs' = pad extractedDecs
newDecl <- doFusing fileName extractedDecs b parse modName mod name
if b
then do
res3 <- applyRefac (addDecls1 newDecl) (Just (inscps, exps, mod, tokList)) fileName
writeRefactoredFiles True [res3]
(inscps2, exps2, mod2, tokList2) <- parseSourceFile fileName
let fusedDecl = declToName newDecl
let newRefactoredDecls1 = hsDecls mod2
let newRefactoredDecls2 = definingDecls (map (declToPName [fusedDecl]) newRefactoredDecls1) newRefactoredDecls1 False False
-- AbstractIO.putStrLn "parsed again"
sigs <- getSig fileName modName fusedDecl
res <- applyRefac (addTypes (map (declToPName [fusedDecl]) newRefactoredDecls1) [sigs]) (Just (inscps2, exps2, mod2, tokList2)) fileName
-- AbstractIO.putStrLn $ show res
writeRefactoredFiles True [res]
(inscps5, exps5, mod5, tokList5) <- parseSourceFile fileName
--(mod',((tokList'',modified),_))<-(doCommenting ( (map (declToPName [fusedDecl]) newRefactoredDecls1))) fileName mod5 tokList5
--writeRefactoredFiles True [((fileName, True), (tokList'', mod'))]
AbstractIO.putStrLn "Completed."
else do
-- where clause
-- recurse through each declaration selected.
-- replace the RHS with a call to the newly
-- created function
let selectedDecs = map extractDecs' parse
res3 <- applyRefac (addDecls2 n newDecl) (Just (inscps, exps, mod, tokList)) fileName
writeRefactoredFiles True [res3]
(inscps3, exps3, mod3, tokList3) <- parseSourceFile fileName
--
-- AbstractIO.putStrLn $ show newMod
res4 <- applyRefac (renameCallInSelected selectedDecs name) (Just (inscps3,exps3, mod3, tokList3)) fileName
writeRefactoredFiles True [res4]
-- writeRefactoredFiles False [((fileName, m), (newToks, newMod))]
AbstractIO.putStrLn "Completed."
doFusing fileName extractedDecs b parse modName mod name
= do
(decl, newDecl) <- doFusing' fileName b extractedDecs parse modName mod name
-- we need to recurse into the where clauses and perform
-- a fusion if necessary.
-- x <- fuseWheres decl modName mod ses1
return decl
fuseExprs :: HsExpP -> HsExpP
fuseExprs exp@(Exp (HsTuple [e1,e2]))
| (isFst e1 && isSnd e2) && (extractCall e1 == extractCall e2) = extractCall e1
| otherwise = exp
where
isFst :: HsExpP -> Bool
isFst (Exp (HsInfixApp e1 o e2))
= (render.ppi) e1 == "fst"
isFst x = False
isSnd :: HsExpP -> Bool
isSnd (Exp (HsInfixApp e1 o e2))
= (render.ppi) e1 == "snd"
isSnd x = False
extractCall :: HsExpP -> HsExpP
extractCall (Exp (HsInfixApp e1 s e2)) = e2
extractCall x = x
fuseExprs e = e
fuseWheres d@(Dec (HsFunBind loc0 ms)) modName mod ses1
= do matches <- lookInMatches ms
return (Dec (HsFunBind loc0 matches))
where
lookInMatches [] = return ([]::[HsMatchP])
lookInMatches (m@(HsMatch l n p exp@(HsBody exp'@(Exp (HsTuple [e,e1]))) ds):ms)
= do
let declNames = filter (/="") (map declToName ds)
(inscopeNames, inscopeNames2) <- hsFDNamesFromInside d
let name = ((expAppName e) ++ (expAppName e1))
let newName = mkNewName name (inscopeNames ++ inscopeNames2) 1
AbstractIO.putStrLn $ show (expAppName e)
if (expAppName e) `elem` declNames && (expAppName e1) `elem` declNames
then do
-- find the decl associated with e and e1
let decl1 = findDecl (expAppName e) ds
let decl2 = findDecl (expAppName e1) ds
let extractedDecs = map extractDecs [Right (decl1, False), Right (decl2, False)]
-- decl' <- doFusing extractedDecs False [Right decl1, Right decl2] modName ses1 mod newName
newExp <- renameFusionInstances exp' newName (map declToPName2 (map extractDecs' [Right (decl1, False), Right (decl2,False)]))
rest <- lookInMatches ms
-- createTypeSig (retieveTypeSig
-- return ((HsMatch l n p (HsBody newExp)
return ((HsMatch l n p (HsBody newExp) ds) : rest)
else do
AbstractIO.putStrLn (">" ++ (show e))
rest <- lookInMatches ms
AbstractIO.putStrLn $ show rest
return (m : rest)
lookInMatches (m:ms)
= do
rest <- lookInMatches ms
return (m : rest)
rmDecls :: [HsDeclP] -> (HsDeclP, HsDeclP) -> [HsDeclP]
rmDecls [] _ = []
rmDecls (d@(Dec (HsTypeSig _ i _ _)):ds) (d1,d2)
| declToPName2 d1 `elem` (map pNTtoPN i) = rmDecls ds (d1, d2)
| declToPName2 d2 `elem` (map pNTtoPN i) = rmDecls ds (d1, d2)
| otherwise = d : (rmDecls ds (d1, d2))
rmDecls (d:ds) (d1, d2)
| d == d1 = rmDecls ds (d1,d2)
| d == d2 = rmDecls ds (d1,d2)
| otherwise = d : (rmDecls ds (d1,d2))
findDecl :: String -> [HsDeclP] -> HsDeclP
findDecl _ [] = error "error in findDecl!"
findDecl name (d:ds)
| (declToName d) == name = d
| otherwise = findDecl name ds
expAppName :: HsExpP -> String
expAppName (Exp (HsApp e1 e2)) = expAppName e1
expAppName e@(Exp (HsId e1)) = pNtoName (expToPN e)
expAppName x = ""
doFusing' fileName b extractedDecs parse modName mod name
= do
let pairedDecs = pairMatches extractedDecs
if b
then do
converged <- isConvergeArguments fileName modName pairedDecs
newRhs' <- mapM ( tidyLetClauses mod converged) pairedDecs
let newDecl = createDecl newRhs' name
decl' <- renameFusionInstances newDecl name (map declToPName2 (map extractDecs' parse))
return (decl', newDecl)
else do
newRhs' <- mapM ( tidyLetClauses mod True) pairedDecs
let newDecl = createDecl newRhs' name
decl' <- renameFusionInstances newDecl name (map declToPName2 (map extractDecs' parse))
return (decl', newDecl)
-- renameFusionInstances :: (MonadState (([PosToken], Bool), t1) m) => HsDeclP -> String -> PName -> m HsDeclP
renameFusionInstances d _ [] = error "No functions have been selected for fusion!"
renameFusionInstances d n [a,b]
= do
dec <- renamePNNoState' a ("fst $ " ++ n) d
dec2 <- renamePNNoState' b ("snd $ " ++n) dec
return dec2
renameFusionInstances _ _ (x:xs) = error "Only two functions may be fused together!"
force :: Eq a => a -> a
force x = if x == x then x else x
{- tidy up arrangments of let clauses.
viz:
f x y = (let ls = x + 1 in ls, let rs = y - 1 in rs)
should be:
f x y = let ls = x + 1 ; rs = y - 1 in (ls, rs)
The idea is that it takes a list of expressions which are
fused together to form a tuple -- or a list of let declarations
and a tuple as a body.
-}
isDupDec :: [String] -> Bool
isDupDec [] = False
isDupDec (x:xs) = (x `elem` xs) || (isDupDec xs)
getDupDec :: [String] -> String
getDupDec [] = ""
getDupDec (x:xs)
| x `elem` xs = x
| otherwise = getDupDec xs
-- tidyLetClauses :: (Monad m, Term t) => t -> Bool -> Fun -> m FunEntity
tidyLetClauses _ _ [] = return Null
tidyLetClauses mod True (m@(Guard p (g@(s,e1,_):gs) ds pnt) : es)
= do
let allPats = extractPats' (m:es)
if all (==(head allPats)) allPats
then do
let guards = filterGuards (m:es)
let guards2 = map (map (\(x,y,z) -> y)) guards
let decs = map filterLet' guards
let exps = pairExps (map filterExp' guards)
let guardExp = filterGuardExp (g:gs)
-- let (decs, exps) = (filterLet (m:es), (filterExp (m:es)))
let ds' = filterDec (m:es)
let dsNames = filter (/="") (map declToName2 ds')
when (isDupDec dsNames) $ error ( "Please rename " ++ (getDupDec dsNames) ++ " as it conflicts during the merge." )
when (all (/=(head guards2)) (tail guards2))
$ error "The guards between the two functions do not match!"
-- AbstractIO.putStrLn $ show (decs, length decs)
if length (filter (/=[]) decs) > 0
then do
let returnGuard = createGuardLet guardExp decs exps
return (Guard p returnGuard ds' pnt)
else do
let returnGuard = createGuard guardExp exps
return (Guard p returnGuard ds' pnt)
-- return (Match p gs' ds' pnt)
else do
error "The patterns between the functions are not the same set! The patterns must be the same and have the same type."
where
pairExps :: [ [HsExpP] ] -> [ (HsExpP, HsExpP) ]
pairExps [] = []
pairExps [x::[HsExpP],y::[HsExpP]] = zip x y
pairExps x = error "Only two functions may be fused together!"
createGuardLet :: [HsExpP] -> [ [HsDeclP] ] -> [ (HsExpP, HsExpP) ] -> [ (SrcLoc, HsExpP, HsExpP) ]
createGuardLet [] [] [] = []
createGuardLet (e:ess) (d:ds) ((x,y):es)
= (s, e, (Exp (HsLet d (Exp (HsTuple (x:[y])))))) : (createGuardLet ess ds es)
createGuard :: [HsExpP] -> [ (HsExpP, HsExpP) ] -> [ (SrcLoc, HsExpP, HsExpP) ]
createGuard [] [] = []
createGuard (e:ess) ((x,y):es) = (s,e, (Exp (HsTuple (x:[y])))) : (createGuard ess es)
tidyLetClauses mod True (m@(Match p e ds pnt) : es)
= do
-- find Let Clauses
let allPats = extractPats' (m:es)
if all (==(head allPats)) allPats
then do
let (decs, exps) = (filterLet (m:es), filterExp (m:es))
let ds' = filterDec (m:es)
let dsNames = (filter (/="") (map declToName2 ds'))
when (isDupDec dsNames) $ error ( "Please rename " ++ (getDupDec dsNames) ++ " as it conflicts during the merge." )
if length decs > 0
then do
return (Match p (Exp (HsLet decs (Exp (HsTuple exps)))) ds' pnt)
else do
return (Match p (Exp (HsTuple exps)) ds' pnt)
else do
error "The patterns between the functions are not the same set! The patterns must be the same and have the same type."
tidyLetClauses _ False _ = error "The types between the functions to be fused to do match. Please change the types first so that the arguments can converge."
{- tidyLetClauses mod False (m@(Match p e ds pnt) : es)
= do
let (decs, exps) = (filterLet (m:es), filterExp (m:es))
if length decs > 0
then do
let letExp = (Exp (HsLet decs (Exp (HsTuple exps))))
(params, exps', ds') <- renameArgs 1 (extractPats (m:es)) letExp ds mod
return (Match params exps' ds' pnt)
else do
let letExp = (Exp (HsTuple exps))
(params, exps', ds') <- renameArgs 1 (extractPats (m:es)) letExp ds mod
return (Match params exps' ds' pnt) -}
extractPats :: Fun -> [ [HsPatP] ]
extractPats [] = []
extractPats ((Match p _ _ _):ms) = p : (extractPats ms)
extractPats ((Guard p _ _ _):ms) = p : (extractPats ms)
extractPats' :: Fun -> [ [String] ]
extractPats' [] = []
extractPats' ((Match p _ _ _):ms) = (map pNtoName (hsPNs p)) : (extractPats' ms)
extractPats' ((Guard p _ _ _):gs) = (map pNtoName (hsPNs p)) : (extractPats' gs)
filterGuardExp :: [(SrcLoc, HsExpP, HsExpP)] -> [HsExpP]
filterGuardExp [] = []
filterGuardExp ((_,e,_):gs) = e : (filterGuardExp gs)
filterGuards :: Fun -> [ [(SrcLoc, HsExpP, HsExpP)] ]
filterGuards [] = []
filterGuards ((Guard _ g _ _):gs) = (rmAllLocs g) : (filterGuards gs)
filterGuards (m:ms) = filterGuards ms
filterDec :: Fun -> [HsDeclP]
filterDec [] = []
filterDec ((Match p e ds pnt):es)= ds ++ (filterDec es)
filterDec ((Guard p g ds pnt):es) = ds ++ (filterDec es)
filterLet' :: [ (SrcLoc, HsExpP, HsExpP) ] -> [HsDeclP]
filterLet' [] = []
filterLet' ((_, _, e@(Exp(HsLet ds _))):gs) = ds ++ (filterLet' gs)
filterLet' (g:gs) = filterLet' gs
filterLet :: Fun -> [HsDeclP]
filterLet [] = []
filterLet ((Match p e@(Exp (HsLet ds _)) _ pnt) : es) = ds ++ (filterLet es)
filterLet ((Match p e ds pnt):es)= filterLet es
filterLet ((Guard p gs ds pnt):es) = (findLetInGuard gs) ++ (filterLet es)
where
findLetInGuard [] = []
findLetInGuard ((_, _, (Exp (HsLet ds _))):gs)
= ds ++ (findLetInGuard gs)
findLetInGuard ((_,_, e):gs) = findLetInGuard gs
filterExp' :: [ (SrcLoc, HsExpP, HsExpP) ] -> [HsExpP]
filterExp' [] = []
filterExp' ((_,_, (Exp (HsLet _ e))):es) = e : (filterExp' es)
filterExp' ((_,_, e):es) = e : (filterExp' es)
filterExp :: Fun -> [HsExpP]
filterExp [] = []
filterExp ((Match p (Exp (HsLet _ e)) ds pnt ): es) = e : (filterExp es)
filterExp ((Match p e ds pnt):es) = e : (filterExp es)
filterExp ((Guard p gs ds pnt):es) = (filterExpGuard gs) ++ (filterExp es)
where
filterExpGuard [] = []
filterExpGuard ((_, _, (Exp (HsLet _ e))):gs) = e : (filterExpGuard gs)
filterExpGuard ((_,_, e):gs) = e : (filterExpGuard gs)
renameArgs index params rhs wheres t
= do
-- AbstractIO.putStrLn $ show (map toRelativeLocs (concat params))
let dups = findDups (concat params)
(newPats, newExps, newDS) <- doRenaming index dups (concat params) rhs wheres t
return (newPats, newExps, newDS)
doRenaming :: (Monad m, MonadPlus m, Term t) => Int -> [PName] -> [HsPatP] -> HsExpP -> [HsDeclP] -> t -> m ([HsPatP],HsExpP, [HsDeclP])
doRenaming _ [] a b c _ = return (a,b, c)
doRenaming index (p:ps) pats exps ds t
= do
-- names <- mapM (addName t) (concat exps)
names <- addName t exps
newPat <- mapM (renamePNNoState p names index) pats
-- newExp <- mapM (mapListListM (renamePNNoState p (concat names) index)) exps
newExp <- renamePNNoState p names index exps
-- newDS <- mapM (mapListListM (renamePNNoState p names index)) ds
newDS <- renamePNNoState p names index ds
-- newExp <- mapM (renamePNNoState p name) exps
rest <- doRenaming (index+1) ps newPat newExp newDS t
return rest
addName mod e = do
names <- hsVisibleNames e mod
return names
-- mapListListM :: [HsExpP] -> m [ [HsExpP] ]
mapListListM f e
= mapM f e
renamePNNoState oldPN names index t
= applyTP (full_tdTP (adhocTP idTP rename)) t
where
rename (pnt@(PNT pn ty (N (Just (SrcLoc fileName c row col)))))
| (pn == oldPN) && (srcLoc oldPN == srcLoc pn)
= return (PNT (replaceNameInPN Nothing pn (mkNewName (pNtoName oldPN) names index )) ty (N (Just (SrcLoc fileName c row col))))
rename x = return x
renamePNNoState' oldPN name t
= applyTP (full_tdTP (adhocTP idTP rename)) t
where
rename (pnt@(PNT pn ty (N (Just (SrcLoc fileName c row col)))))
| (pn == oldPN) && (srcLoc oldPN == srcLoc pn)
= return (PNT (replaceNameInPN Nothing pn name) ty (N (Just (SrcLoc fileName c row col))))
rename x = return x
renameNameNoState' oldPN name t
= applyTP (once_tdTP (adhocTP failTP rename)) t
where
rename (n::String)
| n == oldPN
= return name
rename x = mzero
findDups :: [HsPatP] -> [PName]
findDups [] = []
findDups (x:xs) -- do any elements of x occur through out xs?
| pNtoName (patToPN x) `elem` (map (pNtoName.patToPN) xs) = (patToPN x) : findDups xs
| otherwise = findDups xs
doCommenting (x:xs) fileName mod tokList
= runStateT (applyTP ((once_tdTP (failTP `adhocTP` (rmInMod (x:xs) )
))) mod)
((tokList,unmodified),fileName)
where
--1. The definition to be removed is one of the module's top level declarations.
rmInMod [] mod = return mod
rmInMod (p:ps) (mod@(HsModule loc name exps imps ds):: HsModuleP)
= do ds'<-commentOutTypeSig p ds
res2 <- rmInMod ps (HsModule loc name exps imps ds')
return res2
addTypes _ [] (_,_,mod) = return mod
addTypes (x:xs) (y:ys) (a,b,mod) = do
mod' <- addTypeSigDecl mod (Just x) ([y], Nothing) True
-- commentOutTypeSig x (y:ys)
res <- addTypes xs ys (a,b,mod')
return mod'
replaceInE :: (Monad m, MonadPlus m) => PNT -> String -> HsExpP -> m HsExpP
replaceInE origName newName e
= applyTP (once_tdTP (adhocTP idTP rename')) e
where
rename' (e'@(Exp (HsId (HsVar x)))::HsExpP)
| pNTtoName x == pNTtoName origName = return (Exp (HsId (HsVar (nameToPNT newName) )))
| otherwise = return e'
rename' e@(Exp (HsApp e1 e2))
= do res1 <- rename' e1
res2 <- rename' e2
return (Exp (HsApp res1 res2))
rename' e = return e
cleanWhere :: (Monad m, MonadPlus m) => HsDeclP -> [PNT] -> String -> m HsDeclP
cleanWhere (Dec (HsPatBind loc p (HsBody e) ds)) names theName
= do res2 <- (cleanWhere2 ds names theName)
return (Dec (HsPatBind loc p (HsBody e) res2))
cleanWhere (Dec (HsFunBind loc (d:dss))) names theName
= do res2 <- (cleanMatches (d:dss) names theName)
return (Dec (HsFunBind loc res2))
where
cleanMatches :: (Monad m, MonadPlus m) => [HsMatchP] -> [PNT] -> String -> m [HsMatchP]
cleanMatches [] _ _ = return []
cleanMatches ((HsMatch l i1 ps (HsBody e) ds):ms) names theName
= do res1 <- (cleanWhere2 ds names theName)
res2 <- (cleanMatches ms names theName)
return ((HsMatch l i1 ps (HsBody e) res1 ): res2)
cleanWhere2 :: (Monad m, MonadPlus m) => [HsDeclP] -> [PNT] -> String -> m [HsDeclP]
cleanWhere2 [] _ _ = return []
cleanWhere2 x [] _ = return x
cleanWhere2 (de@(Dec (HsPatBind loc p (HsBody e) ds)):dss) (name:names) theName
| pNTtoName (getNameFromExp e) == (pNTtoName name) = do newPats' <- newPats
newBody <- replaceInE (getNameFromExp e) theName e
let filteredDecs = filterDecs dss names
return ((Dec (HsPatBind loc newPats' (HsBody newBody) ds)):filteredDecs)
| otherwise = do res <- (cleanWhere2 dss names theName)
return (de : res )
where
newPats = do res <- findRest dss names
return (Pat (HsPTuple loc0 (p: res)))
findRest _ [] = return []
findRest [] _ = return []
findRest (de@(Dec (HsPatBind loc p (HsBody e) ds)):dss) (name:names)
| pNTtoName (getNameFromExp e) == (pNTtoName name) = do res <- (findRest dss names)
return (p : res)
| otherwise = do res <- findRest dss names
return res
filterDecs [] _ = []
filterDecs (de@(Dec (HsPatBind loc p (HsBody e) ds)):dss) (name:names)
| (getNameFromExp e) `elem` (name:names) = filterDecs dss (name:names)
| otherwise = de : (filterDecs dss (name:names))
getNameFromExp (Exp (HsApp e1 e2))
= getNameFromExp e1
getNameFromExp e1
= expToPNT e1
addDecls1 x (_,_,mod) = do
mod' <- addDecl mod Nothing ([x], Nothing) True
return mod'
addDecls2 n x (_,_,mod) = do
let newDec = convertExpr x
mod' <- doAdding newDec n mod
return mod'
where
doAdding x n mod = applyTP (once_tdTP (failTP `adhocTP` worker)) mod
where
worker (y::HsDeclP)
| y == n = addDecl n Nothing ([x], Nothing) False
worker _ = mzero
convertExpr :: HsDeclP -> HsDeclP
convertExpr (Dec (HsPatBind loc0 pat (HsBody e) ds))
= (Dec (HsPatBind loc0 pat (HsBody (fuseExprs e)) ds))
convertExpr (Dec (HsFunBind loc0 ms))
= (Dec (HsFunBind loc0 (newMatches ms)))
where
newMatches [] = []
newMatches (m@(HsMatch loc0 x pats (HsBody e) ds):ms)
= (HsMatch loc0 x pats (HsBody (fuseExprs e)) ds) : (newMatches ms)
newMatches (m:ms) = m : (newMatches ms)
convertExpr d = d
renameCallInSelected [d1, d2] name (_,_,mod)
= applyTP (stop_tdTP (failTP `adhocTP` worker)) mod
where
worker d@(Dec (HsPatBind loc0 pat (HsBody e) ds))
| d == d1 = do
newDec <- update e (Exp (HsInfixApp (nameToExp "fst") (nameToIdent "$") (nameToExp name))) d
return newDec
| d == d2 = do
newDec <- update e (Exp (HsInfixApp (nameToExp "snd") (nameToIdent "$") (nameToExp name))) d
return newDec
worker d@(Dec (HsFunBind loc0 ms))
| d == d1 = do matches <- editMatches ms "fst"
return (Dec (HsFunBind loc0 matches))
| d == d2 = do matches <- editMatches ms "snd"
return (Dec (HsFunBind loc0 matches))
where
editMatches [] _ = return []
editMatches (m@(HsMatch loc0 _ pats (HsBody e) ds):ms') par
= do
let newPats = map (pNtoExp . patToPN) pats
newMatch <- update e ((Exp (HsInfixApp (nameToExp par) (nameToIdent "$") (createFunc' (nameToExp name ) newPats ) ))) m
rest <- editMatches ms' par
return (newMatch : rest)
worker _ = mzero
-- | y == n = addDecl n Nothing ([x], Nothing) False
createDecl :: Fun -> String -> HsDeclP
{-createDecl ((Match [] exps ds _):ms) name
= (Dec (HsPatBind loc0 (nameToPat name) (HsBody exps) (concat ds))) -}
createDecl (m:ms) name
= (Dec (HsFunBind loc0 (createMatches (m:ms) )))
where
createMatches [] = []
createMatches ((Guard p guards d _):gs)
=
(HsMatch loc0 (nameToPNT name) p (HsGuard guards) d) : (createMatches gs)
createMatches ((Match p e d _):ms)
=
(HsMatch loc0 (nameToPNT name) p (HsBody e) d) : (createMatches ms)
extractDecs :: Either String (HsDeclP, Bool) -> (Fun, Bool)
extractDecs dec
= do
case dec of
Left errMsg -> error errMsg
Right (decl, b) -> extractDecl (decl, b)
extractDecs' :: Either String (HsDeclP, Bool) -> HsDeclP
extractDecs' dec
= do
case dec of
Left errMsg -> error errMsg
Right (decl,_) -> decl
-- pad :: [ [a] ] -> [ [a] ]
count list = maximum ( map length list )
pad list = map (pad' (count list)) list
where
pad' count entry = entry ++ (replicate count (head entry))
{- converge arguments attemps to converge the arguments of the pairs where ever possible.
The selected functions must have the same set of patterns, if not then
convergeArguments returns an error. Otherwise, the types of each function are taken,
if the types match then only use the first set of arguments. Otherwise, do nothing.
It is sensible to let the user instantiate patterns so that a more general instance converges
with a more specific type. -}
{-
data FunEntity = Match [HsPatP] HsExpP [HsDeclP] PNT | Null
deriving (Eq, Show)
type Fun = [ FunEntity ]
-- we can "pair" an arbitrary number of matches together so
-- we can't use a tuple. We don't know the number of
-- function to fuse!
type PairFun = [ Fun ] -}
-- convergeArguments :: (Monad m) => String -> GHC.Session -> PairFun -> m Bool
isConvergeArguments _ _ [] = return False
isConvergeArguments fileName modName (ent:ents)
= do -- entType <- typeOf modName ses ent
entsType <-typeOf fileName modName ent
AbstractIO.putStrLn $ show entsType
-- AbstractIO.putStrLn $ show (map hsPNs (settleTypes entsType))
--let res = myAll (map pNtoName (map hsPNs (settleTypes entsType)))
let res = myAll entsType
return res
where
-- myAll :: Eq a => [a] -> Bool
myAll :: [ [String] ] -> Bool
myAll [] = False
myAll (l:ls) = all (==l) ls
settleType :: HsDeclP -> HsDeclP
settleType (Dec (HsTypeSig x _ y types))
= (Dec (HsTypeSig x [] y types))
typeOf :: (Monad m) => String -> String -> [FunEntity] -> m [ [String] ]
typeOf fileName modName [] = return []
typeOf fileName modName (m:ms)
= do
sig <- getSigOmitLast modName (nameFromMatch m) fileName
let sig' = hsPNs (settleType sig)
let sig'' = map pNtoName sig'
sigs <- typeOf fileName modName ms
return (sig'' : sigs)
nameFromMatch :: FunEntity -> String
nameFromMatch (Match _ _ _ pnt) = pNTtoName pnt
nameFromMatch Null = ""
pairMatches :: [ Fun ] -> PairFun
pairMatches [] = []
pairMatches [ e] = [ e ]
pairMatches (e:es)
= ((take 1 e) ++ (concat (map (take 1) es))) : (pairMatches (filter (/=[]) (((gtail "e" e):(map (drop 1) es)))))
extractDecl :: (HsDeclP, Bool) -> (Fun, Bool)
-- extractDecl :: HsDeclP -> ( [[HsPatP]], [HsExpP], [HsDeclP] , PNT)
extractDecl (d@(Dec (HsPatBind loc p (HsBody e) ds)),b) = ([Match [] e ds (patToPNT p)],b)
extractDecl ((Dec (HsFunBind loc (d:dss ))),b) = (extractMatches (d:dss),b)
where
extractMatches [] = []
extractMatches ((HsMatch l i1 ps (HsBody e) ds):ms)
= (Match ps e ds i1) : extractMatches ms
extractMatches ((HsMatch l i1 ps (HsGuard g) ds):ms)
= (Guard ps g ds i1) : extractMatches ms
{-
= ((ps : ps2) , (e : e2) , (ds ++ ds2), i1)
where
(ps2, e2, ds2, _) = extractMatches ms -}
-- parseFile :: String -> HsModuleP -> [Either String (HsDeclP, Bool)]
parseName [] _ = error "error in parseName!"
parseName ('>':xs) mod = checkCursor' fileName (read row) (read col) mod
where
(fileName, rest) = parseFileName xs
(row, rest2) = parseRow rest
(col, rest3) = parseCol rest2
parseFile :: String -> HsModuleP -> [Either String (HsDeclP, Bool)]
parseFile [] _ = []
parseFile ('>':xs) mod = (checkCursor fileName (read row) (read col) mod) : (parseFile (tail rest3) mod)
where
(fileName, rest) = parseFileName xs
(row, rest2) = parseRow rest
(col, rest3) = parseCol rest2
parseFileName :: String -> (String, String)
parseFileName [] = ([], [])
parseFileName xs = ((takeWhile (/= '<') xs), (dropWhile (/= '<') xs))
parseRow :: String -> (String, String)
parseRow [] = ([], [])
parseRow xs = ((takeWhile (/= '%') (tail xs')), dropWhile (/= '%') (tail xs'))
where
xs' = dropWhile (/= '%') xs
parseCol :: String -> (String, String)
parseCol [] = ([], [])
parseCol xs = ((takeWhile (/= '&') (tail xs') ), dropWhile (/= '&') (tail xs') )
where
xs' = dropWhile (/= '&') xs
--check whether the cursor points to the beginning of the datatype declaration
--taken from RefacADT.hs
checkCursor :: String -> Int -> Int -> HsModuleP -> Either String (HsDeclP, Bool)
checkCursor fileName row col mod
= case locToPName of
(Nothing, _) -> Left ("Invalid cursor position. Please place cursor at the beginning of the definition!")
(Just decl, b) -> Right (decl, b)
where
locToPName
= case res of
Nothing -> (find (definesPNT (locToPNT fileName (row, col) mod)) (hsDecls mod), True)
_ -> (res, False)
res = find (defines (locToPN fileName (row, col) mod)) (concat (map hsDecls (hsModDecls mod)))
definesPNT pnt d@(Dec (HsPatBind loc p e ds))
= findPNT pnt d
definesPNT pnt d@(Dec (HsFunBind loc ms))
= findPNT pnt d
definesPNT _ _ = False
checkCursor' :: String -> Int -> Int -> HsModuleP -> HsDeclP
checkCursor' fileName row col mod
= case locToPName of
Nothing -> error "Invalid cursor position. Please place cursor at the beginning of the definition!"
Just decl -> decl
where
locToPName = find (definesPNT (locToPNT fileName (row, col) mod)) (hsDecls mod)
definesPNT pnt d@(Dec (HsPatBind loc p e ds))
= findPNT pnt d
definesPNT pnt d@(Dec (HsFunBind loc ms))
= findPNT pnt d
definesPNT _ _ = False
{-|
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).
-}
--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)
| locToExp2 beginPos endPos toks rhs /= defaultExp
= Just (pnt, locToExp2 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)
| locToExp2 beginPos endPos toks rhs /= defaultExp
= if isSimplePatBind pat
then Just (patToPNT ps, locToExp2 beginPos endPos toks rhs)
else error "A complex pattern binding can not be generalised!"
inPat _ = Nothing