-----------------------------------------------------------------------------
-- |
-- Module      :  DuplicateCode
-- Copyright   :  (c) Christopher Brown 2007
--
-- Maintainer  :  cmb21@kent.ac.uk
-- Stability   :  provisional
-- Portability :  portable
--
-- This module contains a duplicate code analysis tool
-- that works over the HaRe infrastructure.
-- Comparing two Haskell source files at the token stream level
-- this module constructs a report based on the structural 
-- duplication of the two source files.
--
-- VERSION
-- -------
-- 02 January 2007: 0.0 -- basic implementation set up.
-- 22 Januray 2007: 0.1 -- fully working alpha equivalence with textual output
--                         in the form of a report.
--
-- 31 July 2008: 0.2  -- rewrite to compare expressions via AST using 
--                       avoidance of capture.
--
-----------------------------------------------------------------------------

module DuplicateCode where
import Time
import PrettyPrint
import System.IO.Unsafe
import PosSyntax hiding (ModuleName, HsName, SN)
import SourceNames 
import ScopeModule
import UniqueNames hiding (srcLoc)
import HsName
import HsLexerPass1
import PNT 
import TiPNT
import SimpleGraphs(reverseGraph,reachable)
import HsTokens
import RefacTypeSyn
import RefacLocUtils
import Data.Char
import GHC.Unicode
import AbstractIO
import Maybe
import List
import RefacUtils
import LocalSettings
import Data.Function
import RefacGenFold (expToPat)


-- as this module is not a transformation, we will not need to modify
-- the source files in question. It is still necessary to import the 
-- HaRe API, in all it's glory, to gain access to tree traversals.

type Group = ([HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP]) 

emptyGroup = ([],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[])


-- define the clone type; E = clone is an Expression;
--                        G = clone is a list of Generators: monadic patterns;
--                        S = clone is a monadic sequence (including generators).
data CloneType = E (HsExpP, String) | G (HsStmtP, String) | S (HsStmtP, String)
                    deriving (Eq, Show, Read, Ord)

-- the filenames need to be given with their full file path
-- unless they appear in the same directory as the executable.

-- We use the concept of a line number quite a lot, so let's define it:

type LineNumber = Int

-- the idea is to look for expressions of a particular
-- size and repetition. For the moment, we use two constants
-- to define this...
-- expressionSize = 5
-- expression size is a variable to determine the size of the expressions
-- we need to look for expressions as close to size 10 as possible.

expressionRep = 1
-- expressionRep determines how many times a particular expression
-- may occur in a code clone. 
-- for example: x + y + z      x + y occurs twice...


duplicateCode args
  = do let 
           fileName1    = args!!0    
           expressionSize = read (args!!1) :: Int  
       AbstractIO.putStrLn "duplicateCode Analysis" 
       timeone <- AbstractIO.getClockTime
       -- we work over a project, so we take the name of the current 
       -- (hopefully main module) and work over it all, in turn....
       let fileName2 = fileName1
       modName <- fileNameToModName fileName1
       
       -- the analysis should be perform over the main module...
       -- get a list of all the modules that are imported directly, or indirectly,
       -- by Main...
       servers<-serverModsAndFiles modName -- returns [(module name ,filename)] 
       -- we arn't interested in the libraries yet though.
       -- I guess it's OK to strip away those not defined in current directory...
              
       let directory = getDirectory fileName1
           servers' = stripServers servers directory
       rest <- parseAll expressionSize servers' -- hardServers  
       modInfo1@(inscps1, exps1, mod1, tokList1) <- parseSourceFile fileName1
       -- for each module in our project, we need to normalise the token streams.
       -- we then concatenate the token streams together, and perform
       -- a big analysis over that. Question? How do we remember
       -- which module we are talking about?
       -- tokList1' <- normaliseTokens fileName1 mod1 tokList1
       -- AbstractIO.putStrLn tokList1'

       -- normalize the AST. We Alpa-Reduce all local variables
       -- to "$" (as they can be passed in as parameters)
       -- top level decs are left alone.
       -- mod' <- renameAST mod1
       
       asts <- genExpList expressionSize tokList1 mod1
       let groupAST = groupExps asts emptyGroup
       duplications <- loop expressionSize ((mod1, tokList1, fileName1, groupAST):rest) 
       duplications' <- removeDuplicates (concat duplications)
       -- display generates a report of the duplications
       -- and writes them to a file for further processing...
       
       let display = prettyPrint duplications' (map (\(x,y,z,_) -> (y,z)) ((mod1, tokList1, fileName1, groupAST):rest)) 
           duplications'' = prettyPrint2 duplications' (map (\(x,y,z,_) -> (y,z)) ((mod1, tokList1, fileName1, groupAST):rest)) 
       AbstractIO.writeFile reportFilePath display
       
       -- for now, print this to the screen also
       AbstractIO.writeFile transFilePath (show duplications'')
       AbstractIO.writeFile answerFilePath ""
       AbstractIO.putStrLn ("Clone analysis complete. Report delivered to: " ++ reportFilePath)
       timetwo <- AbstractIO.getClockTime  
       AbstractIO.putStrLn $ show $ diffClockTimes timetwo timeone

