content: -----------------------------------------------------------------------------
  -- |
  -- 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 Data.Maybe
  import Data.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
        
      
      
  