----------------------------------------------------------------------------- -- | -- Module : RefacFunDef -- Copyright : (c) Christopher Brown 2005 -- -- Maintainer : cmb21@kent.ac.uk -- Stability : provisional -- Portability : portable -- -- This module contains a transformation for HaRe. -- Function Definition folding. -- Looks for duplicate code and replaces it with a call to the function. -- e.g. -- -- @ square x = x * x @ -- -- @ g x y = x * x + y * y @ -- -- will be refactored to: -- -- @ square x = x * x @ -- -- @ g x y = square x + square y @ -- ----------------------------------------------------------------------------- module RefacFunDef ( -- ** Data types Binding, Environment, NonSetEnv, FunctionPats, WhereDecls, -- * Function types subFunctionDef, checkInWhere, checkInPat, createFunc, createFunc', getEnvironment, canAddBind, checkVal, rewritePatsInEnv, doZip, zipHighlightedMatch, callZipHighlightedMatch, zipHighlightedField, zipHighlightedStmt, -- * Type signatures with argument docs findDefNameAndExp ) where import PrettyPrint import PrettyPrint import PosSyntax import AbstractIO import Maybe import TypedIds import UniqueNames hiding (srcLoc) import PNT import TiPNT import List import RefacUtils import PFE0 (findFile) import MUtils (( # )) import RefacLocUtils import RefacGenFold hiding (FunctionPats, WhereDecls, Er, Patt, Mat, findDefNameAndExp, PatFun) -- | Binds an exp to another e.g. (HsID x, HsLit 5) says x is bound to 5. -- and it continues until the next non-comment line type Binding = (HsExpP, HsExpP) -- | An environment is a *set* of bindings. type Environment = [Binding] {- | An environment that is not yet a set - should be processed into an 'Environment'. -} type NonSetEnv = [Maybe Binding] -- | An argument list for a function which of course is a list of paterns. type FunctionPats = [HsPatP] -- | A list of declarations used to represent a where or let clause. type WhereDecls = [HsDeclP] data PatFun = Mat | Patt | Er deriving (Eq, Show) {- | Function Definition folding. This folding takes a function definition, looks for duplicate code and replaces it with a call to the function. e.g. @ square x = x * x g x y = x * x + y * y @ will be refactored to: @ square x = x * x g x y = square x + square y @ -} subFunctionDef 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 "subFunctionDef" (inscps, exps, mod, tokList) <- parseSourceFile fileName -- Parse the input file. -- (inscps, exps, mod, tokList) <- parseSourceFile fileName -- Find the function that's been highlighted as the refactree let (ty, pnt, pats, subExp, wh) = findDefNameAndExp tokList (beginRow, beginCol) (endRow, endCol) mod let exp = locToExp (beginRow, beginCol) (endRow, endCol) tokList mod {- - Do the refactoring! Returns modifications as below: - mod' - the modified Abstract Syntax Tree - tokList' - the modified Token Stream - m - ??? -} if ty == Mat then do (mod', ((tokList', m), _)) <- runStateT (doZip pnt wh pats subExp mod) ((tokList, False), (0,0)) -- Write out the refactoring writeRefactoredFiles False [((fileName, m), (tokList', mod'))] AbstractIO.putStrLn "Completed.\n" else do (mod', ((tokList', m) , _)) <- runStateT (doSubstitution pnt subExp mod) ((tokList,False),( 0, 0)) writeRefactoredFiles False [((fileName, m), (tokList', mod'))] AbstractIO.putStrLn "Completed.\n" doSubstitution p e = applyTP (full_tdTP (idTP `adhocTP` inMod `adhocTP` inMatch `adhocTP` inPat )) where inMod (mod@(HsModule loc name exps imps ds):: HsModuleP) | p `elem` (map declToPNT ds) = do ds' <- doZipModule ds return (HsModule loc name exps imps ds') where doZipModule t = applyTP (full_tdTP (idTP `adhocTP` inMatch2 `adhocTP` inPat2)) t where inMatch2 (match@(HsMatch loc name pats rhs ds)::HsMatchP) = do (_, declared) <- hsFreeAndDeclaredNames pats (_, declared') <- hsFreeAndDeclaredNames match (_, declared'') <- hsFreeAndDeclaredNames ds if (pNTtoName p) `elem` (declared++(declared'++declared'')) then return match else do e' <- doSubstitution' p e declared rhs return (HsMatch loc name pats e' ds) inPat2 (pat@(Dec (HsPatBind loc pa rhs ds))::HsDeclP) = do (_, declared) <- hsFreeAndDeclaredNames pat (_, declared') <- hsFreeAndDeclaredNames ds if (pNTtoName p) `elem` (declared++declared') then return pat else do e' <- doSubstitution' p e declared rhs return (Dec (HsPatBind loc pa e' ds)) inPat2 x = return x inMod x = return x inMatch (match@(HsMatch loc name pats rhs ds)::HsMatchP) | p `elem` (map declToPNT ds) = do (_, declared) <- hsFreeAndDeclaredNames pats (_, declared') <- hsFreeAndDeclaredNames match if (pNTtoName p) `elem` (declared++declared') then return match else do e' <- doSubstitution' p e declared rhs return (HsMatch loc name pats e' ds) inMatch x = return x inPat (pat@(Dec (HsPatBind loc pa rhs ds))::HsDeclP) | p `elem` (map declToPNT ds) = do (_, declared) <- hsFreeAndDeclaredNames pat if (pNTtoName p) `elem` declared then return pat else do e' <- doSubstitution' p e declared rhs return (Dec (HsPatBind loc pa e' ds)) inPat x = return x doSubstitution' p e declared t = applyTP (stop_tdTP (failTP `adhocTP` subExp)) t where subExp exp@((Exp _)::HsExpP) | sameOccurrence exp e == False = if toRelativeLocs e == toRelativeLocs exp then update exp (createFunc p) exp else mzero | otherwise = mzero createFunc pat = (Exp (HsId (HsVar pat))) {-| 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. -> (PatFun, 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 (Er, defaultPNT, [], defaultExp, []) (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 (Mat, pnt, pats, locToExp beginPos endPos toks rhs, ds) inMatch (match@(HsMatch loc1 pnt pats rhs@(HsGuard e) ds)::HsMatchP) | locToExp beginPos endPos toks rhs /= defaultExp = Just (Mat, pnt, pats, rmGuard rhs, ds) 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 = Just (Patt, patToPNT ps, [], locToExp beginPos endPos toks rhs, ds) --The selected sub-expression is in the rhs of a pattern-binding inPat (pat@(Dec (HsPatBind loc1 ps rhs@(HsGuard es) ds))::HsDeclP) | locToExp beginPos endPos toks rhs /= defaultExp = Just (Patt, patToPNT ps, [], rmGuard rhs, ds) inPat _ = Nothing rmGuard ((HsGuard gs)::RhsP) = let (_,e1,e2)=glast "guardToIfThenElse" gs in if ((pNtoName.expToPN) e1)=="otherwise" then (foldl mkIfThenElse e2 (tail(reverse gs))) else (foldl mkIfThenElse defaultElse (reverse gs)) mkIfThenElse e (_,e1, e2)=(Exp (HsIf e1 e2 e)) defaultElse=(Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "error") (G (PlainModule "Prelude") "error" (N (Just loc0)))) Value (N (Just loc0)))))) (Exp (HsLit loc0 (HsString "UnMatched Pattern"))))) doZip :: (MonadPlus m, Term t, MonadState (([PosToken],Bool),(Int, Int)) m) => PNT -> WhereDecls -> FunctionPats -> HsExpP -> t -> m t doZip p w patsGlob e t = applyTP (full_tdTP (idTP `adhocTP` inMod `adhocTP` inMatch `adhocTP` inPat )) t where inMod (mod@(HsModule loc name exps imps ds):: HsModuleP) | p `elem` (map declToPNT ds) = do ds' <- doZipModule ds return (HsModule loc name exps imps ds') where doZipModule t = applyTP (full_tdTP (idTP `adhocTP` inMatch2 `adhocTP` inPat2)) t where inMatch2 (match@(HsMatch loc name pats rhs ds)::HsMatchP) = do (_, declared) <- hsFreeAndDeclaredNames pats (_, declared') <- hsFreeAndDeclaredNames match (_, declared'') <- hsFreeAndDeclaredNames ds if (pNTtoName p) `elem` (declared++(declared'++declared'')) then return match else do e' <- doZip' p w patsGlob e rhs return (HsMatch loc name pats e' ds) inPat2 (pat@(Dec (HsPatBind loc pa rhs ds))::HsDeclP) = do (_, declared) <- hsFreeAndDeclaredNames pat (_, declared') <- hsFreeAndDeclaredNames ds if (pNTtoName p) `elem` (declared++declared') then return pat else do e' <- doZip' p w patsGlob e rhs return (Dec (HsPatBind loc pa e' ds)) inPat2 x = return x inMod x = return x inMatch (match@(HsMatch loc name pats rhs ds)::HsMatchP) | p `elem` (map declToPNT ds) = do (_, declared) <- hsFreeAndDeclaredNames pats (_, declared') <- hsFreeAndDeclaredNames match if (pNTtoName p) `elem` (declared++declared') then return match else do e' <- doZip' p w patsGlob e rhs return (HsMatch loc name pats e' ds) inMatch x = return x inPat (pat@(Dec (HsPatBind loc pa rhs ds))::HsDeclP) | p `elem` (map declToPNT ds) = do (_, declared) <- hsFreeAndDeclaredNames pat if (pNTtoName p) `elem` declared then return pat else do e' <- doZip' p w patsGlob e rhs return (Dec (HsPatBind loc pa e' ds)) inPat x = return x {-| doZip uses Strafunski to traverse each node of the AST and then performs the folding on each node. -} doZip' :: (MonadPlus m, Term t, MonadState (([PosToken],Bool),(Int, Int)) m) => PNT -> WhereDecls -> FunctionPats -> HsExpP -> t -> m t doZip' p w pats e t = applyTP (stop_tdTP (failTP `adhocTP` (zipExpCheck p w pats e))) t where zipExpCheck p w pats (exp1::HsExpP) (exp2::HsExpP) | sameOccurrence exp1 exp2 == False = do result <- (callZipHighlightedMatch pats w exp1 exp2) let environment = getEnvironment result if result == [Nothing] || environment == Nothing then do fail "" else do let Just env = environment let result' = map (rewritePatsInEnv env) pats update exp2 (createFunc p result') exp2 | otherwise = return exp1 {-| checkVal calls checkAddBind in succession to check that all the bindings can be added to the environment or not. -} checkVal :: NonSetEnv -> Bool checkVal xs = checkValAux xs [] where checkValAux :: NonSetEnv -> Environment -> Bool checkValAux [] _ = True checkValAux ((Just (x,y)) : xs) env = canAddBind (x,y) env && checkValAux xs ((x,y):env) checkValAux (Nothing:xs) env = checkValAux xs env {-| canAddBind takes a binding and some environments, and checks to see whether the binding can be added to the environment or not. The binding will not be added to the environment if that binding already exists within the environment. canAddBind returns True if the binding can be added, and False if it cannot. -} canAddBind :: Binding -> Environment -> Bool canAddBind _ [] = True canAddBind (x,y) ((x',y'):xs) = (x1 == x1' && y1 == y1') || (x1 /= x1' && canAddBind (x,y) xs) where [x1,x1',y1,y1'] = map toRelativeLocs [x,x',y,y'] {-| getEnvironment takes a list of bindings and removes the duplicates within the bindings -} getEnvironment :: NonSetEnv -> Maybe Environment getEnvironment [] = Just [] getEnvironment (Nothing: xs) = getEnvironment xs getEnvironment (Just (x,y):xs) = case subEnv of Nothing -> Nothing Just env -> if canAddBind (x,y) env then Just ((x,y):env) else Nothing where subEnv = getEnvironment xs {-| rewritePatsInEnv takes the Environment and a pattern belonging to the argument list of the function the user is folding against. rewritePatsInEnv then forms an expression based on this pattern taking into consideration the environment. This is used when forming the function call e.g. @ Environment = [("x", [1,2,3]), ("y", 1)] pat = (x,y) @ would return... @ HsTuple ([1,2,3], 1) @ -} rewritePatsInEnv :: Environment -> HsPatP -> HsExpP rewritePatsInEnv [] p = error "Empty Environment!" rewritePatsInEnv env (pat1@(Pat (HsPRec x y))) = Exp (HsRecConstr loc0 x (map (sortField env) y)) where sortField :: Environment -> HsFieldI a HsPatP -> HsFieldI a HsExpP sortField env (HsField i e) = (HsField i (rewritePatsInEnv env e)) rewritePatsInEnv env (pat1@(Pat (HsPLit x y))) = Exp (HsLit x y) rewritePatsInEnv env (pat1@(Pat (HsPAsPat i p1))) = Exp (HsAsPat i (rewritePatsInEnv env p1)) rewritePatsInEnv env (pat1@(Pat (HsPIrrPat p1))) = Exp (HsIrrPat (rewritePatsInEnv env p1)) rewritePatsInEnv env (pat1@(Pat (HsPWildCard))) = nameToExp "undefined" rewritePatsInEnv env (pat1@(Pat (HsPApp i p1))) = createFunc i (map (rewritePatsInEnv env) p1) rewritePatsInEnv env (pat1@(Pat (HsPList _ p1))) = Exp (HsList (map (rewritePatsInEnv env) p1)) rewritePatsInEnv env (pat1@(Pat (HsPTuple _ p1))) = Exp (HsTuple (map (rewritePatsInEnv env) p1)) rewritePatsInEnv env (pat1@(Pat (HsPInfixApp p1 x p2))) = Exp (HsInfixApp (rewritePatsInEnv env p1) (HsCon x) (rewritePatsInEnv env p2)) rewritePatsInEnv env (pat@(Pat (HsPParen p1))) = Exp (HsParen (rewritePatsInEnv env p1)) rewritePatsInEnv env (pat1@(Pat (HsPId (HsVar (PNT (PN (UnQual i) _) _ _))))) = if findRewrites i == [] then nameToExp "undefined" else snd (head (findRewrites i)) where findRewrites i = filter (checkPat i) env checkPat i (Exp (HsId (HsVar (PNT (PN (UnQual i2) _) _ _))), (Exp z)) = i == i2 checkPat i _ = False {-| callZipHighlightedMatch simply calls the function zipHighlightedMatch and then returns the value wrapped in a monad -} callZipHighlightedMatch :: Monad m => FunctionPats -> WhereDecls -> HsExpP -> HsExpP -> m NonSetEnv callZipHighlightedMatch pats w (exp1::HsExpP) (exp2::HsExpP) = do zippedE1 <- zipHighlightedMatch False pats w exp1 exp2 return zippedE1 {- | zipHighlightedMatch takes a list of patterns (the list of arguments for the function highlighted, the where clause associated with the function, the expression that has been highlighted and the expression that we are trying to fold against. zipHighlightedMatch then checks to see if the the expressions can be paired. The expressions will only be paired if: both expressions have the ssame type e.g. refactoron -> [1,2,3,4] refactorod -> [1,2,3,4] becomes ([1,2,3,4], [1,2,3,4]) or, the highlighted expression is an idenitfier, in which case a pair is always created, unless the idenitifier does not appear in the argument list (pats) -} zipHighlightedMatch :: Monad m => Bool -> FunctionPats -> WhereDecls -> HsExpP -> HsExpP -> m NonSetEnv zipHighlightedMatch b pats w (exp1@(Exp (HsId (HsCon i1)))::HsExpP) (exp2@(Exp (HsId (HsCon i2)))::HsExpP) | i1 == i2 = return [ Just (exp1, exp2) ] | otherwise = return [ Nothing ] zipHighlightedMatch b pats w (exp1@(Exp (HsId (HsCon i1)))::HsExpP) (exp2::HsExpP) = return [ Nothing ] zipHighlightedMatch True pats w (exp1@(Exp (HsId i1))::HsExpP) (exp2@(Exp (HsId i2))::HsExpP) | not (checkDefs i1 i2) = fail "untouched" | checkInPat pats exp2 = return [ Just (exp1, exp2) ] -- | checkInPat pats exp1 = return [ Just (exp1, exp2) ] | checkGlobal i1 i2 = return [ Just (exp1, exp2) ] | not (checkInWhere w exp1) = return [Nothing] | otherwise = fail "untouched" where checkGlobal (HsVar i1) (HsVar i2) = (pNTtoPN i1) == (pNTtoPN i2) checkGlobal _ _ = False zipHighlightedMatch False pats w (exp1@(Exp (HsId i1))::HsExpP) (exp2@(Exp (HsId i2))::HsExpP) | checkInPat pats exp1 = return [ Just (exp1, exp2) ] | checkGlobal i1 i2 = return [ Just (exp1, exp2) ] | not (checkInWhere w exp1) = return [Nothing] | otherwise = fail "untouched" where checkGlobal (HsVar i1) (HsVar i2) = (pNTtoPN i1) == (pNTtoPN i2) checkGlobal _ _ = False zipHighlightedMatch b pats w (exp1@(Exp (HsId i))::HsExpP) (exp2::HsExpP) | checkInPat pats exp1 == True && checkInWhere w exp1 /= True = return [ Just (exp1, exp2) ] | otherwise = fail "untouched" zipHighlightedMatch b pats w (exp1@(Exp (HsLit _ i1))::HsExpP) (exp2@(Exp (HsLit _ i2))::HsExpP) | i1 == i2 = return [ Just (exp1, exp2) ] | otherwise = return [ Nothing ] zipHighlightedMatch b pats w (exp1@(Exp (HsLit _ _))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsInfixApp e1 i e2))::HsExpP) (exp2@(Exp (HsInfixApp e11 i2 e22))::HsExpP) | i == i2 = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 zippedE2 <- zipHighlightedMatch b pats w e2 e22 if zippedE1 == [ Nothing ] || zippedE2 == [ Nothing ] then return [ Nothing ] else return (zippedE1 ++ zippedE2) | otherwise = return [ Nothing ] zipHighlightedMatch b pats w (exp1@(Exp (HsInfixApp e1 i e2))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsApp e1 e2))::HsExpP) (exp2@(Exp (HsApp e11 e22))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 zippedE2 <- zipHighlightedMatch b pats w e2 e22 if zippedE1 == [Nothing] || zippedE2 == [ Nothing ] then return [Nothing] else return (zippedE1 ++ zippedE2) zipHighlightedMatch b pats w (exp1@(Exp (HsApp e1 e2))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsNegApp _ e1))::HsExpP) (exp2@(Exp (HsNegApp _ e2))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e2 return zippedE1 zipHighlightedMatch b pats w (exp1@(Exp (HsNegApp _ e1))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsLambda ps e1))::HsExpP) (exp2@(Exp (HsLambda ps2 e11))::HsExpP) | wildCardAllPNs ps == wildCardAllPNs ps2 = do zippedE1 <- zipHighlightedMatch b pats w e1 (localRewriteExp e11 (localRewritePats ps ps2)) return zippedE1 where localRewritePats [] ps = [] localRewritePats ps [] = [] localRewritePats (p1:p1s) (p2:p2s) = (rewritePat p2 p1) : (localRewritePats p1s p2s) localRewriteExp e [] = e localRewriteExp e (p1:p1s) = let e1' = rewritePatsInExp p1 e in localRewriteExp e1' p1s zipHighlightedMatch b pats w (exp1@(Exp (HsLet _ e1))::HsExpP) (exp2@(Exp (HsLet _ e11))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 return zippedE1 zipHighlightedMatch b pats w (exp@(Exp (HsLet _ e1))::HsExpP) (exp2::HsExpP) = fail "" zipHighlightedMatch b pats w (exp1@(Exp (HsLambda _ e1))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsIf e1 e2 e3))::HsExpP) (exp2@(Exp (HsIf e11 e22 e33))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 zippedE2 <- zipHighlightedMatch b pats w e2 e22 zippedE3 <- zipHighlightedMatch b pats w e3 e33 return (zippedE1 ++ zippedE2 ++ zippedE3) zipHighlightedMatch b pats w (exp1@(Exp (HsIf e1 e2 e3))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsCase e1 (alt@(HsAlt _ p1 e2 ds1):alts1)))::HsExpP) (exp2@(Exp (HsCase e11 (alt2@(HsAlt _ p11 e22 ds11):alts2) ))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 res <- zippedAlts (alt:alts1) (alt2:alts2) if res == [Nothing] then return [Nothing] else return (zippedE1 ++ res) where zippedAlts [] alts = return [] zippedAlts alts [] = return [] zippedAlts ((HsAlt _ p1 (HsBody exp1) ds1):alts1) ((HsAlt _ p11 (HsBody exp2) ds11):alts2) | wildCardAllPNs p1 == wildCardAllPNs p11 = do zippedE1 <- zipHighlightedMatch b pats w exp1 (rewritePatsInExp (rewritePat p11 p1) exp2) if zippedE1 == [Nothing] then return [Nothing] else do res <- zippedAlts alts1 alts2 if res == [Nothing] then return [Nothing] else return (zippedE1 ++ res) | otherwise = return [Nothing] zippedAlts ((HsAlt _ p1 (HsGuard g1) ds1):alts1) ((HsAlt _ p22 (HsGuard g2) ds11):alts2) | wildCardAllPNs p1 == wildCardAllPNs p22 = do zippedE1 <- zippedGuards g1 (rewritePatsInGuard (rewritePat p22 p1) g2) -- error $ show zippedE1 if zippedE1 == [Nothing] then return [Nothing] else do res <- zippedAlts alts1 alts2 if res == [Nothing] then return [Nothing] else return (zippedE1 ++ res) where zippedGuards _ [] = return [] zippedGuards [] _ = return [] zippedGuards ((_, e1, e2):gs1) ((_, e3, e4):gs2) = do e1' <- zipHighlightedMatch True pats w e1 e3 e2' <- zipHighlightedMatch True pats w e2 e4 res <- zippedGuards gs1 gs2 return ((e1' ++ e2') ++ res) zippedAlts _ _ = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsCase e1 ((HsAlt _ e2 p1 ds1):alts1) ))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsDo (stat1)))::HsExpP) (exp2@(Exp (HsDo (stat2)))::HsExpP) = do zippedE1 <- zipHighlightedStmt pats w stat1 stat2 return zippedE1 zipHighlightedMatch b pats w (exp1@(Exp (HsDo (stat1)))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsTuple ([e1])))::HsExpP) (exp2@(Exp (HsTuple ([e11])))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 return zippedE1 zipHighlightedMatch b pats w (exp1@(Exp (HsTuple (e1:e1s)))::HsExpP) (exp2@(Exp (HsTuple (e11:e11s)))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 result <- zippedE2 e1s e11s if result == [Nothing] || zippedE1 == [Nothing] then return [Nothing] else return (zippedE1 ++ result) where zippedE2 [] [] = return [] zippedE2 _ [] = return [Nothing] zippedE2 [] _ = return [Nothing] zippedE2 (x:xs) (y:ys) = do result1 <- zipHighlightedMatch b pats w x y result2 <- zippedE2 xs ys if result1 == [Nothing] || result2 == [Nothing] then return [Nothing] else return (result1 ++ result2) zipHighlightedMatch b pats w (exp1@(Exp (HsTuple (e1:e1s)))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsList ([e1])))::HsExpP) (exp2@(Exp (HsList ([e11])))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 return zippedE1 zipHighlightedMatch b pats w (exp1@(Exp (HsList (e1:e1s)))::HsExpP) (exp2@(Exp (HsList (e11:e11s)))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 result <- zippedE2 e1s e11s -- error (show zippedE1 ++ " " ++ show result) if result == [Nothing] || zippedE1 == [Nothing] then return [Nothing] else return (zippedE1 ++ result) where zippedE2 [] [] = return [] zippedE2 _ [] = return [Nothing] zippedE2 [] _ = return [Nothing] zippedE2 (x:xs) (y:ys) = do result1 <- zipHighlightedMatch b pats w x y result2 <- zippedE2 xs ys if result1 == [Nothing] || result2 == [Nothing] then return [Nothing] else return (result1 ++ result2) zipHighlightedMatch b pats w (exp1@(Exp (HsList (e1:e1s)))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsParen e1))::HsExpP) (exp2@(Exp (HsParen e11))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 return zippedE1 zipHighlightedMatch b pats w (exp1@(Exp (HsParen e1))::HsExpP) (exp2::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 exp2 return zippedE1 zipHighlightedMatch b pats w (exp1::HsExpP) (exp2@(Exp (HsParen e2))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w exp1 e2 return zippedE1 zipHighlightedMatch b pats w (exp1@(Exp (HsLeftSection e1 i1))::HsExpP) (exp2@(Exp (HsLeftSection e11 i2))::HsExpP) | i1 == i2 = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 return zippedE1 | otherwise = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsLeftSection e1 i1))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsRightSection i1 e1))::HsExpP) (exp2@(Exp (HsRightSection i2 e11))::HsExpP) | i1 == i2 = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 return zippedE1 | otherwise = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsRightSection i1 e1))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsRecConstr _ i1 i2 ))::HsExpP) (exp2@(Exp (HsRecConstr _ i11 i22 ))::HsExpP) | i1 == i11 = do zippedE1 <- zipHighlightedField pats w i2 i22 return zippedE1 | otherwise = do return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsRecConstr _ i1 i2))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsRecUpdate _ e1 i1))::HsExpP) (exp2@(Exp (HsRecUpdate _ e11 i11))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 zippedE2 <- zipHighlightedField pats w i1 i11 return (zippedE1 ++ zippedE2) zipHighlightedMatch b pats w (exp1@(Exp (HsRecUpdate _ e1 i1))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsEnumFrom e1))::HsExpP) (exp2@(Exp (HsEnumFrom e11))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 return zippedE1 zipHighlightedMatch b pats w (exp1@(Exp (HsEnumFrom e1))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsEnumFromTo e1 e2))::HsExpP) (exp2@(Exp (HsEnumFromTo e11 e22))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 zippedE2 <- zipHighlightedMatch b pats w e2 e22 return (zippedE1 ++ zippedE2) zipHighlightedMatch b pats w (exp1@(Exp (HsEnumFromTo e1 e2))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsEnumFromThen e1 e2))::HsExpP) (exp2@(Exp (HsEnumFromThen e11 e22))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 zippedE2 <- zipHighlightedMatch b pats w e2 e22 return (zippedE1 ++ zippedE2) zipHighlightedMatch b pats w (exp1@(Exp (HsEnumFromThen e1 e2))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsEnumFromThenTo e1 e2 e3))::HsExpP) (exp2@(Exp (HsEnumFromThenTo e11 e22 e33))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 zippedE2 <- zipHighlightedMatch b pats w e2 e22 zippedE3 <- zipHighlightedMatch b pats w e3 e33 return (zippedE1 ++ zippedE2 ++ zippedE3) zipHighlightedMatch b pats w (exp1@(Exp (HsEnumFromThenTo e1 e2 e3))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsListComp (stat1)))::HsExpP) (exp2@(Exp (HsListComp (stat2)))::HsExpP) = do zippedE1 <- zipHighlightedStmt pats w stat1 stat2 return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsListComp (stat1)))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsExpTypeSig _ e1 c1 t1))::HsExpP) (exp2@(Exp (HsExpTypeSig _ e2 c2 t2))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e2 return zippedE1 zipHighlightedMatch b pats w (exp1@(Exp (HsExpTypeSig _ e1 c1 t1))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsAsPat i1 e1))::HsExpP) (exp2@(Exp (HsAsPat i11 e11))::HsExpP) | i1 == i11 = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 return zippedE1 | otherwise = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsAsPat i1 e1))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1@(Exp (HsIrrPat e1))::HsExpP) (exp2@(Exp (HsIrrPat e11))::HsExpP) = do zippedE1 <- zipHighlightedMatch b pats w e1 e11 return zippedE1 zipHighlightedMatch b pats w (exp1@(Exp (HsIrrPat e1))::HsExpP) (exp2::HsExpP) = return [Nothing] zipHighlightedMatch b pats w (exp1::HsExpP) (exp2::HsExpP) = return [Nothing] {-| zipHighlightedField takes the highlighted expression , and takes the expression that we are folding against. If they are both fields, it then calls zipHiglightedMatch to pair up the expressions within the fields. -} zipHighlightedField :: Monad m => FunctionPats -> WhereDecls -> HsFieldsI PNT (HsExpI PNT) -> HsFieldsI PNT (HsExpI PNT) -> m NonSetEnv zipHighlightedField pats w [] _ = return [Nothing] zipHighlightedField pats w _ [] = return [Nothing] zipHighlightedField pats w ((fiel1@(HsField i1 e1)):xs) ((fiel2@(HsField i11 e11)):ys) = if i1 == i11 then do zippedE1 <- zipHighlightedMatch False pats w e1 e11 return zippedE1 else do return [Nothing] checkDefs (HsVar p1@(PNT (PN (UnQual i) (_) ) _ _ )) (HsVar p2@(PNT (PN (UnQual i2) (_) ) _ _ )) = i == i2 checkDefs _ _ = False {-| checkInPat checks that the Expression (supplied as 2nd argument) occurs within the Function Arugment List. checkInPat needs to check for every case that expression could be e.g. literals, lists, tuples and records. if the expression occurs then the function returns True otherwise returns False. -} checkInPat :: FunctionPats -> HsExpP -> Bool checkInPat (pat1@(Pat (HsPRec x y)):pats) exp | (checkField y) == False = (checkInPat pats exp) | otherwise = True where checkField ((HsField i e):xs) | (checkInPat [e] exp) == False = (checkField xs) | otherwise = True checkInPat (pat1@(Pat (HsPIrrPat p)):pats) exp | (checkInPat [p] exp) == False = checkInPat pats exp | otherwise = True checkInPat (pat1@(Pat (HsPAsPat i p)):pats) exp | (checkInPat [p] exp) == False = checkInPat pats exp | otherwise = True checkInPat (pat1@(Pat (HsPWildCard)):pats) exp = checkInPat pats exp checkInPat (pat1@(Pat (HsPId (HsVar (PNT p@(PN (UnQual i) (_) ) _ _ )))):pats) (exp1@(Exp (HsId (HsVar (PNT p2@(PN (UnQual i2) (_) ) _ _ ))))::HsExpP) = if p == p2 then True else checkInPat pats exp1 {- = if i == i2 then True else checkInPat pats exp1 -} checkInPat (pat1@(Pat (HsPParen pat)):pats) exp | (checkInPat [pat] exp) == False = checkInPat pats exp | otherwise = True checkInPat (pat@(Pat (HsPInfixApp pat1 x pat2)):pats) exp | (checkInPat [pat1] exp) == False && (checkInPat [pat2] exp) == False = checkInPat pats exp | otherwise = True checkInPat (pat@(Pat (HsPTuple _ pat1)):pats) exp | (checkInPat pat1 exp) == False = checkInPat pats exp | otherwise = True checkInPat (pat@(Pat (HsPList _ pat1)):pats) exp | (checkInPat pat1 exp) == False = checkInPat pats exp | otherwise = True checkInPat (pat@(Pat (HsPApp i pat1)):pats) exp | (checkInPat pat1 exp) == False = checkInPat pats exp | otherwise = True checkInPat ((Pat (HsPLit _ (HsInt x))):pats) exp1 = checkInPat pats exp1 checkInPat _ _ = False {-| checkInWhere checks that where clause of the function does not contain the expressions (as second argument). If it does the function returns True, otherwise returns False. -} checkInWhere :: [HsDeclP] -> HsExpP -> Bool checkInWhere [] _ = False checkInWhere (wh@(Dec (HsPatBind _ (Pat (HsPId (HsVar (PNT (PN (UnQual i) _ ) _ _ ) ) ) ) _ rest)):ws) (exp1@(Exp (HsId (HsVar (PNT (PN (UnQual i2) _ ) _ _ ))))::HsExpP) = i == i2 -- extractHsBody simply extracts the expression within an HsBody -- and returns that Expression. extractHsBody (HsBody exp) = return exp extractHsBody _ = error "Case must contain HsBody" {-| zipHighLightedStmt checks that two statements are identical, if they are, zipHighLightedStmt returns the two statements paired together -} zipHighlightedStmt :: Monad m => FunctionPats -> WhereDecls -> HsStmtP -> HsStmtP -> m NonSetEnv zipHighlightedStmt pats w (exp1@(HsGenerator _ p1 e1 e1')::HsStmtP) (exp2@(HsGenerator _ p2 e2 e2')::HsStmtP) | wildCardAllPNs p1 == wildCardAllPNs p2 = do zippedE1 <- zipHighlightedMatch False pats w e1 e2 zippedE2 <- zipHighlightedStmt pats w e1' e2' return (zippedE1 ++ zippedE2) zipHighlightedStmt pats w (exp1@(HsQualifier e1 e1')::HsStmtP) (exp2@(HsQualifier e2 e2')::HsStmtP) = do zippedE1 <- zipHighlightedMatch False pats w e1 e2 zippedE2 <- zipHighlightedStmt pats w e1' e2' return [Nothing] zipHighlightedStmt pats w (exp1@(HsLetStmt ds1 e1)::HsStmtP) (exp2@(HsLetStmt ds2 e2)::HsStmtP) = do zippedE1 <- zipHighlightedStmt pats w e1 e2 return zippedE1 zipHighlightedStmt pats w (exp1@(HsLast e1)::HsStmtP) (exp2@(HsLast e2)::HsStmtP) = do zippedE1 <- zipHighlightedMatch False pats w e1 e2 return zippedE1 zipHighlightedStmt pats w (exp1::HsStmtP) (exp2::HsStmtP) = return [Nothing]