--Takes an AST and returns a list of tuples containing the string equivalent of the
-- Expression name, and the start & finish locations of the Expression
-- genExpList :: (Term t) => t -> [HsExpP]
genExpList expressionSize tokList ast = applyTU (full_tdTU ( constTU [] `adhocTU` isExp)) ast
    where 
    
             isExp (Exp (HsTuple [])) = return []
             isExp (Exp (HsList [])) = return []
             isExp (Exp (HsLet _ _)) = return []
             isExp (a::HsExpP)= do
                                let (start, end)  = getStartEndLoc tokList a
                                let tokExpression = getToks (start, end) tokList
                                if (length (filter (not. isWhite') tokExpression)) < expressionSize
                                     then return []
                                     else return [a]


getGroup :: HsExpP -> Group -> [HsExpP]
getGroup (Exp (HsId x)) g = getId g
getGroup (Exp (HsLit s i)) g = getLit g
getGroup (Exp (HsInfixApp _ _ _)) g = getInfix g
getGroup (Exp (HsApp _ _)) g = getApp g
getGroup (Exp (HsNegApp _ _)) g = getNegApp g
getGroup (Exp (HsLambda _ _)) g = getLambda g
getGroup (Exp (HsLet _ _)) g = getLet g
getGroup (Exp (HsIf _ _ _)) g = getIf g
getGroup (Exp (HsCase _ _)) g = getCase g
getGroup (Exp (HsDo _)) g = getDo g
getGroup (Exp (HsTuple _)) g = getTuple g
getGroup (Exp (HsList _)) g = getList g
getGroup (Exp (HsParen _)) g = getParen g
getGroup (Exp (HsLeftSection _ _)) g = getLeft g
getGroup (Exp (HsRightSection _ _)) g = getRight g
getGroup (Exp (HsRecConstr _ _ _)) g = getRecConstr g
getGroup (Exp (HsRecUpdate _ _ _)) g = getRecUpdate g
getGroup (Exp (HsEnumFrom _)) g = getEnumFrom g
getGroup (Exp (HsEnumFromTo _ _)) g = getEnumFromTo g
getGroup (Exp (HsEnumFromThen _ _)) g = getEnumFromThen g
getGroup (Exp (HsEnumFromThenTo _ _ _)) g = getEnumFromThenTo g
getGroup (Exp (HsListComp _)) g = getListComp g
getGroup (Exp (HsExpTypeSig _ _ _ _)) g = getTypeSig g
getGroup (Exp (HsAsPat _ _)) g = getAsPat g
getGroup (Exp (HsWildCard)) g = getWildCard g
getGroup (Exp (HsIrrPat _)) g = getIrrPat g

getId :: Group -> [HsExpP]
getId (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = a
getLit :: Group -> [HsExpP]
getLit (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = b
getInfix :: Group -> [HsExpP]
getInfix (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = c
getApp :: Group -> [HsExpP]
getApp (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = d
getNegApp :: Group -> [HsExpP]
getNegApp (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = e
getLambda :: Group -> [HsExpP]
getLambda (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = f
getLet :: Group -> [HsExpP]
getLet (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = g
getIf :: Group -> [HsExpP]
getIf (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = h 
getCase :: Group -> [HsExpP]
getCase (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = i 
getDo :: Group -> [HsExpP]
getDo (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = j  
getTuple :: Group -> [HsExpP]
getTuple (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = k
getList :: Group -> [HsExpP]
getList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = l 
getParen :: Group -> [HsExpP]
getParen (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = m
getLeft :: Group -> [HsExpP]
getLeft (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = n
getRight :: Group -> [HsExpP]
getRight (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = o  
getRecConstr :: Group -> [HsExpP]
getRecConstr (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = p 
getRecUpdate :: Group -> [HsExpP]
getRecUpdate (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = q 
getEnumFrom :: Group -> [HsExpP]
getEnumFrom (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = r 
getEnumFromTo :: Group -> [HsExpP]
getEnumFromTo (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = s 
getEnumFromThen :: Group -> [HsExpP]
getEnumFromThen (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = t  
getEnumFromThenTo :: Group -> [HsExpP]
getEnumFromThenTo (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = u 
getListComp :: Group -> [HsExpP]
getListComp (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = v 
getTypeSig :: Group -> [HsExpP]
getTypeSig (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = w 
getAsPat :: Group -> [HsExpP]
getAsPat (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = x 
getWildCard :: Group -> [HsExpP]
getWildCard (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = y 
getIrrPat :: Group -> [HsExpP]
getIrrPat (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = z  


     
groupExps :: [HsExpP] -> Group -> Group
groupExps [] g = g
groupExps (e@(Exp (HsId x)):es) g = groupExps es (addId e g)
groupExps (e@(Exp (HsLit s i)):es) g = groupExps es (addLit e g)
groupExps (e@(Exp (HsInfixApp _ _ _)):es) g = groupExps es (addInfix e g)
groupExps (e@(Exp (HsApp _ _)):es) g = groupExps es (addApp e g)
groupExps (e@(Exp (HsNegApp _ _)):es) g = groupExps es (addNegApp e g)
groupExps (e@(Exp (HsLambda _ _)):es) g = groupExps es (addLambda e g)
groupExps (e@(Exp (HsLet _ _)):es) g = groupExps es (addLet e g)
groupExps (e@(Exp (HsIf _ _ _)):es) g = groupExps es (addIf e g)
groupExps (e@(Exp (HsCase _ _)):es) g = groupExps es (addCase e g)
groupExps (e@(Exp (HsDo _)):es) g = groupExps es (addDo e g)
groupExps (e@(Exp (HsTuple _)):es) g = groupExps es (addTuple e g)
groupExps (e@(Exp (HsList _)):es) g = groupExps es (addList e g)
groupExps (e@(Exp (HsParen _)):es) g = groupExps es (addParen e g)
groupExps (e@(Exp (HsLeftSection _ _)):es) g = groupExps es (addLeft e g)
groupExps (e@(Exp (HsRightSection _ _)):es) g = groupExps es (addRight e g)
groupExps (e@(Exp (HsRecConstr _ _ _)):es) g = groupExps es (addRecConstr e g)
groupExps (e@(Exp (HsRecUpdate _ _ _)):es) g = groupExps es (addRecUpdate e g)
groupExps (e@(Exp (HsEnumFrom _)):es) g = groupExps es (addEnumFrom e g)
groupExps (e@(Exp (HsEnumFromTo _ _)):es) g = groupExps es (addEnumFromTo e g)
groupExps (e@(Exp (HsEnumFromThen _ _)):es) g = groupExps es (addEnumFromThen e g)
groupExps (e@(Exp (HsEnumFromThenTo _ _ _)):es) g = groupExps es (addEnumFromThenTo e g)
groupExps (e@(Exp (HsListComp _)):es) g = groupExps es (addListComp e g)
groupExps (e@(Exp (HsExpTypeSig _ _ _ _)):es) g = groupExps es (addTypeSig e g)
groupExps (e@(Exp (HsAsPat _ _)):es) g = groupExps es (addAsPat e g)
groupExps (e@(Exp (HsWildCard)):es) g = groupExps es (addWildCard e g)
groupExps (e@(Exp (HsIrrPat _)):es) g = groupExps es (addIrrPat e g)

addId :: HsExpP -> Group -> Group
addId e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = ((a++[e1]),b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
addLit :: HsExpP -> Group -> Group
addLit e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,(b++[e1]),c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
addInfix :: HsExpP -> Group -> Group
addInfix e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,(c++[e1]),d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
addApp :: HsExpP -> Group -> Group
addApp e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,(d++[e1]),e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
addNegApp :: HsExpP -> Group -> Group
addNegApp e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,(e++[e1]),f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
addLambda :: HsExpP -> Group -> Group
addLambda e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,(f++[e1]),g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
addLet :: HsExpP -> Group -> Group
addLet e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,(g++[e1]),h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
addIf :: HsExpP -> Group -> Group
addIf e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,(h++[e1]),i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) 
addCase :: HsExpP -> Group -> Group
addCase e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,(i++[e1]),j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) 
addDo :: HsExpP -> Group -> Group
addDo e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,(j++[e1]),k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)  
addTuple :: HsExpP -> Group -> Group
addTuple e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,j,(k++[e1]),l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) 
addList :: HsExpP -> Group -> Group
addList e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,j,k,(l++[e1]),m,n,o,p,q,r,s,t,u,v,w,x,y,z) 
addParen :: HsExpP -> Group -> Group
addParen e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,j,k,l,(m++[e1]),n,o,p,q,r,s,t,u,v,w,x,y,z)
addLeft :: HsExpP -> Group -> Group
addLeft e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,j,k,l,m,(n++[e1]),o,p,q,r,s,t,u,v,w,x,y,z)
addRight :: HsExpP -> Group -> Group
addRight e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,(o++[e1]),p,q,r,s,t,u,v,w,x,y,z)  
addRecConstr :: HsExpP -> Group -> Group
addRecConstr e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,(p++[e1]),q,r,s,t,u,v,w,x,y,z) 
addRecUpdate :: HsExpP -> Group -> Group
addRecUpdate e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,(q++[e1]),r,s,t,u,v,w,x,y,z) 
addEnumFrom :: HsExpP -> Group -> Group
addEnumFrom e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,(r++[e1]),s,t,u,v,w,x,y,z) 
addEnumFromTo :: HsExpP -> Group -> Group
addEnumFromTo e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,(s++[e1]),t,u,v,w,x,y,z) 
addEnumFromThen :: HsExpP -> Group -> Group
addEnumFromThen e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,(t++[e1]),u,v,w,x,y,z)  
addEnumFromThenTo :: HsExpP -> Group -> Group
addEnumFromThenTo e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,(u++[e1]),v,w,x,y,z) 
addListComp :: HsExpP -> Group -> Group
addListComp e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,(v++[e1]),w,x,y,z) 
addTypeSig :: HsExpP -> Group -> Group
addTypeSig e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,(w++[e1]),x,y,z) 
addAsPat :: HsExpP -> Group -> Group
addAsPat e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,(x++[e1]),y,z) 
addWildCard :: HsExpP -> Group -> Group
addWildCard e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,w,r,s,t,u,v,w,x,(y++[e1]),z) 
addIrrPat :: HsExpP -> Group -> Group
addIrrPat e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)
 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,(z++[e1]))   
loop _ [] = return []
loop eSize a@((x,y,m,g):xs)
  = do 
        let list' = numberList 0 ((x,y,m,g):xs)
        dups <- mapM (calculateInstances eSize (x,y,m,g)) ((x,y,m,g):xs)
        dups' <- loop' eSize ((tail list')++[(x,y,m,g,0)]) 0
        return (dups ++ dups')
        -- return dups' 
          where
             numberList _ [] = []
             numberList n ((x,y,m,g):xs) = (x,y,m,g,n):numberList (n+1) xs


loop' _ [] _ = return []
loop' eSize ((x,y,m,g,z):xs) n 
 | z == n = return []
 | otherwise = do
                  dups <- mapM (calculateInstances eSize (x,y,m,g)) ((x,y,m,g):(map (\(x,y,m,g,z) -> (x,y,m,g)) xs))
                  rest <- loop' eSize (xs++[(x,y,m,g,z)]) n 
                  -- return rest
                  return (dups ++ rest)


parseAll _ [] = return []
parseAll eSize ((m,f):xs) = do
                          (_,_,mod, tok) <- parseSourceFile f
                          rest <- parseAll eSize xs
                          modName <- fileNameToModName f
                          asts <- genExpList eSize tok mod
                          let groupAST = groupExps asts emptyGroup
                          return ((mod, tok, f, groupAST) : rest)

normaliseTokens f mod t
  = do
       let whiteRemoved = filter (not. isWhite') t
           normalised = removedIdents f mod whiteRemoved
           normalised' = stringIt normalised
       return normalised'
        where
          removedIdents :: Term t => String -> t -> [PosToken] -> [PosToken]
          removedIdents _ _ [] = []
          removedIdents f mod (a@(Varid, (Pos x y z,s)):xs)   
             | findTopLevel f y z mod = a : removedIdents f mod xs
             | otherwise = (Varid, (Pos x y z,"$")) : removedIdents f mod xs
          removedIdents f mod (a@(Conid, (Pos x y z,s)):xs)
             | findTopLevel f y z mod = a : removedIdents f mod xs
             | otherwise = (Conid, (Pos x y z,"$")) : removedIdents f mod xs
          removedIdents f mod (a@(Varsym, (Pos x y z,s)):xs)
             | findTopLevel f y z mod = a : removedIdents f mod xs
             | otherwise = (Varsym, (Pos x y z,"$")) : removedIdents f mod xs
          removedIdents f mod (a@(Consym, (Pos x y z,s)):xs)
             | findTopLevel f y z mod = a : removedIdents f mod xs
             | otherwise = (Consym, (Pos x y z,"$")) : removedIdents f mod xs
             
          removedIdents f mod (a@(Qvarid, (Pos x y z,s)):xs)   
             | findTopLevel f y z mod = a : removedIdents f mod xs
             | otherwise = (Qvarid, (Pos x y z,"$")) : removedIdents f mod xs
          removedIdents f mod (a@(Qconid, (Pos x y z,s)):xs)
             | findTopLevel f y z mod = a : removedIdents f mod xs
             | otherwise = (Qconid, (Pos x y z,"$")) : removedIdents f mod xs
          removedIdents f mod (a@(Qvarsym, (Pos x y z,s)):xs)
             | findTopLevel f y z mod = a : removedIdents f mod xs
             | otherwise = (Qvarsym, (Pos x y z,"$")) : removedIdents f mod xs
          removedIdents f mod (a@(Qconsym, (Pos x y z,s)):xs)
             | findTopLevel f y z mod = a : removedIdents f mod xs
             | otherwise = (Qconsym, (Pos x y z,"$")) : removedIdents f mod xs
          removedIdents f mod (a@(IntLit, (Pos x y z,s)):xs)
             = (IntLit, (Pos x y z, "$")) : removedIdents f mod xs
          removedIdents f mod (a@(FloatLit, (Pos x y z,s)):xs)
             = (FloatLit, (Pos x y z, "$")) : removedIdents f mod xs
          removedIdents f mod (a@(CharLit, (Pos x y z,s)):xs)
             = (CharLit, (Pos x y z, "$")) : removedIdents f mod xs
          removedIdents f mod (a@(StringLit, (Pos x y z,s)):xs)
             = (StringLit, (Pos x y z, "$")) : removedIdents f mod xs
          removedIdents f mod (x:xs) = x: removedIdents f mod xs
                     
          findTopLevel :: Term t => String -> Int -> Int -> t -> Bool           
          findTopLevel f x y t = isTopLevelPNT (locToPNT f (x,y) t)

getDirectory :: String -> String
getDirectory f
  = reverse $ dropWhile (=='/') (dropWhile (/='/') (reverse f))
  
stripServers :: [(ModuleName, String)] -> String -> [(ModuleName, String)]
stripServers [] d = []
stripServers (a@(x,y):xs)  d
 | d == getDirectory y = a : stripServers xs d
 | otherwise           = stripServers xs d

addIndex :: [ [(a,b)] ] -> [ [(a,b,Int)] ]
addIndex (x:xs) = addIndex' 0 x : addIndex xs
                    where
                      addIndex' i ((x,y):xs) = (x,y,i) : addIndex' (i+1) xs 


-- removeDuplicates = groupBy (foldExp `on` fst) . nub . concat

removeDuplicates x = do let x' = nubBy sameOccurrence (sort (concat x))

                        es <- mapM renameExp' x'
                        let g' = groupBy (foldExpOrDo `on` (\(x,y,z) -> x)) es 
                            x2 = removeSubEntities  $ nubBy (sameOccurrence2 `on` fst) (map (\(x,y,z) -> (y,z)) (concat (remove1Ele g')))
                        es2 <- mapM renameExp' x2
                        let g2 = groupBy (foldExpOrDo `on` (\(x,y,z) -> x)) es2

                        return g2
                        
foldExpOrDo :: HsExpP -> HsExpP -> Bool
foldExpOrDo e@(Exp (HsDo _)) e2@(Exp (HsDo _))
 = foldDoNormal [] [] e e2
foldExpOrDo e1 e2 = foldExp [] [] e1 e2                  
                        
remove1Ele [] = []
remove1Ele (x:xs) 
 | length x == 1 = remove1Ele xs
 | otherwise = x : remove1Ele xs



removeSubEntities' x [] = False
removeSubEntities' (x,z) ((y,m):ys)
  | findEntityWithLocation x y && z == m = True
  | otherwise = removeSubEntities' (x,z) ys

removeSubEntities (x:xs)
  | removeSubEntities' x xs = removeSubEntities2  x (xs++[x])
  | otherwise = x : removeSubEntities2  x (xs++[x])
removeSubEntities [] = []
  
removeSubEntities2 x (y:ys) 
 | x == y = []
 | removeSubEntities' y ys = removeSubEntities2  x (ys++[y]) 
 | otherwise = y : removeSubEntities2  x (ys++[y])  

takeSubEntities (x:xs)
 | removeSubEntities' x xs = x : takeSubEntities2 x (xs++[x])
 | otherwise = takeSubEntities2 x (xs ++ [x])
takeSubEntities2 x (y:ys)
 | x == y = []
 | removeSubEntities' y ys = y : takeSubEntities2 x (ys++[y])
 | otherwise = takeSubEntities2 x (ys++[y])


renameExp' (a,b) = do
                       a' <- renameExp a
                       return (a',a,b)

-- a variation on groupBy; groups by comparing one element to all other elements...
-- groupBy' 		::  (a -> a -> Bool) -> [a] -> [b] -> [[b]]
groupBy' _  []	[]	=  []
groupBy' eq (x:xs) (a:as)	=  (a:ys) : groupBy' eq xs' as'
                              where ((ls,ys),(os, zs)) = span' (eq x) xs as
                                    (xs', as') = filterIt ys xs as
                                    
                                    filterIt _ [] [] = ([],[])
                                    filterIt _ [] _  = ([],[])
                                    filterIt _ _ []  = ([],[])
                                    filterIt list1 (x:xs) (y:ys)
                                      | y `elem` list1 = filterIt list1 xs ys
                                      | otherwise = let (ls, zs) = filterIt list1 xs ys in  (x:ls, y:zs)
                                     
                 
span'                    :: (a -> Bool) -> [a] -> [b] -> (([a], [b]),([a], [b]))
span' _ xs@[] ys@[]           =  ((xs,ys),(xs, ys))
span' p xs@(x:xs') ds@(a:as')
         | p x          =  let ((ls,ys),(os,zs)) = span' p xs' as' in (((x:ls),(a:ys)),(os,zs))
         | otherwise    =  span' p xs' as'  -- (([],[]),(xs',as'))
      
calculateInstances expressionSize a@(mod1, tokList1, name1, group) b@(mod2, tokList2, name2, group2)
 = do  
       rest <- (applyTU (full_tdTU (constTU [] `adhocTU` inExp)) mod1)
       return rest
     where
       inExp (e1::HsExpP)
         = do
             -- res <- traverseExp a b e1 
             -- AbstractIO.putStrLn ("comparing " ++ name1 ++ " with " ++ name2)
             res <- findExp expressionSize a b e1  
             if res == []
               then return []
               else return res
         

findExp _ _ _ (Exp (HsList [])) = return []
findExp _ _ _ (Exp (HsTuple [])) = return [] 
findExp _ _ _ (Exp (HsLet _ _)) = return []
findExp expressionSize (mod1, tokList1, name1, group1) (mod2, tokList2, name2, group2) e1@(Exp (HsDo _))
 = do
        let (start, end)  = getStartEndLoc tokList1 e1
        let tokExpression = getToks (start, end) tokList1   
        if (length (filter (not. isWhite) tokExpression)) < expressionSize
             then return []
             else -- find occurrences of this expression within mod2
              do
               newE1 <- renameExp e1
               occurs <- findExpressionDo (e1,name1) newE1 (mod2, tokList2, name2) (getGroup newE1 group2)
               if occurs == []
                then return []
                else do 
                  return [occurs]
findExp expressionSize (mod1, tokList1, name1, group1) (mod2, tokList2, name2, group2) e1
 = do
        -- tokenize expression
        -- tokenized expression must be bigger than
        -- expressionSize!
        let (start, end)  = getStartEndLoc tokList1 e1
        let tokExpression = getToks (start, end) tokList1   
        if (length (filter (not. isWhite) tokExpression)) < expressionSize
                then return []
                else -- find occurrences of this expression within mod2
                 do
                  newE1 <- renameExp e1
                  occurs <- findExpression e1 newE1 (mod2, tokList2, name2) (getGroup newE1 group2)
                  if occurs == []
                   then return []
                   else do 
                    return [ (e1, name1) : occurs]
      
      
-- find the occurrences of e1 within mod1  
findExpressionDo (e1@(Exp (HsDo s)),name1) newE1 (mod1, tokList1, name2) (e2:exps)
       | sameOccurrence e1 e2 = do rest <- findExpressionDo (e1,name1) newE1 (mod1, tokList1, name1) exps
                                   return rest
       | otherwise
          = do newE2 <- renameExp e2
               let (pred, stmt2, stmt1) = foldDo [] [] (newE1,e1) (newE2,e2)
               -- error $ show stmt
               if pred 
                  then
                    do
                       rest <- findExpressionDo (e1,name1) newE1 (mod1, tokList1, name1) exps
                       return ((stmt1, name1) : ((stmt2, name2) : rest ))
                  else do rest <- findExpressionDo (e1,name1) newE1 (mod1, tokList1, name1) exps
                          return rest 
findExpressionDo _ _ _ _ = return []
    
findExpression _ _ _ [] = return []
                                                       
findExpression e1 newE1 (mod1, tokList1, name1) (e2:exps)
       | sameOccurrence e1 e2 = do rest <- findExpression e1 newE1 (mod1, tokList1, name1) exps
                                   return rest
       | otherwise 
           = do    
                                      
                newE2 <- renameExp e2        
                if foldExp [] [] newE1 newE2
                  then do  -- identify the function
                                 -- that defines this expression
                                 -- the find the free and declared variables from it...
                                 -- error $ show newE2
                         rest <- findExpression e1 newE1 (mod1, tokList1, name1) exps
                         return ( (e2, name1) : rest)
                         
                  else do  rest <- findExpression e1 newE1 (mod1, tokList1, name1) exps
                           return rest 

isWhite' x@(t,_) = t==Whitespace || t==Commentstart || t==Comment || t==NestedComment || isOpenBracket x || isCloseBracket x ||
                   isComma x || isOpenSquareBracket x || isCloseSquareBracket x || isIrrefute x

                  
-- find the defining function for a given expression
definingFun e1
  = (fromJust) . (applyTU (once_tdTU (failTU `adhocTU` inFun)))
     where
       inFun d@(Dec (HsFunBind s ms)::HsDeclP)
        | findEntity e1 d = Just d
       inFun d@(Dec (HsPatBind s p e ds)::HsDeclP)
        | findEntity e1 d = Just d
       inFun _ = Nothing

-- foldExp compares two expressions for equality
-- via alpha-renaming
-- foldIdent :: (HsIdent PNT) -> (HsIdent PNT) -> Bool
foldIdent pats pats2 (HsVar x) (HsVar y)
 = x == y && ((not (checkPNTInPat pats x)) && (not (checkPNTInPat pats2 y)))
foldIdent _ _ (HsCon x) (HsCon y) -- constructors are treated like literals?
 = True -- x == y
foldIdent _ _ x y = False
foldWild (HsVar x)
 = isLocalPNT x  
foldWild (HsCon x) 
 = isLocalPNT x       
 
 
checkPNTInPat :: [HsPatP] -> PNT -> Bool
checkPNTInPat [] _ = False
checkPNTInPat (p:ps) i 
        | defineLoc i == (SrcLoc "__unknown__" 0 0 0) = False
        | defineLoc i == defineLoc (patToPNT p) = True
        | otherwise = checkPNTInPat ps i

findPNTInPat :: Int -> [HsPatP] -> PNT -> Int
findPNTInPat n [] _ = -1
findPNTInPat n (p:ps) i 
        | defineLoc i == (SrcLoc "__unknown__" 0 0 0) = -1
        | defineLoc i == defineLoc (patToPNT p) = n
        | otherwise = findPNTInPat (n+1) ps i       
 
foldExp :: [HsPatP] -> [HsPatP] -> HsExpP -> HsExpP -> Bool
foldExp pats pats2 (Exp (HsId x)) (Exp (HsId y))
 | pred1 x y && pos1 x == pos2 y = True
 | pred1 x y && pos1 x /= pos2 y = False
 | (foldIdent pats pats2 x y || (foldWild x && foldWild y)) = True
 | otherwise = False
    where
      pred1 (HsVar x) (HsVar y) = checkPNTInPat pats x && checkPNTInPat pats2 y
      pred1 _ _ = False
      pos1 (HsVar x) = findPNTInPat 0 pats x
      pos2 (HsVar y) = findPNTInPat 0 pats2 y
foldExp pats pats2 (Exp (HsId (HsVar x))) e  -- comparing a variable against any expression should be OK CHECK THIS!
 | isLocalPNT x && (not (checkPNTInPat pats x)) = True -- | pNTtoName x == "$" = True
 | otherwise = False
foldExp pats pats2 e (Exp (HsId (HsVar x)))   -- comparing a variable against any expression should be OK CHECK THIS!
 | isLocalPNT x && (not (checkPNTInPat pats2 x)) = True -- | pNTtoName x == "$" = True 
 | otherwise = False
foldExp pats pats2 (Exp (HsParen e1)) e2 
 | not (sameOccurrence e1 e2) = foldExp pats pats2 e1 e2
 | otherwise = False
foldExp pats pats2 e1 (Exp (HsParen e2)) 
 | not (sameOccurrence e1 e2) = foldExp pats pats2 e1 e2
 | otherwise = False
foldExp pats pats2 (Exp (HsLit s lit1)) x   -- (Exp (HsLit s2 (lit2))) -- comparing 2 literals is True!?
  = True -- lit1 == lit2
foldExp pats pats2 x (Exp (HsLit s lit1)) = True
foldExp pats pats2 (Exp (HsInfixApp e1 o1 e2)) (Exp (HsInfixApp e3 o2 e4))  -- check this (different ops!?)
 | foldWild o1 && (pred1 && pred2) = True
 | foldIdent pats pats2 o1 o2 && (pred1 && pred2) = True
     where
       pred1 = foldExp pats pats2 e1 e3
       pred2 = foldExp pats pats2 e2 e4
foldExp pats pats2 a@(Exp (HsApp e1 e2)) b@(Exp (HsApp e3 e4))
  = (foldExp pats pats2 e1 e3) && (foldExp pats pats2 e2 e4)
foldExp pats pats2 (Exp (HsNegApp s e1)) (Exp (HsNegApp s2 e2)) = foldExp pats pats2 e1 e2
foldExp pats pats2 e5@(Exp (HsLambda ps e11)) e4@(Exp (HsLambda ps2 e22)) 
 = False
foldExp pats pats2 (Exp (HsLet decs1 e1)) (Exp (HsLet decs2 e2)) = False -- check decs?
foldExp pats pats2 (Exp (HsIf e1 e2 e3)) (Exp (HsIf e4 e5 e6)) 
  = foldExp pats pats2 e1 e4 && foldExp pats pats2 e2 e5 && foldExp pats pats2 e3 e6
foldExp pats pats2 a@(Exp (HsCase e1 alts1)) b@(Exp (HsCase e2 alts2)) 
 = False
foldExp pats pats2 (Exp (HsList es1)) (Exp (HsList es2))
  = foldExpList pats pats2 es1 es2
foldExp pats pats2 (Exp (HsTuple es1)) (Exp (HsTuple es2))
  = foldExpList pats pats2 es1 es2
foldExp pats pats2 (Exp (HsLeftSection e1 x)) (Exp (HsLeftSection e2 y))
 | foldWild x && foldExp pats pats2 e1 e2 = True
 | foldIdent pats pats2 x y  && foldExp pats pats2 e1 e2 = True
 | otherwise = False
foldExp pats pats2 (Exp (HsRightSection x e1)) (Exp (HsRightSection y e2))
 | foldWild x && foldExp pats pats2 e1 e2 = True
 | foldIdent pats pats2 x y  && foldExp pats pats2 e1 e2 = True
 | otherwise = False
foldExp pats pats2 (Exp (HsEnumFrom e1)) (Exp (HsEnumFrom e2))
 = foldExp pats pats2 e1 e2
foldExp pats pats2 (Exp (HsEnumFromTo e1 e2)) (Exp (HsEnumFromTo e3 e4)) 
 = foldExp pats pats2 e1 e3 && foldExp pats pats2 e2 e4
foldExp pats pats2 (Exp (HsEnumFromThen e1 e2)) (Exp (HsEnumFromThen e3 e4))
 = foldExp pats pats2 e1 e3 && foldExp pats pats2 e2 e4
foldExp pats pats2 (Exp (HsExpTypeSig _ e1 _ _)) (Exp (HsExpTypeSig _ e2 _ _))
 = foldExp pats pats2 e1 e2
foldExp pats pats2 (Exp (HsAsPat i1 e1)) (Exp (HsAsPat i2 e2))
 | isLocalPNT i1 && foldExp pats pats2 e1 e2     = True
 | i1 == i2 && foldExp pats pats2 e1 e2 = True
 | otherwise = False
foldExp pats pats2 (Exp (HsWildCard)) (Exp (HsWildCard)) = True
foldExp pats pats2 (Exp (HsIrrPat e1)) (Exp (HsIrrPat e2)) = foldExp pats pats2 e1 e2
 
foldExp _ _ _ _ = False


{- foldAlt :: [HsAltP] -> [HsAltP] -> Bool
foldAlt [] [] = True
foldAlt [] _  = False
foldAlt _ []  = False
foldAlt ((HsAlt s p rhs ds):as) ((HsAlt s1 p1 rhs1 ds1):as1)
  = foldRHS rhs rhs1 && foldAlt as as1
  
foldRHS (HsBody e1) (HsBody e2) 
 = foldExp e1 e2
foldRHS (HsGuard gs1) (HsGuard gs2)
 = foldGuards gs1 gs2
    where
      foldGuards [] [] = True
      foldGuards _ []  = False
      foldGuards [] _  = False
      foldGuards ((s1, e1, e2):gs1) ((s2, e3, e4):gs2)
       = foldExp e1 e3 && foldExp e2 e4 && foldGuards gs1 gs2 -}

foldExpList :: [HsPatP] -> [HsPatP] -> [HsExpP] -> [HsExpP] -> Bool
foldExpList p _ [] [] = True
foldExpList p _ [] _ = False
foldExpList p _ _ [] = False
foldExpList p p2 (x:xs) (y:ys)
  = (foldExp p p2 x y && foldExpList p p2 xs ys)


-- ==========================================================

foldDo :: [HsPatP] -> [HsPatP] -> (HsExpP, HsExpP) -> (HsExpP,HsExpP) -> (Bool, HsExpP, HsExpP)
foldDo pats pats2 (Exp (HsDo stmts1), Exp (HsDo stmts1')) ((Exp (HsDo stmts2)), Exp (HsDo stmts2'))
 | pred = (True, Exp (HsDo res), Exp (HsDo res2))
           where
             (pred, res, res2) = foldStmt pats pats2 (stmts1,stmts1') (stmts2, stmts2')
foldDo _ _ _ _ = (False, defaultExp, defaultExp)
  
foldStmt :: [HsPatP] -> [HsPatP] -> (HsStmtP, HsStmtP) -> (HsStmtP,HsStmtP) -> (Bool, HsStmtP, HsStmtP)
foldStmt pats pats2 (ss1@(HsGenerator s p1 e1 stmts1),ss2@(HsGenerator _ p1' e1' stmts1')) 
                    (ss3@(HsGenerator _ p2 e2 stmts2),ss4@(HsGenerator _ p2' e2' stmts2'))
 {- | wildCardAllPNs p1 == wildCardAllPNs p2 && predExp && pred2
      = (True, ss1, res2')               
  | wildCardAllPNs p1 == wildCardAllPNs p2 && predExp && pred3
      = (True, res3', ss3) -}
 -- | pred2 = (True, HsGenerator loc0 p1' e1' res1', res2')
 -- | pred3 = (True, res3', HsGenerator loc0 p2' e2' res4')
  | wildCardAllPNs p1 == wildCardAllPNs p2 && predExp && predStmt
       = (True, (HsGenerator s p1' e1' res1), (HsGenerator s p2' e2' res2))
  | wildCardAllPNs p1 == wildCardAllPNs p2 && predExp && (not predStmt)
       = (True, (HsGenerator s p1' e1' (HsLast defaultExp)), 
                (HsGenerator s p2' e2' (HsLast defaultExp)))
  -- | pred2 = (True, ss1, (HsGenerator s p2' e2' res2'))

  | otherwise = foldStmt (pats++[p1]) (pats2++[p2]) (stmts1, stmts1') (stmts2, stmts2')
           where
             predExp = foldExp (pats++[p1]) (pats2++[p2]) e1 e2
             (pred2, res1', res2') = foldStmt (pats++[p1]) (pats2++[p2]) (ss1, ss2) (stmts2, stmts2')
             (pred3, res3', res4') = foldStmt (pats++[p1]) (pats2++[p2]) (stmts1, stmts1') (ss3, ss4)
             (predStmt, res1, res2) = foldStmt (pats++[p1]) (pats2++[p2]) (stmts1, stmts1') (stmts2, stmts2') 
foldStmt pats pats2 (HsQualifier e1 stmts1, HsQualifier e1' stmts1')
                    (HsQualifier e2 stmts2, HsQualifier e2' stmts2')
 | foldExp pats pats2 e1 e2 = (True, HsQualifier e1' res1, HsQualifier e2' res2)
                     where
                       (_, res1, res2) = foldStmt (pats) pats2 (stmts1, stmts1') (stmts2, stmts2')
foldStmt pats pats2 (HsQualifier e1 stmts1, HsQualifier e1' stmts1')
              (HsLast e2, HsLast e2')
 | foldExp pats pats2 e1 e2 = (True, HsLast e1', HsLast e2')
foldStmt pats pats2 (HsLast e1, HsLast e1') 
              (HsQualifier e2 stmts2, HsQualifier e2' stmts2')
 | foldExp pats pats2 e1 e2 = (True, HsLast e1', HsLast e2')
foldStmt pats pats2 (HsLast e1, HsLast e1') 
              ((HsLast e2),(HsLast e2'))
 | foldExp pats pats2 e1 e2 = (True, HsLast e1', HsLast e2')
foldStmt a b c d = (False, HsLast defaultExp, HsLast defaultExp)  

-- ===========================================================

foldDoNormal :: [HsPatP] -> [HsPatP] -> HsExpP -> HsExpP -> Bool
foldDoNormal pats pats2 (Exp (HsDo stmts1)) (Exp (HsDo stmts2))
 | pred = True
           where
             pred= foldStmtNormal pats pats2 stmts1 stmts2
foldDoNormal _ _ _ _ = False
  
foldStmtNormal :: [HsPatP] -> [HsPatP] -> HsStmtP -> HsStmtP -> Bool
foldStmtNormal pats pats2 ss@(HsGenerator s p1 e1 stmts1) ss2@(HsGenerator _ p2 e2 stmts2)
  -- | pred2 = True
  -- | pred3 = True
  | wildCardAllPNs p1 == wildCardAllPNs p2 && predExp && predStmt
       = True
  | otherwise = foldStmtNormal (pats++[p1]) (pats2++[p2]) stmts1 stmts2
           where
             pred2 = foldStmtNormal (pats++[p1]) (pats2++[p2]) ss stmts2
             pred3 = foldStmtNormal (pats++[p1]) (pats2++[p2]) stmts1 ss2
             predExp = foldExp (pats++[p1]) (pats2++[p2]) e1 e2
             predStmt = foldStmtNormal (pats++[p1]) (pats2++[p2]) stmts1 stmts2
foldStmtNormal pats pats2 (HsQualifier e1 stmts1) (HsQualifier e2 stmts2)
 = foldExp pats pats2 e1 e2 && predStmt
     where
       predStmt = foldStmtNormal pats pats2 stmts1 stmts2
foldStmtNormal pats pats2 (HsLast e1) (HsLast e2)
 | e1 == defaultExp && e2 == defaultExp = True
 | otherwise  = foldExp pats pats2 e1 e2
foldStmtNormal _ _ _ _ = False


  
-- renames all bound variables to "$" so we can
-- compare too expressions via alpha renaming...      
-- renameExp :: HsExpP -> HsDeclP -> m HsExpP
renameExp exp = applyTP (full_buTP (idTP `adhocTP` renameVar)) exp
  where
    renameVar e@(p::PName)
      | isTopLevelPN p = return p
     -- | (pNTtoPN p) `elem` free = return p
     -- | not (defines (pNTtoPN x) fun) = return e
      | otherwise = do s <- renameStringPN p
                       return e
                       --   (nameToPN "$")
    -- renameVar e = return e
    renameStringPN p = applyTP (full_buTP (idTP `adhocTP` inS)) p
    inS (p::String) = return "$"
    
    
-- ===================================================================================== 
-- Pretty Printing 
-- We pretty print our matches to a file. Displaying the expression, together with
-- its position and the number of occurrences.
--
--

prettyPrint :: [ [(HsExpP, HsExpP, String)] ] -> [ ([PosToken], String) ] ->  String
prettyPrint [] [] = []
prettyPrint [] _ = []
prettyPrint _ [] = []
prettyPrint (dups:xs) toks
  = prettyPrint' dups toks ++ prettyPrint xs toks
  
     where
       prettyPrint' :: [(HsExpP, HsExpP,String)] -> [ ([PosToken], String) ] -> String
       prettyPrint' [] _ = ""
       prettyPrint' dups toks
         | length dups == 1 = ""
         | otherwise = 
          ( (concatMap renderIt dups) 
               ++ "\n" ++ (show (length dups)) ++ " occurrences.\n\n" )

       renderIt :: (HsExpP, HsExpP, String) -> String
       renderIt (_, e, m)
         = "\n\t\t" ++ m ++ "  " ++ (pos e (toks' m)) ++ ": >" ++ 
                       (stringise e (toks' m)) ++ "<"

       toks' :: String -> [PosToken]
       toks' m = findTokens toks m
    
       findTokens :: [ ([PosToken], String) ] -> String -> [PosToken]
       findTokens ((x,m):xs) name
         | m == name = x
         | otherwise = findTokens xs name

       pos :: HsExpP -> [PosToken] -> String
       pos e@(Exp (HsDo stmts)) toks
        = show pos'
           where pos'
                  = let       s=getStmtList stmts                           
                              locs = map (startEndLoc toks) (removeDefault s)
                              (startLocs, endLocs) =(sort (map fst locs), sort (map snd locs))
                          in {- extendForwards toks (ghead "StartEndLoc::HsStmtP" startLocs) (glast "StartEndLoc::HsStmtP" endLocs) isLet -} ((ghead "StartEndLoc::HsStmtP" startLocs), (glast "StartEndLoc::HsStmtP" endLocs)) 
                          
       pos e toks
        | e /= defaultExp
           = let (start, end) = getStartEndLoc toks e
                in ((show (start, end)))
        | otherwise = ""
            
       stringise :: HsExpP -> [ PosToken ] -> String
       stringise e@(Exp (HsDo stmts)) toks
        = stringIt (getToks pos' toks)
           where pos'
                  = let       s=getStmtList stmts                           
                              locs = map (startEndLoc toks) (removeDefault s)
                              (startLocs, endLocs) =(sort (map fst locs), sort (map snd locs))
                          in {- extendForwards toks (ghead "StartEndLoc::HsStmtP" startLocs) (glast "StartEndLoc::HsStmtP" endLocs) isLet -} ((ghead "StartEndLoc::HsStmtP" startLocs), (glast "StartEndLoc::HsStmtP" endLocs)) 

       stringise e toks 
        | e /= defaultExp
           = let (start,end) = getStartEndLoc toks e
              in stringIt (getToks (start,end) toks)
        | otherwise = ""

removeDefault [] = []
removeDefault (s@ (HsLastAtom e):es)         
  | e == defaultExp = removeDefault es
  | otherwise = s : removeDefault es
removeDefault (s:ss)
  = s : removeDefault ss
prettyPrint2 :: [ [(HsExpP, HsExpP, String)] ] -> [ ([PosToken], String) ] ->  [ [(HsExpP, String, String)] ]
prettyPrint2 [] [] = []
prettyPrint2 [] _ = []
prettyPrint2 _ [] = []
prettyPrint2 (dups:xs) toks
  = prettyPrint' dups toks : prettyPrint2 xs toks
  
     where
       prettyPrint' :: [(HsExpP,HsExpP,String)] -> [ ([PosToken], String) ] -> [(HsExpP, String, String)]
       prettyPrint' [] _ = []
       prettyPrint' ((_,e,m):ms) toks
         = (e,m,( (renderIt (e,m)) ++ "\n" )) : prettyPrint' ms toks

       renderIt :: (HsExpP, String) -> String
       renderIt (e, m)
         = "\n\t\t" ++ m ++ "  " ++ (pos e (toks' m)) ++ ": >" ++ 
                       (stringise e (toks' m)) ++ "<"

       toks' :: String -> [PosToken]
       toks' m = findTokens toks m
    
       findTokens :: [ ([PosToken], String) ] -> String -> [PosToken]
       findTokens ((x,m):xs) name
         | m == name = x
         | otherwise = findTokens xs name

       pos :: HsExpP -> [PosToken] -> String
       pos e@(Exp (HsDo stmts)) toks
        = show pos'
           where pos'
                  = let       s=getStmtList stmts
                              locs = map (startEndLoc toks) (removeDefault s)
                              (startLocs, endLocs) =(sort (map fst locs), sort (map snd locs))
                          in ((ghead "StartEndLoc::HsStmtP" startLocs), (glast "StartEndLoc::HsStmtP" endLocs)) 

       pos e toks
        = let (start, end) = getStartEndLoc toks e
             in ((show (start, end)))
            
       stringise :: HsExpP -> [ PosToken ] -> String
       stringise e@(Exp (HsDo stmts)) toks
        = stringIt (getToks pos' toks)
           where pos'
                  = let       s=getStmtList stmts                           
                              locs = map (startEndLoc toks) (removeDefault s)
                              (startLocs, endLocs) =(sort (map fst locs), sort (map snd locs))
                          in  ((ghead "StartEndLoc::HsStmtP" startLocs), (glast "StartEndLoc::HsStmtP" endLocs))   

       stringise e toks 
        | e /= defaultExp
            = let (start,end) = getStartEndLoc toks e
                in stringIt (getToks (start,end) toks)
        | otherwise = ""

stringIt :: [PosToken] -> String
stringIt [] = ""
stringIt (r@(x,(y, s) ):xs) = s ++ (stringIt xs)



