content: module RefacRedunDec (convertPatsToPn,
                        convertToPat,
                        refacRedunDec,
                        removeRedun,
                        removeRedunWhere,
                        removeRedunWhere2,
                        doRemovingWhere, doRemoving1, doRefac) where
  
  
  import AbstractIO
  import Data.Maybe
  import Data.List
  import RefacUtils
  import RefacLocUtils
  
  data Patt = Match HsMatchP | MyPat HsDeclP | Def [Char]
  
  refacRedunDec 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 "refacRedunDec"
  
         -- Parse the input file.
         modInfo@(inscps, exps, mod, tokList) <- parseSourceFile fileName
  
         -- Find the function that's been highlighted as the refactree
  
         let (loc, pnt, pats, exp, wh, p)
               = findDefNameAndExp tokList
                                   (beginRow, beginCol)
                                   (endRow, endCol)
                                   mod
  
  
         (wh', newExp) <- removeRedunCase exp wh
         (wh'', newExp') <- doRefac wh' newExp
  
         -- (mod',((tokList',modified),_))<-doRemovingWhere fileName mod tokList exp newExp wh'
  
         ((_,_), (tokList', mod')) <- applyRefac (doRemovingWhere exp newExp' wh'') (Just (inscps, exps, mod, tokList)) fileName
  
  
         ((_,m), (tokList'', mod'')) <- applyRefac (doRemoving1 exp newExp' wh'') (Just (inscps, exps, mod', tokList')) fileName
  
  
         writeRefactoredFiles False [((fileName, True), (tokList'', mod''))]
  
      --   error (show mod')
         AbstractIO.putStrLn "Completed.\n"
  
  doRefac wh exp = do
                   (decls, newExp) <- removeRedun wh exp
                   (newWhere) <- removeRedunWhere wh newExp
                   return (newWhere, newExp)
  
  convertToPat [] _ = []
  convertToPat _ [] = []
  convertToPat (pat@(Pat (HsPId (HsVar (PNT (PN x y) Value s)))):ps) ((PN v z):xs)
        | x == v && y == z = pat : (convertToPat ps xs)
        | otherwise        = convertToPat ps ((PN v z):xs)
  
  
  convertPatsToPn [] = []
  convertPatsToPn ((Pat (HsPId (HsVar (PNT (PN x y)Value s )))):ps)
                             = (PN x y): (convertPatsToPn ps)
  convertPatsToPn _ = []
  
  
  --removeRedun :: [HsDeclP] -> HsExpP -> m ([HsDeclP], HsExpP)
  
  removeRedunCase (Exp(HsParen e)) wh
                  = do
                       res <- removeRedunCase e wh
                       return res
  removeRedunCase (Exp(HsCase e alts)) wh
                  = do
                       newAlts <- checkAlts alts
                       return (wh, (Exp (HsCase e newAlts)))
                          where
                             checkAlts [] = do
                                               return []
                             checkAlts ((HsAlt s p1 (HsBody e) ds):xs)
                                = do
                                     decls <- removeRedunWhere ds e
                                     res <- checkAlts xs
                                     return ((HsAlt s p1 (HsBody e) decls) : res)
  
  removeRedunCase (exp@e) wh  = do
                                 return (wh, e)
  
  removeRedun wh (Exp (HsParen e))
     = do
          (wh', newExp) <- removeRedun wh e
          return (wh', (Exp (HsParen newExp)))
  
  removeRedun wh (Exp (HsInfixApp e1 o e2))
   = do
        (wh'1, newExp1) <- removeRedun wh e1
        (wh'2, newExp2) <- removeRedun wh e2
  
        return ( nub ( wh'2 ++ wh), (Exp (HsInfixApp newExp1 o newExp2)))
  
  removeRedun wh (Exp(HsLet ds e)) = do
                                     (_, newE) <- removeRedun wh e
                                     (free, dec) <- hsFreeAndDeclaredPNs newE
                                     let decls = checkFree free ds
                                     let decls' = checkFree free wh
                                     newWhere <- checkWhere wh decls
                                     moreDecls <- checkRestDecls decls' wh
                                     if decls /= []
                                        then do
                                          return ((nub (moreDecls++(decls'++newWhere))), (Exp(HsLet decls newE)))
                                        else do
                                          return ((nub (moreDecls++(decls'++newWhere))), newE)
                                        where
                                           checkWhere [] _ = do return wh
                                           checkWhere wh [] = do return wh
                                           checkWhere wh ((Dec(HsPatBind _ _ (HsBody e)_)):xs)
                                                        = do
                                                             (free, dec) <- hsFreeAndDeclaredPNs e
                                                             let decls = checkFree free wh
                                                             newDecls <- checkWhere decls xs
                                                             moreDecls <- checkRestDecls newDecls wh
                                                             return (nub (moreDecls ++ newDecls))
  removeRedun wh exp@(Exp (HsLambda (p:ps) e))
        = do
             (free, dec) <- hsFreeAndDeclaredPNs e
             -- error $ show (free, (p:ps))
             let decls = myCheckFree e (p:ps)
             let decls' = checkFree free wh
             -- newWhere <- checkWhere wh [(Exp (HsLambda decls e))]
             moreDecls <- checkRestDecls decls' wh
             return ((nub (moreDecls ++ (decls'))), (Exp (HsLambda decls e)))
              where
                myCheckFree e list = checkSin e list
                                         where
                                          checkSin :: HsExpP -> [HsPatP] -> [HsPatP]
                                          checkSin e [] = []
                                          checkSin e (x:xs)
                                            | findPN' (patToPN x) e = x : checkSin e xs
                                            | otherwise   = checkSin e xs
  
                checkWhere [] _ = do return wh
                checkWhere wh [] = do return wh
                checkWhere wh ((Dec(HsPatBind _ _ (HsBody e)_)):xs)
                                     = do
                                         (free, dec) <- hsFreeAndDeclaredPNs e
                                         let decls = checkFree free wh
                                         newDecls <- checkWhere decls xs
                                         moreDecls <- checkRestDecls newDecls wh
                                         return (nub (moreDecls ++ newDecls))
  
  removeRedun wh (exp@(_)) = do return (wh, exp)
  
  removeRedunWhere wh (exp@(_)) = do
                        (free, dec) <- hsFreeAndDeclaredPNs exp
                        let decls = checkFree free wh
                        -- check each declaration that is left for
                        -- declarations that are still needed
                        let dupsRemove = removeDups wh decls
                        moreDecls <- checkRestDecls decls dupsRemove
                        return (nub (decls++moreDecls))
                          where
                            removeDups [] ys = []
                            removeDups (x:xs) ys
                              | x `elem` ys = removeDups xs ys
                              | otherwise   = x : removeDups xs ys
  removeRedunWhere2 wh (exp@(_)) = do
                        (free, dec) <- hsFreeAndDeclaredPNs exp
                        let decls = checkFree2 free wh
                        -- check each declaration that is left for
                        -- declarations that are still needed
                        moreDecls <- checkRestDecls decls wh
  
                        return (nub (decls++moreDecls))
  
  checkRestDecls [] _ = return []
  checkRestDecls wh [] = return []
  checkRestDecls ((Dec (HsPatBind loc1 ps (HsBody e) ds)):rest) (x:[])
                        = do
                            (free, dec) <- hsFreeAndDeclaredPNs e
                            let decls = checkFree free [x]
                            return decls
  
  checkRestDecls ((Dec (HsPatBind loc1 ps (HsBody e) ds)):rest) (x:xs)
                        = do
                            (free, dec) <- hsFreeAndDeclaredPNs e
                            let decls = checkFree free (x:xs)
                           -- moreDecls <- checkRestDecls [x] xs
                            moreDecls <- checkRestDecls decls (x:xs)
                            moreDecls' <- checkRestDecls rest (x:xs)
                            return (decls ++ (moreDecls ++ moreDecls'))
  
  checkRestDecls ((Dec (HsFunBind loc1 ms)):rest) (x:xs)
    = do
         res <- checkRestMatches ms
         let newDec = (Dec (HsFunBind loc1 res))
         moreDecls <- checkRestDecls rest (x:xs)
         return (newDec :  moreDecls)
      where
        checkRestMatches [] = return []
        checkRestMatches (m@(HsMatch l i1 ps (HsBody e) ds):ms)
                        = do
  
                            (free, dec) <- hsFreeAndDeclaredPNs e
                            let decls = checkFree free (x:xs)
                           -- moreDecls <- checkRestDecls [x] xs
                            moreDecls1 <- checkRestMatches ms
                            return moreDecls1
  
  
  doRemoving1 exp newExp wh (_, _, mod)
   = do
        newMod <- doRemoving exp newExp wh mod
        return newMod
  
  
  -- Stafunski function to traverse the AST and find the occurance of the exp that we
  -- are interested in. When the exp is found, the redundant declarations are calculated
  -- and rmDecls in then called.
  -- the rusult is then a new expression with the new list of declarations returned by
  -- rmDecls.
  doRemoving exp newExp wh mod
      =  applyTP (stop_tdTP (failTP `adhocTP` (rmInLet newExp))) mod
  
             where
               rmInLet (new::HsExpP) (letExp@(Exp (HsParen (Exp (HsCase e2 alts2))))::HsExpP)
                  |sameOccurrence letExp exp
                      = do
                           -- error $ show new
                           r <- update letExp (Exp (HsParen new)) letExp
                           return r
                  | otherwise = return (Exp (HsParen new))
  
               rmInLet (new::HsExpP) (letExp@(Exp (HsCase e2 alts2))::HsExpP)
                  | rmLocs letExp == rmLocs exp
                      = do
                           -- error $ show new
                           r <- update letExp new letExp
                           return r
                  | otherwise = return letExp
  
               rmInLet (new@(Exp (HsParen e1))::HsExpP) (letExp@(Exp (HsLet ds e))::HsExpP)
                 = do
                      res <- rmInLet e1 letExp
                      return res
  
               rmInLet (new@(Exp (HsLet ds e1))::HsExpP) (letExp@(Exp (HsParen (Exp (HsLet ds2 e2))))::HsExpP)
                 | sameOccurrence letExp exp == True
                    = do
                       res <- update letExp (Exp (HsParen new)) letExp
                       return res
                 | otherwise = return letExp
  
               --1. The definition to be removed is a local declaration in a let expression
               rmInLet (new@(Exp (HsLet decs e'))::HsExpP) (letExp@(Exp (HsLet ds e))::HsExpP)
                 | sameOccurrence letExp exp == True
                    =do
                        let redunDecs = ds \\ decs
                        ds'<- rmDecls ds redunDecs
                        if ds'==[] then do res <- rmInLet new e
                                           -- r <- update letExp res exp
                                           -- error $ show (tokenise (Pos 0 v1 1) offset False $ printFun)
                                           return res
                                   else do
                                           r <- update letExp (Exp (HsLet ds' e')) letExp
                                           return r
                 | otherwise = do
                                      -- error $ show (new, letExp)
                                      return letExp
  
  
  
               rmInLet e1 (Exp (HsLet ds e)::HsExpP)
                 | sameOccurrence e1 e == True
                    = do
                        ds' <- rmDecls ds ds
                        if ds' == [] then return e1
                                     else return (Exp (HsLet ds' e))
                 | otherwise
                     = return e
  
               rmInLet (new@(Exp (HsParen (Exp (HsLambda ds1 e1))))::HsExpP) (lamExp@(Exp (HsParen (Exp (HsLambda ds e2))))::HsExpP)
                | sameOccurrence lamExp exp == True
                  = do
                       res <- update lamExp new lamExp
                       return res
                | otherwise = return lamExp
  
               rmInLet (new@(Exp (HsParen e1))::HsExpP) (lamExp@(Exp (HsLambda ds e2))::HsExpP)
                 = do
                      res <- rmInLet e1 lamExp
                      return res
  
               rmInLet (new@(Exp (HsLambda decs e'))::HsExpP) (letExp@(Exp (HsParen (Exp (HsLambda ds e))))::HsExpP)
                 | sameOccurrence letExp exp == True
                    =do
                       res <- update letExp (Exp (HsParen new)) letExp
                       return res
                 | otherwise = return letExp
  
  
               rmInLet (new@(Exp (HsLambda decs e'))::HsExpP) (letExp@(Exp (HsLambda ds e))::HsExpP)
                 | sameOccurrence letExp exp == True
                    =do
                       res <- update letExp newExp letExp
                       return res
                 | otherwise =  return letExp
  
  
  
        {-       rmInLet (e1@(Exp (HsLambda _ _))::HsExpP) (e2::HsExpP)
                  = do res <- update e2 newExp e2
                       return res     -}
  
               rmInLet e1 e2@(Exp (HsInfixApp e11 o e22)::HsExpP)
                  | findEntity e1 e11 = do  -- error $ show (e1, e11)
                                            res <- rmInLet e1 e11
                                            r <- update e2 res e2
                                            return r
                  | findEntity e1 e22 = do
                                            res <- rmInLet e1 e22
                                            r <- update e2 res e2
                                            return r
  
               rmInLet e1 e2@(Exp (HsParen e))
                 = do
                      res <- rmInLet e1 e
                      -- r <- update e2 res e2
                      return res
  
               rmInLet e1 e2
                 | sameOccurrence e2 exp == True
                               = do
                                    res <- update e2 e1 e2
                                    return res
                 | otherwise   = return e2
  
               rmDecls wh [] = return wh
               rmDecls wh ((d@(Dec (HsPatBind loc1 pn (HsBody rhs) ds))::HsDeclP):xs)
                    = do
                        let newName = pNTtoPN (patToPNT pn)
                        decls' <- rmDecl newName False wh
                        decls'' <- rmDecls decls' xs
                        return decls''
               rmDecls d _ = return wh
  
  
  doRemovingWhere exp newExp wh (_,_,mod)
       = (applyTP (stop_tdTP (failTP `adhocTP` (rmInPat exp)
                                     `adhocTP` (rmInMatch exp))) mod)
  
       {- runStateT (applyTP (stop_tdTP (failTP `adhocTP` (rmInPat exp)
                                                `adhocTP` (rmInMatch exp)
                                                `adhocTP` rmInCase)) mod) ((tokList,unmodified),fileName) -}
            where
               rmInCase (a@(HsAlt s p1 (HsBody e2) ds)::HsAltP)
                  | findEntity newExp e2
                     =do
                         -- error $ show e2
                         ds' <- removeRedunWhere ds newExp
  
                         -- let redunDecs = ds \\ wh
                         -- ds'<- rmDecls ds [] redunDecs
                         -- let ds' = filter (not . (\x -> x `elem` redunDecs)) ds
                         -- error $ show ds'
                         if ds' == [] then fail ""
                                      else do
                                        r <- update a (HsAlt s p1 (HsBody e2) ds') a
                                        -- return (HsAlt s p1 (HsBody e2) ds')
                                        return r
               rmInCase e2 = fail ""
               rmInPat exp (pat@(Dec (HsPatBind loc p (HsBody rhs) ds))::HsDeclP)
                  | sameOccurrence exp rhs && ds /= []
                     =do
                         --  error "3"
                         redunDecs2 <- removeRedunWhere ds newExp
                         let redunDecs = ds \\ redunDecs2
                         ds'<- rmDecls ds redunDecs
                         return (Dec (HsPatBind  loc p (HsBody rhs) ds'))
                  | sameOccurrence exp rhs && ds == [] && wh /= []
                     = do
                           -- error "2"
                           r <- update pat (Dec (HsPatBind  loc p (HsBody rhs) wh)) pat
                           return r
               rmInPat exp (pat@(Dec (HsPatBind loc p g@(HsGuard es) ds))::HsDeclP)
                  | checkES exp es && ds /= []
                     =do
                         --  error "3"
                         redunDecs2 <- removeRedunWhere ds newExp
                         -- circle through all expressions in guards
                         let firstExp = getExp' es
                         redunDecs3 <- removeRedunWhere ds firstExp
                         gatherRedun <- getExp ds (tail es)
                         -- error $ show (redunDecs2, redunDecs3)
                         let redunDecs = nub (((ds \\ redunDecs2) \\ redunDecs3) \\ gatherRedun)
                         ds'<- rmDecls ds redunDecs
                         return (Dec (HsPatBind loc p g ds'))
                  | checkES exp es && ds == [] && wh /= []
                     = do
                           -- error "2"
                           r <- update pat (Dec (HsPatBind  loc p g wh)) pat
                           return r
               rmInPat _ e2 = fail ""
               rmInMatch exp  (match@(HsMatch loc1  pnt pats (rhs@(HsBody e)) ds)::HsMatchP)
                  | sameOccurrence exp e && wh /= []
                     = do
                          -- ds'' <- addDecl (HsMatch loc1 pnt pats rhs ds) Nothing ((nub (wh++ds)), Nothing) False
                          ds' <- rmDecls ds ds
                          ds'' <- addDecl (HsMatch loc1 pnt pats rhs ds') Nothing (wh, Nothing) False
                          return ds''
                  | sameOccurrence exp e && ds /= []
                     =do
                         redunDecs2 <- removeRedunWhere (nub (ds++wh)) newExp
                         let redunDecs = (ds \\ redunDecs2)
                         ds'<- rmDecls ds redunDecs2
                         -- error $ show redunDecs
                         return (HsMatch loc1 pnt pats rhs ds')
  
                  | sameOccurrence exp e && ds == [] && wh /= []
                      = do
                           -- error (show wh)
                           ds' <- addDecl match Nothing (wh, Nothing) False
                           return ds'
               rmInMatch exp  (match@(HsMatch loc1  pnt pats (rhs@(HsGuard es)) ds)::HsMatchP)
                | checkES exp es && ds /= []
                    =do
                         redunDecs2 <- removeRedunWhere (nub (ds++wh)) newExp
                         -- circle through all expressions in guards
                         let firstExp = getExp' es
                         redunDecs3 <- removeRedunWhere ds firstExp
                         gatherRedun <- getExp ds (tail es)
                         -- error $ show (redunDecs2, redunDecs3)
                         let redunDecs = nub (((ds \\ redunDecs2) \\ redunDecs3) \\ gatherRedun)
                         ds'<- rmDecls ds redunDecs
                         -- error $ show redunDecs
                         return (HsMatch loc1 pnt pats rhs ds')
  
                | checkES exp es && ds == [] && wh /= []
                      = do
                           -- error (show wh)
                           ds' <- addDecl match Nothing (wh, Nothing) False
                           return ds'
  
               rmInMatch _ e2 = fail ""
  
               checkES _ [] = False
               checkES exp ((_,_, e):gs)
                 | sameOccurrence exp e = True
                 | otherwise            = checkES exp gs
  
               getExp ds [] = return []
               getExp ds ((_,e1,e2):gs)
                 = do
                      redunDecs1 <- removeRedunWhere ds e1
                      redunDecs2 <- removeRedunWhere ds e2
                      rest <- getExp ds gs
                      return ((redunDecs1 \\ redunDecs2) \\ rest)
  
               getExp' [] = defaultExp
               getExp' ((_,e1,_):es) = e1
               --error ((show e1) ++ " " ++ (show e2)  )
               rmDecls wh [] = return wh
               rmDecls wh ((d@(Dec (HsPatBind loc1 pn e ds))::HsDeclP):xs)
                    = do
                        let newName = pNTtoPN (patToPNT pn)
                        decls' <- rmDecl newName False wh
                        decls'' <- rmDecls decls' xs
                        return decls''
               rmDecls wh ((d@(Dec (HsFunBind _ ((HsMatch loc pnt pats e ds):ms)))::HsDeclP):xs)
                    = do
                        let newName = pNTtoPN pnt
                        decls' <- rmDecl newName False wh
                        decls'' <- rmDecls decls' xs
                        return decls''
               rmDecls d _ = return wh
  
             {-  rmDecls wh d [] = return []
               rmDecls wh d (((Dec (HsPatBind loc1 pn (HsBody rhs) ds))::HsDeclP):xs)
                    = do
                        let newName = pNTtoPN (patToPNT pn)
                        decls' <- rmDecl newName False wh
                        decls'' <- rmDecls wh decls' xs
                        return decls''
               rmDecls _ d _ = return d -}
  
  newMatch loc pnt pats rhs ds = HsMatch loc pnt pats (HsBody rhs) ds
  newDecl loc pnt pats rhs ds = Dec (HsFunBind loc [HsMatch loc pnt pats (HsBody rhs) ds] )
  
  checkFree :: [PName] -> [HsDeclP] -> [HsDeclP]
  checkFree [] _ = []
  checkFree _ [] = []
  checkFree (p:ps) list = (checkSin p list) ++ (checkFree ps list)
                                   where
                                     checkSin :: PName -> [HsDeclP] -> [HsDeclP]
                                     checkSin p [] = []
                                     checkSin p (x:xs)
                                        | defines p x = [x]
                                        | otherwise   = checkSin p xs
  
  checkFree2 :: [PName] -> [HsDeclP] -> [HsDeclP]
  checkFree2 [] _ = []
  checkFree2 _ [] = []
  checkFree2 (p:ps) list = (checkSin p list) ++ (checkFree ps list)
                                   where
                                     checkSin :: PName -> [HsDeclP] -> [HsDeclP]
                                     checkSin p [] = []
                                     checkSin p (x:xs)
                                        | defines' p x = x : (checkSin p xs)
                                        | otherwise   = checkSin p xs
  
  
  {-|
  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 es)) ds)::HsMatchP)
            = checkES es
                  where
                     checkES [] = Nothing
                     checkES ((s, e1 , e): es)
                       | locToExp beginPos endPos toks e /= defaultExp
                            = Just ([loc1], pnt, pats, e, ds, (Match match))
                       | otherwise = checkES es
        inMatch x = 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 "Please select the result of the function!"
        inPat (pat@(Dec (HsPatBind loc1 ps (rhs@(HsGuard es)) ds))::HsDeclP)
          = checkES es
              where
                 checkES [] = Nothing
                 checkES ((s, e1 , e): es)
                   | locToExp beginPos endPos toks e /= defaultExp
                        = Just ([loc1], patToPNT ps, [], e, ds, (MyPat pat))
                   | otherwise = checkES es
        inPat _ = Nothing
  
  
  
  