HaRe-0.6: refactorer/DuplicateCode.hs
-----------------------------------------------------------------------------
-- |
-- 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)