HaRe-0.6: refactorer/RefacSlicTuple.hs
-----------------------------------------------------------------------------
-- |
-- Module : RefacSlicTuple
-- Copyright : (c) Christopher Brown 2006
--
-- Maintainer : cmb21@kent.ac.uk
-- Stability : provisional
-- Portability : portable
--
-- This module contains a transformation for HaRe.
-- Symoblic Evaluation on tuples.
-- creates functions which evaluate the expressions
-- within the return value of a function.
-- e.g.
--
-- @ f x y = (x, y) @
--
-- @ f1 x = x @
--
-- @ f2 y = y @
--
-----------------------------------------------------------------------------
module RefacSlicTuple where
import System.IO.Unsafe
import RefacTypeSyn
import RefacLocUtils
import Data.Char
import GHC.Unicode
import AbstractIO
import Maybe
import List
import RefacUtils
import RefacRedunDec
import SlicingUtils
data Patt = Match HsMatchP | MyPat HsDeclP | Def [Char] deriving Show
refacSlicTuple args
= do let
fileName = args!!0
row = read (args!!1)::Int
col = read (args!!2)::Int
answer = args!!3
AbstractIO.putStrLn "refacTuple"
-- Parse the input file.
modName1 <- fileNameToModName fileName
let modName = modNameToStr modName1
modInfo@(inscps, exps, mod, tokList) <- parseSourceFile fileName
-- Find the function that's been highlighted as the refactree
case checkCursor fileName row col mod of
Left errMsg -> do error errMsg
Right decl ->
do
-- get the RHS
let (x@(listExp, rhs, wh, wh2, localDefs, p):xs) = getRHS fileName answer decl (locToPNT fileName (row, col) mod) False [] modName
let name = (locToPN fileName (row, col) mod)
-- let newDecl2 = getNamesFromDecl decl
let newDecl = map (getDeclInWhere decl) (map (\(a,b,c,d,e,f) -> (b)) (x:xs))
let newAnswer = convertAnswer answer listExp
-- error $ show (x:xs)
res <- myMapM f (newAnswer, (x:xs))
let res2 = map (\(a,b,c) -> a) res
let local2 = makeBools res
let names = makeNames res
let sortedDecls0 = sortDecls ((concat res2), local2, names)
let sortedDecls = map (\(a,b, c) -> a) sortedDecls0
let local3 = map (\(a,b, c) -> b) sortedDecls0
let names2 = map (\(a,b,c) -> c) sortedDecls0
-- newSortedDecls <- matchPatterns sortedDecls newDecl
replacedDecls <- replaceWithNew answer (locToPN fileName (row, col) mod) sortedDecls (length listExp)
newReplacedDecls <- removeDeadPatterns answer replacedDecls names2 -- (getNameOfDec (head newDecl))
newReplacedDecls2 <- removeDeadTupleCase newReplacedDecls newReplacedDecls
newReplacedDecls3 <- dependencyAnalysis newReplacedDecls2 (head newDecl) newReplacedDecls2 names2
newSortedDecls2 <- createDecl newReplacedDecls3 decl local3 0 newAnswer
let newSortedDecls3 = sortDecls (newSortedDecls2, local3, names2)
let refactoredDecls = map (\(a,b, c) -> a) newSortedDecls3
res2 <- applyRefac (addDecls refactoredDecls name) (Just (inscps, exps, mod, tokList)) fileName
writeRefactoredFiles True [res2]
(inscps2, exps2, mod2, tokList2) <- parseSourceFile fileName
let newRefactoredDecls1 = hsDecls mod2
-- AbstractIO.putStrLn $ show (map declToName refactoredDecls)
let newRefactoredDecls2 = definingDecls (map (declToPName (map declToName refactoredDecls)) newRefactoredDecls1) newRefactoredDecls1 False False
-- AbstractIO.putStrLn $ show newRefactoredDecls2
sigs <- mapM (getSigAsString fileName modName) (map declToName newRefactoredDecls2)
-- AbstractIO.putStrLn $ show sigs
-- AbstractIO.putStrLn $ show (map declToName newRefactoredDecls2)
-- AbstractIO.putStrLn $ show (map (declToPName (map declToName refactoredDecls)) newRefactoredDecls1)
res3 <- applyRefac (addTypes (dropWhile (\x -> x == defaultPN) (map (declToPName (map declToName refactoredDecls)) newRefactoredDecls1)) sigs) (Just (inscps2, exps2, mod2, tokList2)) fileName
-- error $ show res3
writeRefactoredFiles True [res3]
{- (inscps5, exps5, mod5, tokList5, ses5) <- parseSourceFile2 fileName modName
(mod',((tokList'',modified),_))<-(doCommenting (dropWhile (\x -> x == defaultPN) (map (declToPName (map declToName refactoredDecls)) newRefactoredDecls1))) fileName mod5 tokList5
writeRefactoredFiles True [((fileName, True), (tokList'', mod'))] -}
where
f a l@((listExp:es), rhs, wh, wh2, localDefs, p1) -- (tok, m)
= do
if (listExp:es) == []
then error "Please select a definition that returns a tuple!"
else
if localDefs == False
then do
let (funRHS, funName, wher, pats) = simpleGetRHS decl (locToPNT fileName (row, col) mod)
decl <- forEach (listExp:es) rhs wh wh2 fileName 0 a (funName, p1) (inscps, exps, mod, tokList)
return (decl, False, funName)
else do
let (begin, end) = getStartEndLoc tokList (get1Element listExp)
let blah@(loc, pnt, pats, exp, wh2, p)
= findDefNameAndExp tokList
begin
end
mod
let (funRHS, funName, wher, pats) = simpleGetRHS decl (locToPNT fileName (row, col) mod)
decl <- forEach2 wher (listExp:es) rhs wh wh2 fileName 0 a (funName, p1) (inscps, exps, mod, tokList)
return (decl, True, pnt)
writeRefactored2 x = writeRefactoredFiles False [x]
myMapM f (a, [l])
= do
res <- f a l -- (tokList, mod)
return [res]
myMapM f (a , (l:list))
= do
res <- f a l -- (tokList, mod)
x <- myMapM f (a ,list) -- (tokList, mod)
return (res : x)
convertModName (PlainModule s) = s
convertModName m@(MainModule f) = modNameToStr m
--createTypeSig :: String -> [String] -> [String] -> HsDeclP
createTypeSig name [] types
= Dec (HsTypeSig loc0 [nameToPNT name] [] (createApplication types))
createTypeSig name context types
= Dec (HsTypeSig loc0 [nameToPNT name] [(Typ (HsTyVar (nameToPNT context)))] (createApplication types))
-- (Typ (HsTyVar (nameToTypePNT (head types))) ) )
nameToTypePNT :: String -> PNT
nameToTypePNT id = (PNT (PN (UnQual id) (S loc0)) (Type (TypeInfo {defType = Nothing, constructors = [], fields = []})) (N (Just loc0)))
createApplication [var]
= (Typ (HsTyVar (nameToTypePNT var)))
createApplication (var:vars)
= createApplication' (Typ (HsTyVar (nameToTypePNT var))) vars
createApplication' x [y]
= (Typ (HsTyFun x (Typ (HsTyVar (nameToTypePNT y)))))
createApplication' x (y:ys)
= (createApplication' (Typ (HsTyFun x (Typ (HsTyVar (nameToTypePNT y))))) ys)
findType pnt t
= applyTU (stop_tdTU (failTU `adhocTU` inSig)) t
where
inSig (dec@(Dec (HsTypeSig _ _ _ _))::HsDeclP)
= do
let res = definesTypeSig (pNTtoPN pnt) dec
if res == True
then return [True]
else fail ""
inSig _ = fail ""
{- declToName :: HsDeclP -> String
declToName (Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs)))
= pNTtoName pnt
declToName (Dec (HsPatBind _ pnt _ _)) = pNTtoName (patToPNT pnt) -}
{- declToPName :: [ String ] -> HsDeclP -> PName
declToPName [] _ = defaultPN
declToPName (name: names) d@(Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs)))
| name == pNTtoName pnt = pNTtoPN pnt
| otherwise = declToPName names d
declToPName (name:names) d@(Dec (HsPatBind _ pnt _ _)) -- = pNTtoPN (patToPNT pnt)
| name == pNTtoName (patToPNT pnt) = pNTtoPN (patToPNT pnt)
| otherwise = declToPName names d
declToPName _ _ = defaultPN
-}
{- getSig ses modName name
= do
let types = getTypes name ses modName
-- error $ show types
let types1 = cleanTypes (tail types)
let (context, l) = getContext (head types)
let types2 = l : types1
-- let context2 = init context
let types3 = map (filter (/= '\n')) types2
let newSig = createTypeSig name context types3
-- error $ show newSig
return newSig -}
makeBools :: [ ([HsDeclP], Bool, PNT) ] -> [Bool]
makeBools [] = []
makeBools (( x, False, _) : xs)
= (replicate (length x) False) ++ (makeBools xs)
makeBools (( x, True, _) : xs)
= (replicate (length x) True) ++ ( makeBools xs )
makeNames :: [ ([HsDeclP], Bool, PNT) ] -> [PNT]
makeNames [] = []
makeNames (( x, _, y) : xs)
= (replicate (length x) y) ++ (makeNames xs)
createDecl [] _ _ _ _ = return []
createDecl (d3@(Dec (HsFunBind _ (m@(HsMatch l i1 ps (HsBody e) ds):ms) )):ds3) t@(Dec (HsPatBind loc2 p2 (HsBody e2) ds2)) (True:xs) count a
= do
let (newCount, newAnswer) = countAnswer count a
result2 <- renamePN2 (getNameFromExp e2) i1 e2
let (jj,ii) = span (defines' (pNTtoPN i1)) (d3:ds3)
newSortedDecls3 <- removeRedunWhere2 ((d3:ds3) ++ ds2) result2
rest <- createDecl (ii) t (drop (length jj) (True:xs)) newCount newAnswer
return ((Dec (HsPatBind loc2 (nameToPat ((pNTtoName (patToPNT p2)) ++ (show newCount))) (HsBody result2) newSortedDecls3)) : rest)
createDecl (d3@(Dec (HsFunBind _ (m@(HsMatch l i1 ps (HsBody e) ds):ms) )):ds3) t@(Dec (HsFunBind loc (m2@(HsMatch l2 i2 ps2 (HsBody e2) ds2):ms2))) (True:xs) count a
= do
let (newCount, newAnswer) = countAnswer count a
result <- checkMatch (m2:ms2) i1 newCount
let (jj,ii) = span (defines' (pNTtoPN i1)) (d3:ds3)
rest <- createDecl (ii) t (drop (length jj) (True:xs)) newCount newAnswer
return ( (Dec (HsFunBind loc result)) : rest )
where
checkMatch [] _ _ = return []
checkMatch (m2@(HsMatch l2 i2 ps2 (HsBody e2) ds2):ms2) i1 newCount
= do
if isPrefixOf (pNtoName (getNameFromExp e2)) (pNTtoName i1)
then do
result2 <- renamePN2 (getNameFromExp e2) i1 e2
newSortedDecls3 <- removeRedunWhere2 ((d3:ds3) ++ ds2) result2
rest2 <- checkMatch ms2 i1 newCount
return ((HsMatch l2 (nameToPNT ((pNTtoName i2) ++ (show newCount))) ps2 (HsBody result2) newSortedDecls3):rest2)
else do
result <- checkMatch ms2 i1 newCount
return result
createDecl (d:ds) t (False:xs) c a = do
rest <- createDecl ds t xs c a
return (d : rest)
-- xcreateDecl _ _ [] _ = return []
-- createDecl a x y z = error $ show (a, x,y,z)
renamePN2:: (Monad m, Term t) =>
PName -- ^ The identifier to be renamed.
->PNT -- ^ The new name
->t -- ^ The syntax phrase
->m t
renamePN2 oldPN newName t
= applyTP (full_tdTP (adhocTP idTP rename)) t
where
rename pnt@(PNT pn y z )
| (pn ==oldPN) && (srcLoc oldPN == srcLoc pn)
= return newName
-- where
-- replaceName = replaceNameInPN Nothing
rename x = return x
getNameFromExp (Exp (HsApp e1 e2))
= getNameFromExp e1
getNameFromExp e1
= expToPN e1
getNameOfDec :: HsDeclP -> PNT
getNameOfDec (Dec (HsFunBind loc ms))
= getNameOfDecMatch ms
where
getNameOfDecMatch (m@(HsMatch l i1 ps (HsBody e) ds):ms)
= i1
getNameOfDec (Dec (HsPatBind loc p (HsBody e) ds))
= patToPNT p
getDeclInWhere :: HsDeclP -> HsExpP -> HsDeclP
getDeclInWhere decl (Exp (HsApp e1 e2))
= head ( findDef (expToPNT (e1)) decl )
getDeclInWhere decl _ = decl
mapNew (x@(listExp, rhs, wh, wh2, localDefs):xs)
| localDefs == True = map (\(a,b,c,d,e) -> (a,b,c,d,True)) (x:xs)
| otherwise = (x:xs)
convertAnswer [] ys = []
convertAnswer (x:xs) ys
| x == 'a' || x == 'A' = replicate (length ys) 'x'
| isDigit x = 'x' : (convertAnswer (nextXS xs) ys)
| x == 'x' || x == 'X' = 'x' : (convertAnswer (nextXS xs) ys)
| x == '_' = '_' : (convertAnswer (nextXS xs) ys)
| otherwise = convertAnswer xs ys
matchPatterns [] _ = return []
matchPatterns (x:xs) (Dec (HsFunBind loc ms))
= do
let len = length ms
let ft = take len (x:xs)
let result = correctPatterns ft ms
result2 <- matchPatterns (drop len (x:xs)) (Dec (HsFunBind loc ms))
return (result ++ result2)
matchPatterns (x:xs) (Dec (HsPatBind loc p (HsBody e) ds))
= do
return (x:xs)
correctPatterns [] _ = []
correctPatterns _ [] = []
correctPatterns ((Dec (HsFunBind loc0 ((HsMatch loc pnt pats rhs ds):ms))):ds2) (m@(HsMatch _ _ pats2 _ _):ms2)
= ((Dec (HsFunBind loc0 ((HsMatch loc pnt pats2 rhs ds):ms))) : (correctPatterns ds2 ms2))
getLengthAnswer [] count = count
getLengthAnswer (x:xs) count
= case x of
'(' -> if (or (map isDigit xs)) then getLengthAnswer xs count
else getLengthAnswer (tail (dropWhile (\x -> x /= ')') xs)) (count+1)
',' -> getLengthAnswer xs count
'/' -> getLengthAnswer xs count
'X' -> getLengthAnswer xs (count+1)
'x' -> getLengthAnswer xs (count+1)
'_' -> getLengthAnswer xs (count+1)
')' -> count
_ -> if not (isDigit x) then error "Incorrect usage syntax"
else maximum (map digitToInt (filter (isDigit) (x:xs)))
getLength1 "A" rhs = getLength2 rhs
getLength1 "a" rhs = getLength2 rhs
getLength1 _ _ = 0
getLength2 (rhs@(Exp (HsTuple x))) = length x
getLength2 _ = 0
shuffleRHS :: String -> [HsExpP] -> [HsExpP]
shuffleRHS _ [] = []
shuffleRHS [] _ = []
shuffleRHS ('x':xs) (y:ys) = y : (shuffleRHS xs ys)
shuffleRHS ('X':xs) (y:ys) = y : (shuffleRHS xs ys)
shuffleRHS ('_':xs) (y:ys) = shuffleRHS xs ys
shuffleRHS ('(':xs) (y:ys)
| or (map isDigit xs) = (Exp (HsTuple (shuffleRHS2 xs (y:ys)))) : (shuffleRHS (nextXS xs) (y:ys))
| otherwise = (shuffleRHS xs (nestedTuples y)) ++ (shuffleRHS (nextXS xs) ys)
where
nestedTuples :: HsExpP -> [HsExpP]
nestedTuples (Exp (HsTuple ts)) = ts
nestedTuples e = error "The input string does not match the pattern of the RHS."
shuffleRHS (x:xs) (y:ys)
| isDigit x = ((y:ys) !! ((digitToInt x)-1)) : ( shuffleRHS xs (y:ys))
| otherwise = shuffleRHS xs (y:ys)
shuffleRHS2 (')':xs) (y:ys) = []
shuffleRHS2 (x:xs) (y:ys)
| isDigit x = ( (y:ys) !! ((digitToInt x)-1) ) : shuffleRHS2 xs (y:ys)
| otherwise = shuffleRHS2 xs (y:ys)
nextXS [] = []
-- nextXS (')':xs) = []
nextXS ('/':xs) = xs
nextXS (x:xs) = nextXS xs
addDecls (x:xs) id (_,_,mod) = do
mod' <- addDecl mod (Just id) ((x:xs),Nothing) True
return mod'
addTypes _ [] (_,_,mod) = return mod
addTypes (x:xs) (y:ys) (a,b,mod) = do
-- mod' <- addTypeSigDecl mod (Just x) ([y], Nothing) True
let name = pNtoName x
mod' <- insertComment (name ++ " :: " ++ y) x mod
-- commentOutTypeSig x (y:ys)
res <- addTypes xs ys (a,b,mod')
return mod'
commentThemOut (x:xs) (y:ys) = do
commentOutTypeSig x (y:ys)
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
-- ds' <-
res2 <- rmInMod ps (HsModule loc name exps imps ds')
return res2
-- rmInMod _ _ =mzero
{- removeDeadPatternsCase [] _ = return []
removeDeadPatternsCase (d@(Dec (HsFunBind loc ms)):ds) decs
= do
res <- removeDeadCaseArgs ms decs
rest <- removeDeadPatternsCase ds decs
return ((Dec (HsFunBind loc )):rest)
where
removeDeadCaseArgs [] _ = return []
removeDeadCaseArgs _ [] = return []
removeDeadCaseArgs (m@(HsMatch l i1 ps (HsBody e) ds):ms) d
= do
res <- removeDeadCaseArgs2 i1 ds d
rest <- removeDeadCaseArgs ms d
return ((HsMatch l i1 ps (HsBody e) res):rest)
removeDeadCaseArgs2 _ [] _ = return []
removeDeadCaseArgs2 pnt (d@(Dec (HsPatBind loc p (HsBody e) ds)):dss) decs
= case p of
(Pat (HsPTuple s (l:ls))) -> if returnRHS pnt e
then do
newRHS <- removeDeadTupleCase ds decs
return newRHS
else do
return (d:dss)
p -> -}
createNewRHS count (d:ds) pnt var params
= do
let result = res (findDec (d:ds) ((pNTtoName pnt) ++ (show count)) (pNTtoName pnt) (show count) var (d:ds) )
return result
where
res (Dec (HsFunBind _ (m@(HsMatch l i1 ps (HsBody e) ds):ms))) = createFunc i1 params
res (Dec (HsPatBind loc p _ _)) = pNtoExp (patToPN p)
convertPNTs [] = []
convertPNTs (pnt:pnts) = ((pNTtoName pnt) ++ (show count)) : (convertPNTs pnts)
findDec [] x fun var name list = error ( "The variable: " ++ name ++ " requires element " ++
var ++ " from " ++ fun ++ ". Please retry slicing element " ++ var ++ " as well.")
findDec (d@(Dec (HsFunBind _ (m@(HsMatch l i1 ps (HsBody e) ds1):ms))):ds) name a b c list
| (pNTtoName i1) == name = d
| otherwise = findDec ds name a b c list
findDec (d@(Dec (HsPatBind loc p _ _)):ds) name a b c list
| pNTtoName (patToPNT p) == name = d
| otherwise = findDec ds name a b c list
{-|
createFunc takes the function name and a list of expressions to be
used in the call. createFunc then creates a function application
based on the expressions in the second argument.
createFunc :: PNT -> [HsExpP] -> HsExpP
createFunc _ [] = defaultExp
createFunc pat [exp]
= (Exp (HsApp (Exp (HsId (HsVar pat))) exp))
createFunc pat (exp:exps)
= createFunc' (Exp (HsId (HsVar (pat)))) (exp:exps)
-- | createFunc' is used by createFunc to build up a function application
createFunc' :: HsExpP -> [HsExpP] -> HsExpP
createFunc' exp [x]
= (Exp (HsApp exp x))
createFunc' exp (x:xs)
= (createFunc' (Exp (HsApp (exp) x)) xs)
-}
dependencyAnalysis [] _ _ _ = return []
dependencyAnalysis (d@(Dec (HsFunBind loc ms)):ds) origDec decs (pnt:pnts)
= do
res <- fixDependency ms origDec decs (pnt:pnts)
rest <- dependencyAnalysis ds origDec decs pnts
return ((Dec (HsFunBind loc res)):rest)
where
fixDependency [] _ _ _ = return []
fixDependency (m@(HsMatch l i1 ps (HsBody e) ds):ms) d decs (p:pns)
= do
res <- fixDependency2 p ds d decs
rest <- fixDependency ms d decs pns
return ((HsMatch l i1 ps (HsBody e) res):rest)
fixDependency2 _ [] _ _ = return []
fixDependency2 pnt d@((Dec (HsFunBind loc ms)):dss) decs allDecs
= do
rest <- fixDependency2 pnt dss decs allDecs
return ((Dec (HsFunBind loc ms)): rest)
fixDependency2 pnt (d@(Dec (HsPatBind loc p (HsBody e) ds)):dss) decs allDecs
= case p of
(Pat (HsPTuple s (p1:ps1)))
-> if returnRHS pnt e
then do
rhs <- correctTupleRHS pnt (p1:ps1) dss decs allDecs e
{- count <- correctRHS p1 decs -}
rest <- fixDependency2 pnt dss decs allDecs
let rhs2 = case e of
(Exp (HsCase _ alts)) -> (Exp (HsCase (Exp (HsTuple rhs)) alts))
_ -> (Exp (HsTuple rhs))
return ((Dec (HsPatBind loc p (HsBody rhs2) ds)):rest)
else do
rest <- fixDependency2 pnt dss decs allDecs
return ((Dec (HsPatBind loc p (HsBody e) ds)):rest)
_ -> if returnRHS pnt e
then do
count <- correctRHS p decs
if count /= 0
then do
rest <- fixDependency2 pnt dss decs allDecs
let params = getParams pnt e
newRHS <- createNewRHS count allDecs pnt (pNTtoName (patToPNT p)) params
return ((Dec (HsPatBind loc p (HsBody newRHS) ds)):rest)
else do
rest <- fixDependency2 pnt dss decs allDecs
return rest
else do
rest <- fixDependency2 pnt dss decs allDecs
return ((Dec (HsPatBind loc p (HsBody e) ds)):rest)
correctTupleRHS :: Monad m => PNT -> [HsPatP] -> [HsDeclP] -> HsDeclP -> [HsDeclP] -> HsExpP -> m [HsExpP]
correctTupleRHS _ [] _ _ _ _ = return []
correctTupleRHS pnt (p:ps) dss decs allDecs e
= do
count <- correctRHS p decs
if count /=0
then do
-- rest <- fixDependency2 pnt dss decs allDecs
let params = getParams pnt e
-- error $ show (count, pnt, (pNTtoName (patToPNT p)))
newRHS <- createNewRHS count allDecs pnt (pNTtoName (patToPNT p)) params
rest <- correctTupleRHS pnt ps dss decs allDecs e
return ( newRHS : rest)
else do
rest <- correctTupleRHS pnt ps dss decs allDecs e
return rest
correctRHS :: Monad m => HsPatP -> HsDeclP -> m Int
correctRHS (Pat (HsPParen p)) origDec
= do
result <- correctRHS p origDec
return result
correctRHS (Pat (HsPTuple _ (p:ps))) origDec
= do
result <- correctRHS p origDec
return result
correctRHS (Pat (HsPId (HsVar (PNT (PN (UnQual x2) s) _ _)))) (Dec (HsFunBind loc ms))
= do
result <- correctRHS2 ms x2
return result
correctRHS p d
= return 0
correctRHS2 [] _ = return 0
correctRHS2 (m@(HsMatch l i1 ps _ ds):ms) x2
= do
res <- correctRHS3 i1 ds x2
rest <- correctRHS2 ms x2
if res /= 0
then return res
else return rest
correctRHS3 _ [] _ = return 0
correctRHS3 pnt (d@(Dec (HsPatBind loc p (HsBody e) ds)):dss) x2
= if returnRHS pnt e
then do
-- which element is x2 contained within p?
count <- countPat [p] x2 1
return count
else do
rest <- correctRHS3 pnt dss x2
return rest
correctRHS3 pnt (d@(Dec (HsFunBind loc ms)):dss) x2
= do
matches <- checkMatches ms x2
if matches /= 0
then return matches
else do
res <- correctRHS3 pnt dss x2
return res
where
checkMatches [] _ = return 0
checkMatches (m@(HsMatch l i1 ps (HsBody e) ds):ms) x2
= do
res <- correctRHS3 i1 ds x2
rest <- correctRHS2 ms x2
if res /= 0
then return res
else return rest
{-} correctRHS3 (d:dss) x2 = do rest <- correctRHS3 dss x2
return 0 -}
countPat :: Monad m => [HsPatP] -> String -> Int -> m Int
countPat [] x count = return count
countPat [Pat (HsPTuple _ (p:ps))] x2 count
= do
let result = inPat [p] x2
if result then return count
else do result2 <- countPat ps x2 (count+1)
return result2
countPat ((Pat (HsPTuple _ (p:ps))):ps2) x2 count
= do
let result = inPat (p:ps) x2
if result then return count
else do result2 <- countPat ps2 x2 (count + 1)
return result2
countPat (p:ps) x2 count
= do
let result = inPat [p] x2
if result then return count
else do result2 <- countPat ps x2 (count+1)
return result2
inPat [] _ = False
inPat ((Pat (HsPId (HsVar (PNT (PN (UnQual x1) s) _ _)))):ps) x2
| x1 == x2 = True
| otherwise = inPat ps x2
inPat ((Pat (HsPTuple _ (p:ps))):ps2) x2
| inPat (p:ps) x2 = True
| otherwise = inPat ps2 x2
inPat ((Pat (HsPParen p)):ps) x2
= inPat (p:ps) x2
inPat (p:ps) x2
= inPat ps x2
removeDeadTupleCase [] _ = return []
removeDeadTupleCase (d@(Dec (HsFunBind loc ms)):ds) decs
= do
res <- removeDeadCaseArgs ms decs
rest <- removeDeadTupleCase ds decs
return ((Dec (HsFunBind loc res)):rest)
where
removeDeadCaseArgs [] _ = return []
removeDeadCaseArgs _ [] = return []
removeDeadCaseArgs (m@(HsMatch l i1 ps (HsBody e) ds):ms) d
= do
res <- removeDeadCaseArgs2 i1 ds d
rest <- removeDeadCaseArgs ms d
return ((HsMatch l i1 ps (HsBody e) res):rest)
removeDeadCaseArgs2 _ [] _ = return []
removeDeadCaseArgs2 pnt (d@(Dec (HsPatBind loc p (HsBody e) ds)):dss) decs
= case p of
(Pat (HsPTuple s (l:ls))) -> if returnRHS pnt e
then do
newRHS <- removeDeadTupleCase2 (l:ls) decs [e]
rest <- removeDeadCaseArgs2 pnt dss decs
if length newRHS == 1
then do
let newRHS1 = newRHS !! 0
return ((Dec (HsPatBind loc p (HsBody newRHS1) ds)):rest)
else do
return ((Dec (HsPatBind loc p (HsBody (Exp (HsTuple newRHS))) ds)):rest)
else do
rest <- removeDeadCaseArgs2 pnt dss decs
return (d:rest)
_ -> if returnRHS pnt e
then do
newRHS <- removeDeadTupleCase2 [p] decs [e]
rest <- removeDeadCaseArgs2 pnt dss decs
if length newRHS == 1
then do
let newRHS1 = newRHS !! 0
return ((Dec (HsPatBind loc p (HsBody newRHS1) ds)):rest)
else do
return ((Dec (HsPatBind loc p (HsBody (Exp (HsTuple newRHS))) ds)):rest)
else do
rest <- removeDeadCaseArgs2 pnt dss decs
return (d:rest)
removeDeadCaseArgs2 pnt (d:dss) decs = do rest <- removeDeadCaseArgs2 pnt dss decs
return (d:rest)
removeDeadTupleCase2 pats decs [(Exp (HsCase e1 alts ))]
= do
newExp <- removeFromExp [e1] pats decs
return [(Exp (HsCase newExp alts))]
removeDeadTupleCase2 pats decs [e]
= do
newExp <- removeFromExp [e] pats decs
return [e]
-- removeDeadTupleCase2 pats decs [e] = return [e]
removeFromExp [(Exp (HsTuple (e:es)))] [p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2) s) _ _))))] (d:ds)
= do
-- error $ show (d:ds)
let dec = head (findDec e (d:ds) )
-- error $ show (x2, dec, [p])
if defines2 (PN (UnQual x2) s) [p] dec
then do
-- error $ show e
return e
else do
-- error $ show (defines2 (PN (UnQual x2) s) [p] dec)
rest <- removeFromExp2 es [p] (d:ds)
return (Exp (HsTuple rest))
removeFromExp [(Exp (HsTuple (e:es)))] (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2) s) _ _)))):ps) (d:ds)
= do
let dec = head (findDec e (d:ds) )
-- check there is a wildcard. If there is we need to find the definition which defines
-- the names and the wildcard replacment
-- error $ show dec
let pns = defines3 (PN (UnQual x2) s) (p:ps) dec
if defaultPN `elem` pns
then do
rest <- removeFromExp2 es (p:ps) (d:ds)
return (Exp (HsTuple rest))
else do
-- error $ show (x2, dec)
if and (map ( (\a b c d -> a d b c) defines2 (p:ps) dec) (hsPNs (p:ps)))
then do
rest <- removeFromExp2 es ps (d:ds)
return (Exp (HsTuple (e:rest)))
{- if defines2 (PN (UnQual x2) s) dec
then do
rest <- removeFromExp2 es ps (d:ds)
return (Exp (HsTuple (e:rest))) -}
else do
rest <- removeFromExp2 es ps (d:ds)
return (Exp (HsTuple rest))
removeFromExp [e] _ _ = return e
removeFromExp2 [] _ _ = return []
removeFromExp2 (e@(Exp _):es) [p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2) s) _ _))))] (d:ds)
= do
let dec = head (findDec e (d:ds) )
if defines2 (PN (UnQual x2) s) [p] dec
then do
-- error $ show (x2, dec)
return [e]
else do
res <- removeFromExp2 es [p] (d:ds)
return res
removeFromExp2 (e@(Exp _):es) (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2) s) _ _)))):ps) (d:ds)
= do
let dec = head (findDec e (d:ds) )
if defines2 (PN (UnQual x2) s) (p:ps) dec
then do
-- error $ show (x2, dec)
rest <- removeFromExp2 es ps (d:ds)
return (e:rest)
else do
rest <- removeFromExp2 es ps (d:ds)
return rest
removeFromExp2 a b c = return []
findDec _ [] = error "this wasn't supposed to happen"
findDec e@(Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual x) s) _ _ )))) e2)) (d:ds)
| inDec x d = [d]
| otherwise = findDec e ds
inDec x (Dec (HsPatBind loc (Pat (HsPId (HsVar (PNT (PN (UnQual x2) s) _ _)))) (HsBody e) ds))
| x == x2 = True
| otherwise = False
inDec x (Dec (HsFunBind _ ((HsMatch _ (PNT (PN (UnQual x2) s)_ _) _ _ _):ms)))
| x == x2 = True
| otherwise = False
inDec _ _ = False
{- removeDeadPatterns _ [] _ = return []
removeDeadPatterns a ((Dec (HsFunBind loc ms)):ds) pnt
= do
res <- removeDeadPats ms pnt
-- error $ show ds
rest <- removeDeadPatterns a ds pnt
return ((Dec (HsFunBind loc res)): rest)
where
removeDeadPats [] pnt = return []
removeDeadPats (m@(HsMatch l i1 ps (HsBody e) ds):ms) pnt
= do
(dec, free) <- hsFreeAndDeclaredPNs e
-- error $ show dec
res <- removeDeadPats2 a dec i1 ds
rest <- removeDeadPats ms pnt
return ((HsMatch l i1 ps (HsBody e) res):rest)
removeDeadPats2 a dec pnt [] = return []
removeDeadPats2 a dec pnt (d@(Dec (HsPatBind loc p (HsBody e) ds)):dss)
= case p of
(Pat (HsPTuple s (l:ls))) -> if returnRHS2 pnt e
then do
newPats <- removeDeadPats3' s dec (l:ls)
newRHS <- removeDeadTupleEl pnt dec (l:ls) [e]
rest <- removeDeadPats2 a dec pnt dss
if length newRHS == 1
then do
let newRHS1 = newRHS !! 0
return ((Dec (HsPatBind loc newPats (HsBody newRHS1) ds)):rest)
else do
if length newRHS == 0
then error "There is an error with the variable dependency analysis!"
else
return ((Dec (HsPatBind loc newPats (HsBody (Exp (HsTuple newRHS))) ds)):rest)
else do
rest <- removeDeadPats2 a dec pnt dss
return ((Dec (HsPatBind loc p (HsBody e) ds)):rest)
_ -> do
rest <- removeDeadPats2 a dec pnt dss
return (d:rest)
removeDeadPats2 a dec pnt x = return x -}
removeDeadPatterns a ((Dec (HsFunBind loc ms)):ds) (pnt:pnts)
= do
res <- removeDeadPats ms pnt
rest <- removeDeadPatterns a ds pnts
return ((Dec (HsFunBind loc res)): rest)
where
removeDeadPats [] pnt = return []
removeDeadPats (m@(HsMatch l i1 ps (HsBody e) ds):ms) pnt
= do
(dec, free) <- hsFreeAndDeclaredPNs e
-- error $ show dec
res <- removeDeadPats2 a dec pnt ds
rest <- removeDeadPats ms pnt
return ((HsMatch l i1 ps (HsBody e) res):rest)
removeDeadPats2 a dec pnt [] = return []
removeDeadPats2 a dec pnt (d@(Dec (HsPatBind loc p (HsBody e) ds)):dss)
= case p of
(Pat (HsPTuple s (l:ls))) -> if returnRHS pnt e
then do
newPats <- removeDeadPats3' s dec (l:ls)
newRHS <- removeDeadTupleEl pnt dec (l:ls) [e]
rest <- removeDeadPats2 a dec pnt dss
if length newRHS == 1
then do
let newRHS1 = newRHS !! 0
return ((Dec (HsPatBind loc newPats (HsBody newRHS1) ds)):rest)
else do
if length newRHS == 0
then error "There is an error with the variable dependency analysis!"
else
return ((Dec (HsPatBind loc newPats (HsBody (Exp (HsTuple newRHS))) ds)):rest)
else do
error $ show (pnt, e)
rest <- removeDeadPats2 a dec pnt dss
return ((Dec (HsPatBind loc p (HsBody e) ds)):rest)
_ -> do
rest <- removeDeadPats2 a dec pnt dss
return (d:rest)
removeDeadPats2 a dec pnt x = return x
-- removeDeadPats3 [] _ = []
removeDeadPats3' s a b
= do
let res = removeDeadPats3 a b
if length res == 1
then do
let newRes = res !! 0
return newRes
else do
if res == []
then error "there is a problem with the dependency analysis on the RHS"
else return (Pat (HsPTuple s res))
removeDeadPats3 :: [PName] -> [HsPatP] -> [HsPatP]
removeDeadPats3 [] _ = []
removeDeadPats3 _ [] = []
removeDeadPats3 (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2)_) _ _)))):ps)
| myElem p (x:xs) = p : (removeDeadPats3 (x:xs) ps)
-- | x1 == x2 = p : (removeDeadPats3 xs ps)
| otherwise = removeDeadPats3 (x:xs) ps
removeDeadPats3 (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPTuple s (p1:ps))):pss)
| allBlank (removeDeadPats3Tuple (x:xs) (p1:ps)) = removeDeadPats3 (x:xs) pss
| otherwise = (Pat (HsPTuple s (removeDeadPats3Tuple (x:xs) (p1:ps)))) : (removeDeadPats3 (x:xs) pss)
where
allBlank ps = and (allBlank2 ps)
allBlank2 [] = [True]
allBlank2 ((Pat (HsPWildCard)):ps)
= True : (allBlank2 ps)
allBlank2 (p:ps)
= False : (allBlank2 ps)
removeDeadPats3Tuple [] _ = []
removeDeadPats3Tuple _ [] = []
removeDeadPats3Tuple (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2)_) _ _)))):ps)
| myElem p (x:xs) = p : (removeDeadPats3Tuple (x:xs) ps)
| otherwise = (Pat (HsPWildCard)) : ( removeDeadPats3Tuple (x:xs) ps )
removeDeadPats3Tuple a (p:ps)
= p : (removeDeadPats3Tuple a ps )
-- pattern is either a wildcard or a literal
removeDeadPats3 a (p:ps) -- = error $ show p
= removeDeadPats3 a ps
-- removeDeadPats3 a b = error $ show b
myElem :: HsPatP -> [PName] -> Bool
myElem _ [] = False
myElem a@(Pat (HsPParen p1)) (p:ps) = myElem p1 (p:ps)
myElem a@(Pat (HsPId (HsVar (PNT (PN (UnQual x1)_) _ _)))) (p@(PN (UnQual x2) _):ps)
| x1 == x2 = True
| otherwise = myElem a ps
removeDeadPats4' s a b c
= do
let res = removeDeadPats4 a b c
if length res == 1
then do
let newRes = res !! 0
return newRes
else do
if res == []
then error $ show "blah"
else return (Pat (HsPTuple s res))
removeDeadPats4 [] _ _ = []
removeDeadPats4 _ [] _ = []
removeDeadPats4 _ _ [] = []
removeDeadPats4 (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPParen p1)):ps) (l:ls)
= removeDeadPats4 (x:xs) (p1:ps) (l:ls)
removeDeadPats4 (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPTuple s (p1:ps1))):ps) (l:ls)
| or (map (flip myElem (x:xs)) (p1:ps1)) = l : (removeDeadPats4 (x:xs) ps ls)
| otherwise = removeDeadPats4 (x:xs) ps ls
removeDeadPats4 (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2)_) _ _)))):ps) (l:ls)
| myElem p (x:xs) = l : (removeDeadPats4 (x:xs) ps ls)
| otherwise = removeDeadPats4 (x:xs) ps ls
-- removeDeadPats4 a b c = error $ show (a,b,c)
removeDeadTupleEl _ [] _ _ = return []
removeDeadTupleEl _ _ [] _ = return []
removeDeadTupleEl _ _ _ [] = return []
removeDeadTupleEl pnt (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2)_) _ _)))):ps) e1@[(Exp (HsTuple (e:es)))]
= return e1
-- | x1 == x2 = do
{- | myElem p (x:xs) = do
res <- removeDeadTupleEl pnt (x:xs) ps es
return (e : res)
| otherwise = do res <- removeDeadTupleEl pnt (x:xs) ps es
return res
-}
removeDeadTupleEl p a b [(Exp (HsIf e1 e2 e3))]
= do
-- e1' <- removeDeadTupleEl' a b [e1]
e2' <- removeDeadTupleEl' p a b [e2]
e3' <- removeDeadTupleEl' p a b [e3]
return [(Exp (HsIf e1 e2' e3'))]
removeDeadTupleEl pnt a b [(Exp (HsCase e1 (al:als) ))]
= do
result <- removeDeadAlts (al:als)
return [(Exp (HsCase e1 result))]
where
removeDeadAlts [] = return []
removeDeadAlts ((HsAlt s p (HsBody e) ds):as)
=
case p of
(Pat (HsPTuple s2 (l:ls))) ->
do
if returnRHS pnt e1 && (length (l:ls) == length b)
then do
newPats <- removeDeadPats4' s2 a b (l:ls)
let res = removeDeadCase a b [e]
rest <- removeDeadAlts as
return ((HsAlt s newPats (HsBody (Exp (HsTuple res))) ds):rest)
else do
let res = removeDeadCase a b [e]
rest <- removeDeadAlts as
return ((HsAlt s p (HsBody (Exp (HsTuple res))) ds):rest)
_ ->
do
let res = removeDeadCase a b [e]
rest <- removeDeadAlts as
return ((HsAlt s p (HsBody (Exp (HsTuple res))) ds):rest)
-- | x1 == x2 = e : (removeDeadTupleEl xs ps es)
-- | otherwise = removeDeadTupleEl (x:xs) ps es
removeDeadTupleEl pnt (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2)_) _ _)))):ps) (e:es)
= return (e:es)
{- | myElem p (x:xs) = do
res <- removeDeadTupleEl pnt (x:xs) ps es
return (e : res)
| otherwise = do res <- removeDeadTupleEl pnt (x:xs) ps es
return res
-}
removeDeadTupleEl _ _ _ x = return x
removeDeadTupleEl' p a b e
= do
res <- removeDeadTupleEl p a b e
if length res == 1
then do
let newRes = res !! 0
return newRes
else return (Exp (HsTuple res))
removeDeadCase [] _ _ = []
removeDeadCase _ [] _ = []
removeDeadCase _ _ [] = []
removeDeadCase (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2)_) _ _)))):ps) [(Exp(HsTuple (e:es)))]
| myElem p (x:xs) = e : (removeDeadCase (x:xs) ps es)
| otherwise = removeDeadCase (x:xs) ps es
removeDeadCase (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2)_) _ _)))):ps) (e:es)
| myElem p (x:xs) = e : (removeDeadCase (x:xs) ps es)
| otherwise = removeDeadCase (x:xs) ps es
removeDeadCase _ _ e = e
-- return (d:dss)
removeDeadPatterns a d _ = return d
replaceWithNew a name [] _ = return []
replaceWithNew a name (d@(Dec (HsFunBind loc ms)):dss) total
= do
newMatches <- replaceInMatch ms total
rest <- replaceWithNew a name dss total
return ((Dec (HsFunBind loc newMatches)) : rest)
where
replaceInMatch [] _ = return []
replaceInMatch (m@(HsMatch l i1 ps (HsBody e) ds):ms) total
= do
newExp <- replaceInE a name total e
let newExp2 = cleanNew newExp
rest2' <- replaceWithNew a name ds total
rest' <- replaceInMatch ms total
return ((HsMatch l i1 ps (HsBody newExp2) rest2') : rest')
replaceWithNew a name (d@(Dec (HsPatBind loc p (HsBody e) ds)):dss) total
= do
newExp <- replaceInE a name total e
let newExp2 = cleanNew newExp
rest <- replaceWithNew a name ds total
rest2 <- replaceWithNew a name dss total
return ((Dec (HsPatBind loc p (HsBody newExp2) rest)): rest2)
cleanNew :: HsExpP -> HsExpP
cleanNew e@(Exp (HsTuple l))
| length l == 1 = head l
| otherwise = e
cleanNew e = e
removeName (Exp (HsApp e1 e2))
| removeName e1 == defaultExp = (Exp (HsApp defaultExp e2))
| otherwise = (Exp (HsApp (removeName e1) e2))
removeName e = defaultExp
replaceInE a name total e
= applyTP (once_tdTP (adhocTP idTP (rename' a))) e
where
rename' a e'@(Exp (HsApp e1 e2)::HsExpP)
-- | a /= "a" && a /= "A" = return e
| findPN name e1 = return (Exp (HsTuple (makeTuple (pNtoName name) newCount (removeName e) total newAnswer)))
| findPN name e2 = do newExp <- replaceInE a name total e2
return (Exp (HsApp e1 (newExp) ))
| otherwise = return e'
where
(newCount, newAnswer) = countAnswer 0 a
rename' a e'@(Exp (HsParen e1)::HsExpP) = do newExp <- replaceInE a name total e1
return (Exp (HsParen (newExp)))
rename' a e'@(Exp (HsLet ds e1)::HsExpP) = do newDS <- replaceWithNew a name ds total
newExp <- replaceInE a name total e1
return (Exp (HsLet newDS newExp))
rename' a e'@(Exp (HsIf e1 e2 e3)::HsExpP) = do newExp1 <- replaceInE a name total e1
newExp2 <- replaceInE a name total e2
newExp3 <- replaceInE a name total e3
return (Exp (HsIf newExp1 newExp2 newExp3))
rename' a e'@(Exp (HsTuple (e1:e1s))::HsExpP) = do newExp1 <- replaceInE a name total e1
newExps2 <- mapM (replaceInE a name total) e1s
return (Exp(HsTuple (newExp1 : newExps2)))
rename' a e'@(Exp (HsList (e1:e1s))::HsExpP) = do newExp1 <- replaceInE a name total e1
newExps2 <- mapM (replaceInE a name total) e1s
return (Exp(HsList (newExp1 : newExps2)))
rename' a e'@(Exp (HsLambda ps e1)::HsExpP) = do newExp1 <- replaceInE a name total e1
return (Exp (HsLambda ps newExp1))
rename' a e'@(Exp (HsInfixApp e1 i e2)::HsExpP) = do newExp1 <- replaceInE a name total e1
newExp2 <- replaceInE a name total e2
return (Exp(HsInfixApp newExp1 i newExp2))
rename' a e'@(Exp (HsCase e1 as)::HsExpP) = do newExp1 <- replaceInE a name total e1
newAlts <- mapM (replaceInA name total) as
return (Exp (HsCase newExp1 newAlts))
where
replaceInA name total (HsAlt s p (HsBody e1) ds)
= do
newExp1 <- replaceInE a name total e1
newDS <- replaceWithNew a name ds total
return (HsAlt s p (HsBody newExp1) newDS)
replaceInA name total (HsAlt s p (HsGuard es) ds)
= do
newExp1 <- mapM replaceInG es
newDS <- replaceWithNew a name ds total
return (HsAlt s p (HsGuard newExp1) newDS)
where
replaceInG (s, e1, e2) = do newExp1 <- replaceInE a name total e1
newExp2 <- replaceInE a name total e2
return (s, newExp1, newExp2)
rename' a (x::HsExpP)
| findPN name x = return (Exp (HsTuple (makeSimpleTuple (pNtoName name) newCount total newAnswer)))
| otherwise = return x
where
(newCount, newAnswer) = countAnswer 0 a
makeTuple _ _ _ 0 _= []
makeTuple name i e2 total a
= (Exp (HsApp (nameToExp (name ++ (show i))) e2)) : (makeTuple name newCount e2 (total-1) newAnswer)
where
(newCount, newAnswer) = countAnswer 0 a
makeTuple2 _ _ _ 0 _ = []
makeTuple2 name i e1 total a
= (Exp (HsApp e1 (nameToExp (name ++ (show i))))) : (makeTuple2 name newCount e1 (total-1) newAnswer)
where
(newCount, newAnswer) = countAnswer 0 a
makeSimpleTuple _ _ 0 _ = []
makeSimpleTuple name i total a
= (nameToExp (name ++ (show i))) : (makeSimpleTuple name newCount (total-1) newAnswer)
where
(newCount, newAnswer) = countAnswer 0 a
sortDecls :: ([HsDeclP], [Bool], [PNT]) -> [(HsDeclP, Bool, PNT)]
sortDecls ([],_, _) = []
sortDecls ((d@(Dec (HsFunBind loc (m@(HsMatch l i1 ps (HsBody e) ds):ms))):dss), (b:bs), (s:ss))
= (( (d, b, s) : (findRest i1 (dss, bs, ss) )) ++ sortDecls ((map (\(a,b,c) -> a) (removeAll i1 ((d:dss), (b:bs) , (s:ss))) ) , (map (\(a,b,c) -> b) (removeAll i1 ((d:dss), (b:bs), (s:ss) )) ), (map (\(a,b,c)->c) (removeAll i1 ((d:dss), (b:bs), (s:ss)))) ) )
where
findRest :: PNT -> ([HsDeclP], [Bool], [PNT]) -> [(HsDeclP, Bool, PNT)]
findRest i ([], _, _) = []
findRest i ((d@(Dec(HsFunBind loc (m@(HsMatch l i1 ps (HsBody e) ds):ms))):dss), (b:bs), (s:ss))
| i == i1 = (d, b, s) : (findRest i (dss, bs, ss))
| otherwise = findRest i (dss, bs, ss)
findRest i (_, _, k) = error $ show k
removeAll :: PNT -> ([HsDeclP], [Bool], [PNT]) -> [(HsDeclP, Bool, PNT)]
removeAll i ([], _, _) = []
removeAll i ((d@(Dec(HsFunBind loc (m@(HsMatch l i1 ps (HsBody e) ds):ms))):dss) , (b:bs), (s:ss) )
| i == i1 = removeAll i (dss, bs, ss)
| otherwise = (d,b, s) : (removeAll i (dss, bs, ss) )
correctExpression [] exp = exp
correctExpression (x:xs) exp
| x == defaultExp = correctExpression xs exp
| otherwise = x
get1Element :: HsExpP -> HsExpP
get1Element (Exp (HsTuple (e:es))) = e
get1Element e = e
forEach [] _ _ _ fileName i a _ (inscps, exps, mod, tokList)
= do
return []
forEach (e:es) rhs wh wh3 fileName i a (funName, funPats) (inscps, exps, mod, tokList)
= do
let (newCount, newAnswer) = countAnswer i a
let (begin, end) = getStartEndLoc tokList (get1Element e)
let (loc, pnt, pats, exp, wh2, p)
= findDefNameAndExp tokList
begin
end
mod
-- error $ "1" ++ (show (begin, end))
res <- checkLetAndLambda begin end tokList wh e rhs
let res' = correctExpression res rhs
newExp' <- checkIfOrLet res' e tokList begin end
(refactoredExp,wh') <- checkCase newExp' e wh
res1 <- sliceSubExp p rhs refactoredExp wh' wh3 (head loc) funName pats newCount
res2 <- forEach es rhs wh wh3 fileName newCount newAnswer (funName, funPats) (inscps, exps, mod, tokList)
return (res1 ++ res2)
forEach2 wher [] rhs wh wh3 fileName i a (funName, funPats) (inscps, exps, m, tokList) = do
return []
forEach2 wher (e:es) rhs wh wh3 fileName i a (funName, funPats) (inscps, exps, m, tokList)
= do
let (newCount, newAnswer) = countAnswer i a
let (begin, end) = getStartEndLoc tokList (get1Element e)
let blah@(loc, pnt, pats, exp, wh2, p)
= findDefNameAndExp tokList
begin
end
m
let (begin2, end2) = getStartEndLoc tokList rhs
-- error $ "2" ++ (show (loc, pnt, pats, exp, wh2, p) )
let (_,_, mainPats, _, _,_)
= findDefNameAndExp tokList
begin2
end2
m
res <- checkLetAndLambda begin end tokList wh e rhs
let res' = correctExpression res rhs
newExp' <- checkIfOrLet res' e tokList begin end
(refactoredExp,wh') <- checkCase newExp' e wh
res1 <- sliceSubExp3 wher rhs e pnt p refactoredExp wh' wh3 (head loc) pnt mainPats funPats newCount
res2 <- forEach2 wher es rhs wh wh3 fileName newCount newAnswer (funName, funPats) (inscps, exps, m, tokList)
-- error $ show (res1 ++ res2)
return (res1 ++ res2)
countAnswer :: Int -> String -> (Int, String)
countAnswer i [] = (i, [])
countAnswer i "a" = (i+ 1, "a")
countAnswer i "A" = (i+ 1, "a")
countAnswer i ('_':xs) = countAnswer (i+1) xs
countAnswer i ('x':xs) = ((i+1), xs)
countAnswer i ('X':xs) = ((i+1), xs)
countAnswer i (x:xs) = countAnswer i xs
sliceSubExp2 (_,_,mod) = return mod
sliceSubExp p old exp wh wh2 loc pnt pats i -- (_,_, mod)
= do
(decls, newExp) <- removeRedun wh exp
return (updating p loc pnt pats newExp decls i)
sliceSubExp3 wher funRHS rhs funName p old wh wh2 loc pnt mainPats pats i -- (_,_, mod)
= do
(decls, newExp) <- removeRedun wh rhs
newWher <- removeRedunWhere wher rhs
return [(newDecl3 loc (nameToPNT ((pNTtoName funName) ++ (show i))) pats newExp decls i)]
-- return (updating2 p (wh2++newWher) funRHS funName loc pnt mainPats pats newExp decls i)
changeName newName (PNT (PN (UnQual _) (G modName _ optSrc)) Value s)
= PNT (PN (UnQual newName) (G modName newName optSrc)) Value s
updating (match@(Match x)) loc pnt pats rhs ds i= [Dec (HsFunBind loc0 [newMatch loc pnt pats rhs ds i])]
updating (pat@(MyPat x))loc pnt pats rhs ds i = [newDecl loc pnt pats rhs ds i]
updating x _ _ _ _ _ _ = error $ show x
updating2 (match@(Match x)) wher funRHS funName loc pnt mainPats pats rhs ds i= [Dec (HsFunBind loc0 [newMatch2 wher funRHS funName loc pnt mainPats pats rhs ds i])]
updating2 (pat@(MyPat x)) wher funRHS funName loc pnt mainPats pats rhs ds i = [newDecl2 wher funRHS funName loc pnt mainPats pats rhs ds i]
newMatch loc pnt pats rhs ds i= HsMatch loc (nameToPNT ((pNTtoName pnt) ++ (show i))) pats (HsBody rhs) ds
newDecl loc pnt pats rhs ds i = Dec (HsFunBind loc [HsMatch loc (nameToPNT ((pNTtoName pnt) ++ (show i))) pats (HsBody rhs) ds] )
newMatch2 wher funRHS funName loc pnt mainPats pats rhs ds i= HsMatch loc (nameToPNT ((pNTtoName funName) ++ (show i))) mainPats (HsBody funRHS) ([newDecl3 loc pnt pats rhs ds i] ++ wher)
newDecl2 wher funRHS funName loc pnt mainPats pats rhs ds i = Dec (HsFunBind loc [HsMatch loc (nameToPNT ((pNTtoName funName) ++ (show i))) mainPats (HsBody funRHS) ([newDecl3 loc pnt pats rhs ds i] ++ wher)] )
newDecl3 loc pnt pats rhs ds i = Dec (HsFunBind loc [HsMatch loc pnt pats (HsBody rhs) ds] )
getRHS :: String -> String -> HsDeclP -> PNT -> Bool -> [HsDeclP] -> String -> [([HsExpP], HsExpP, [HsDeclP], [HsDeclP], Bool, [HsPatP])]
getRHS fileName a (Dec (HsPatBind loc p (HsBody e) ds)) pnt local localDefs modName
= res e
where
res e =
case e of
(Exp (HsTuple es)) -> if (getLength1 a e) == (length es)
then [(es, e, ds, [], local, [p])]
else do let l = getLengthAnswer a 0
if (length es) /= l
then error "Please supply the correct number of elements"
else [((shuffleRHS a es), e, ds, [], local, [p])]
(Exp (HsId (HsVar i)))
-> do
let types = getTypes fileName (pNTtoName (patToPNT p) ) modName
let returnType = last types
if local == False
then do
let isTuple = elem '(' returnType && elem ',' returnType && elem ')' returnType
if isTuple
then
if or (map (defines (pNTtoPN i)) ds)
then
do
-- find the definition
let def = findDef i ds
if def == []
then error "Definition does not appear on the RHS"
else
do
let ((listExp, rhs, wh, wh2, localDefs, p'):xs) = (getRHS fileName a (head def) i True ds modName)
((listExp, e, wh, wh2, True, p'):xs)
else
error "Definition does not appear on the RHS"
else error $ show isTuple
else
if or (map (defines (pNTtoPN i)) ds)
then
do
-- find the definition
let def = findDef i ds
if def == []
then error "Definition not defined on RHS"
else
do
let ((listExp, rhs, wh, wh2, localDefs, p'):xs) = (getRHS fileName a (head def) i True ds modName)
((listExp, e, wh, wh2, True, p'):xs)
else
error "Definition not definied on RHS"
(Exp (HsApp e1 e2)) -> do let ((listExp, e', wh, wh2, True, p'):xs) = res e1
((listExp, e, wh, wh2, True, p'):xs)
_ -> [([e], e, ds,[], False, [p])]
getRHS fileName a (Dec (HsFunBind loc ms)) pnt local localDefs modName
= findInMatch ms pnt
where
findInMatch [] _ = []
findInMatch (m@(HsMatch l i1 ps (HsGuard [(s, e1, e2)]) ds):ms) pnt
= findInMatch ((HsMatch l i1 ps (HsBody e2) ds):ms) pnt
findInMatch (m@(HsMatch l i1 ps (HsBody e) ds):ms) pnt
= (res e) ++ (findInMatch ms pnt)
where
mapM2 f [e] = do let ((listExp, e', wh, wh2, localDefs, p):xs) = res e
((listExp, e, wh, wh2, True, p):xs)
mapM2 f (e:es) = do let ((listExp, e', wh, wh2, localDefs, p):xs) = res e
(((e:es), e, wh, wh2, True, p):xs) ++ mapM2 f es
res e =
case e of
(Exp (HsTuple es)) -> if (getLength1 a e) == (length es)
then [(es, e, ds, [], local, ps)]
else do let l = getLengthAnswer a 0
if (length es) /= l
then error "Please supply the correct number of elements"
else [((shuffleRHS a es), e, ds, [], local, ps)] -- [((shuffleRHS a es), e, ds, [], False)]
(Exp (HsId (HsVar i)))
-> do
let types = getTypes fileName (pNTtoName i1) modName
let returnType = last types
if local == False
then do
let isTuple = elem '(' returnType && elem ',' returnType && elem ')' returnType
if isTuple
then
if or (map (defines (pNTtoPN i)) ds)
then
do
-- find the definition
let def = findDef i ds
if def == []
then error ("Definition does not appear on the RHS" ++ (show i))
else
do
let ((listExp, rhs, wh, wh2, localDefs, p):xs) = (getRHS fileName a (head def) i True ds modName)
((listExp, e, wh, wh2, True, p):xs)
else
error "Definition does not appear on the RHS"
else error $ show isTuple
else
if or (map (defines (pNTtoPN i)) ds)
then
do
-- find the definition
let def = findDef i ds
if def == []
then error $ show def
else
do
[([e], e, ds, [] ,True, ps)]
else do
-- let def = definingDecls [(nameToPN (pNTtoName i))] localDefs False False
let def = findDef i localDefs
if def == []
then error ( "Definition does not fully appear on RHS" ++ (show i) )
else
do
let newDec = (Dec (HsFunBind loc [m]))
[([e], e, ds, [] ,True, ps)]
(Exp (HsApp e1 e2)) -> do let ((listExp, e', wh, wh2, True, p):xs) = res e1
((listExp, e, wh, wh2, True, p):xs)
e -> [([e], e, ds,[], False, ps)]
-- findInMatch m pnt = error $ show m
findDef pnt t
= fromMaybe ([])
(applyTU (once_tdTU (failTU `adhocTU` inDef)) t)
where
inDef d@(Dec (HsPatBind loc p (HsBody e) ds))
| pNTtoName (patToPNT p) == pNTtoName pnt = Just [d]
| otherwise = Nothing
inDef d@(Dec (HsFunBind loc ms))
| traverseMS ms = Just [d]
| otherwise = Nothing
where
traverseMS [] = False
traverseMS (m@(HsMatch l i1 ps (HsBody e) ds):ms)
| pNTtoName i1 == pNTtoName pnt = True
| lookInPats ps pnt = True
| otherwise = traverseMS ms
inDef _ = Nothing
lookInPats [] _ = False
lookInPats (p:ps) pnt
| patToPNT p == pnt = True
| otherwise = lookInPats ps pnt
simpleGetRHS (Dec (HsPatBind loc p (HsBody e) ds)) pnt = (e, patToPNT p, ds, [])
simpleGetRHS (Dec (HsFunBind loc ms)) pnt
= findInMatch ms pnt
where
findInMatch [] _ = (defaultExp, defaultPNT, [], [])
findInMatch (m@(HsMatch l i ps (HsBody e) ds):ms) pnt
| findPNT pnt m = (e, i, ds, ps)
| otherwise = findInMatch ms pnt
findInMatch (m@(HsMatch l i ps (HsGuard [(l', e1, e2)]) ds):ms) pnt
| findPNT pnt m = (e2, i, ds, ps)
| otherwise = findInMatch ms pnt
removeFromWhere [] _ = []
removeFromWhere (d:ds) pnt
| defines pnt d = removeFromWhere ds pnt
| otherwise = d : (removeFromWhere ds pnt)
--check whether the cursor points to the beginning of the datatype declaration
--taken from RefacADT.hs
checkCursor :: String -> Int -> Int -> HsModuleP -> Either String HsDeclP
checkCursor fileName row col mod
= case locToTypeDecl of
Nothing -> Left ("Invalid cursor position. Please place cursor at the beginning of the definiton!")
Just decl -> Right decl
where
locToTypeDecl = find (definesPNT (locToPNT fileName (row, col) mod)) (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 pnt _ = 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).
-}
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 [(s, e1, e2)])) ds)::HsMatchP)
| locToExp beginPos endPos toks rhs /= defaultExp
= Just ([loc1], pnt, pats, e2, 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