HaRe-0.6: refactorer/RefacDupTrans.hs

module RefacDupTrans where
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 PrettyPrint
import RefacTypeSyn
import RefacLocUtils
import Data.Char
import GHC.Unicode
import AbstractIO
import Maybe
import List
import Data.Function
import RefacUtils
import LocalSettings
import DuplicateCode (foldDo)

type NameToCall    = String
type NameToReplace = String
type Module        = String
type FileName      = String

refacDupTrans args
  = do         
       AbstractIO.putStrLn "refacDupTrans"
       {- let fileName = ghead "fileName'" args 
           beginRow         = read (args!!1)::Int
           beginCol         = read (args!!2)::Int
           endRow           = read (args!!3)::Int
           endCol           = read (args!!4)::Int
       -- collect the answers...
       (inscps, exps, mod, tokList)<-parseSourceFileOld fileName
       let subExp = locToExp (beginRow, beginCol) (endRow, endCol) tokList mod
       expression <- AbstractIO.readFile transFilePath
       let expressions = (read expression)::([ [(HsExpP, String)] ])
 
       let clonedExps = concat (filter (subExp `myElem`) expressions) 
           groupedClones = groupClones clonedExps  -}
           
       cloneCall <- AbstractIO.readFile classTransformPath
       answers   <- AbstractIO.readFile answerFilePath  
        
       let clonedExps = pruneCloneClass (read cloneCall::[(HsExpP, String, String)]) (filter (isAlpha) answers) 
           groupedClones = groupClones clonedExps   
               
       if clonedExps == []
         then error "Please use introduce a new definition instead; selected expression is not a member of a clone class!"
         else do 
            -- make sure all the files we need to modify
            -- are added to the project. Otherwise we run into "module not found"
            -- issues...
            let names = nub $ concatMap (map snd) groupedClones
            mods <- (mapM parseSourceFile names)
            destMods <- mapM fileNameToModName names 
            -- addFile names
            res <- createParameters (makeFullASTList mods) 1 (createAbs (map fst clonedExps)) 
            let pns  = nub $ concatMap definedPNs [(fromJust res)]
            results <- callFindSafeModules destMods (myZip mods names groupedClones) pns res
            writeRefactoredFiles False results
            AbstractIO.putStrLn "Clone Transformation Completed.\n" 
makeFullASTList gf= [mod | (inscps, exps, mod, tokList) <- gf]


pruneCloneClass :: [ (HsExpP, String, String) ] -> String -> [ (HsExpP, String) ]
pruneCloneClass ((x,y,z):xs) ('y':ys) = (x,y) : pruneCloneClass xs ys
pruneCloneClass (x:xs) ('n':ys) = pruneCloneClass xs ys
pruneCloneClass _ _ = []


retainLocs [] _ = []
retainLocs _ [] = []
retainLocs ((i,e,_,_):ms) (((_,_),(t,m)):ts)
 = (i,e,m,t) : retainLocs ms ts

myZip :: [(a,b,c,d)] -> [e] -> [f] -> [(a,b,c,d,e,f)]
myZip ((a,b,c,d):as) (e:bs) (f:fs) = (a,b,c,d,e,f) : myZip as bs fs
myZip _      _   _    = []


-- find safe Module
-- this function checks to see where there is a safe place
-- to put the abstraction.
-- 
-- given the list of the files that we are transforming,
-- we introduce a cyclic inclusion if the module
-- we want to introduce the abstraction already imports
-- another module.... Therefore the module cannot import
-- any of the modules from our transformation set.
-- findSafeModule :: Term t => [ ModuleName ] -> t -> [Bool]
findSafeModule destMods mod
  = not $ or $ map (flip elem mod) (map fst destMods)


findSafeModules destmods [] _ = -- basically we can't do imports, everywhere needs to define abstraction!
                                  return Nothing
findSafeModules destmods ((inscps, exps, mod, tokList, fileName, clonedExps@(c:cs)):mods) res
  = do
          modName <- fileNameToModName fileName
          modules <- serverModsAndFiles modName
          if findSafeModule modules destmods 
           then 
            do AbstractIO.putStrLn $ show fileName
               -- add the abstraction in this module...
               -- we also need to make sure all other modules import this module...
               ((f,m), (newToks, newMod)) <- applyRefac (addAbstraction res (map fst clonedExps))
                                                        (Just (inscps, exps, mod, tokList)) fileName  
                                            
                                                   
               return (Just (((f,m), (newToks, newMod)), mod, fileName))  
           else do rest <- findSafeModules destmods mods res
                   return rest                                 
                   

callFindSafeModules destMods mods pns res
 = do
       -- mod is the module that everything has to import...
       result <- findSafeModules destMods mods res
       if result == Nothing
            then error "All will introduce cyclic inclusion!"
            else do let (transformation, m, fName) = fromJust result
                    fFile <- fileNameToModName fName
                    transformation' <- addImports mods res m pns fName fFile 
                    -- we also need to transform the module we are left with
                    -- i.e. the module where we have added the abstraction...                    
                    return (transformation:transformation')
       
addImports [] _ _ _ _ _ = return []
addImports (t@(inscps, exps, mod, tokList, fileName, clonedExps@(c:cs)):ms) res m pns fFile f
 | mod == m  = do
                  rest <- addImports ms res m pns fFile f
                  return rest
 | otherwise = do modified <- addImports' t res pns fFile f
                  rest <- addImports ms res m pns fFile f
                  return (modified: rest)
                  
addImports' (inscps, exps2, mod, tokList, fileName, clonedExps@(c:cs)) res pns fFile f
 = do
      ((f,m), (newToks, newMod)) <- applyRefac (addImport'' res pns fFile f (map fst clonedExps)) (Just (inscps, exps2, mod, tokList)) fileName
      return ((f,m), (newToks, newMod))


addImport'' res pns fFile f exps (_,_,t)
 = do 
      replacedT <- replaceOccurrences t res exps
      t' <- addImport fFile f pns replacedT
      return t'
      

-- transformClones takes a list of [(HsExpP, String)]
-- parses the module of String, and performs a 
-- "addAbstraction" over that module and writes the 
-- refactoredFiles. 
--
-- transformClones should be called from a mapM_ to allow
-- the monadic effect to be preserved.
transformClones destMods res f clonedExps@(c:cs)
 = do
     let fileName = snd c
          
     currentMod <- fileNameToModName fileName
     origFile <- fileNameToModName f

     let pns  = nub $ concatMap definedPNs [(fromJust res)]

     (inscps, exps, mod, tokList)<-parseSourceFileOld fileName
     ((f2,m), (newToks, newMod)) <- applyRefac (extractExpression res pns fileName origFile currentMod (map fst clonedExps))
                                               (Just (inscps, exps, mod, tokList)) fileName
     return ((f2,m), (newToks, newMod))                                          
                                               
                                               
-- group the expressions by their defining module.
-- groupBy :: (a -> a -> Bool) -> [a] -> [[a]]
groupClones :: [ (HsExpP, String) ] -> [ [(HsExpP, String)] ]

groupClones clones
  = groupBy checkFile clones
     where
      checkFile :: Eq b => (a,b) -> (a,b) -> Bool
      checkFile (a,b) (c,d) = b == d


myElem :: HsExpP -> [(HsExpP, String)] -> Bool
myElem _ [] = False
myElem e ((x,y):xs) 
 | toRelativeLocs e == toRelativeLocs x    = True
 | otherwise = myElem e xs
 
extractExpression decs pns fFile f fileName exps (_,_,t)
 | f /= fileName
     = do
      -- find the expressions in t that are associated
      -- with exps. Replace these expressions with a call
      -- to the abstactions.
      replacedT <- replaceOccurrences t decs exps
      return replacedT
 | otherwise = do replacedT <- replaceOccurrences t decs exps
                  return replacedT


--add a definition name to the import. If the module is not imported yet, then create a new import decl.
-- addImport::String->HsName.ModuleName->[PName]->HsModuleP->HsModuleP
addImport destFileName destModName pns mod@(HsModule _ _  _ imp _)
  =if itemIsImportedByDefault destModName mod     -- Is the definition name explicitly imported?
    then return mod                               -- Yes. Do nothing.
    else if itemsAreExplicitlyImported destModName mod  --Is the module imported and some of its items are explicitly imported?
          then addVarItemInImport1 destModName pns mod -- Yes. Then add the definition name to the list.
          else addImportDecl mod (modNameToStr destModName) False  Nothing False (map pNtoName pns)
               --addImportDecl mod (mkImportDecl destFileName destModName  False (map pNtoName pns)) --Create a new import decl.

  where  
   {- Compose a import declaration which imports the module specified by 'modName',
      and only imports the definition spcified by 'e'.
    -}
   
   itemsAreExplicitlyImported serverModName (HsModule _ _ _ imps _)
     = any (isExplicitlyImported serverModName) imps
    where
       isExplicitlyImported serverModName ((HsImportDecl _ (SN modName _) _ _ h)::HsImportDeclP)
         = serverModName == modName && isJust h && not (fst (fromJust h))



-- are items defined in the serverModName imported by the current module by default?
itemIsImportedByDefault serverModName (HsModule _ _ _ imps _) 
  = any (isImportedByDefault'  serverModName) imps
  where
    isImportedByDefault' serverModName ((HsImportDecl _ (SN modName _) _ _ h)::HsImportDeclP)
       = serverModName == modName && ( isNothing h  || (isJust h && fst(fromJust h)))


addVarItemInImport1 serverModName pns mod
   = applyTP ((once_tdTP (failTP `adhocTP` inImport))  `choiceTP` idTP) mod
  where 
    inImport (imp@(HsImportDecl loc@(SrcLoc fileName _ row col) (SN modName l) qual as (Just (b,ents))):: HsImportDeclP)
      | serverModName == modName && not b  
     =  
          addItemsToImport serverModName  Nothing (Left (map pNtoName pns)) imp
    inImport x = mzero 
                  
addAbstraction decs exps (_,_,t)
  = do
       
       replacedT <- replaceOccurrences t decs exps
       t' <- addDecl replacedT Nothing (maybeToList decs, Nothing) True
       t'' <- addItemsToExport t' Nothing False (Left (map declToName (maybeToList decs))) 
       return t''


-- replaceOccurrences :: (Term t, MonadPlus m, Monad m) => t -> [ HsDeclP ] -> [ [HsExpP] ] -> m t
-- replaceOccurrences t [] _ = return t
replaceOccurrences t _ [] = return t
replaceOccurrences t dec exps
  = do
       res <- repOcc dec exps t
       -- rest <- replaceOccurrences res dec expss
       return res

repOcc Nothing _ t = return t
repOcc (Just dec) es t
  = do
      -- get the expression on the RHS of Abstraction,
      -- and abstraction name for the call.
      let (name, rhs) = getNameAndRHS dec
      newT <- repOcc' name rhs es t
      return newT     
       where
         getNameAndRHS (Dec (HsFunBind _ [HsMatch _ name _ (HsBody e) _]))
           = (name, e)

repOcc' _ _ [] t = return t
repOcc' name rhs (x:xs) t
  = do
      res <- applyTP (once_tdTP (failTP `adhocTP` inExp)) t
      -- error $ show x
      rest <- repOcc' name rhs xs res
      return rest
    where
      inExp e@(Exp (HsDo e1))
       = do
             let new = foldAgainstAbs [] x rhs
             -- we need to actually find the bit to update...
             las <- (getStmtList2 rhs)
             -- error $ show las
             if las == [] 
               then mzero
               else do
                      let (p, newStmts) = foldStmt' (head las) [] (createFunc name (rmAllLocs new)) e1 x
                      if p 
                       then 
                        do
                           -- error $ show (e1, rhs)
                           --    new' = (render.ppi) new
                           -- n' <- update e (Exp (HsDo (HsLast (createFunc name new)))) e
                           -- n' <- RefacUtils.delete e e
                           lift $ AbstractIO.putStrLn $ show new
                           n'' <- update e (Exp (HsDo newStmts))  e
                           return n''
                       else mzero

      inExp e@(Exp (HsParen e1))
        | sameOccurrence e x
            = do 
                 let new = foldAgainstAbs [] e rhs
                     new' = (render.ppi) new
                 
                 e' <- update e (Exp (HsParen (createFunc name new))) e
                 return e'

       -- | otherwise = mzero
      inExp (e::HsExpP)
        | sameOccurrence e x
            = do 
                 let new = foldAgainstAbs [] e rhs
                     new' = (render.ppi) new
                 e' <- update e (createFunc name new) e
                 return e'
      inExp e = 
                   mzero

getStmtList2 (Exp (HsDo s))
  = return [last $ getStmtList s]
getStmtList2 _ = return []


foldStmt' :: HsStmtAtomP -> [HsPatP] -> HsExpP -> HsStmtP -> HsExpP -> (Bool, HsStmtP)
foldStmt' ss p e s (Exp (HsDo s1)) = foldStmt ss p e  s s1
foldStmt' ss p e s1 _ = (False, s1)
  
foldStmt :: HsStmtAtomP -> [HsPatP] -> HsExpP -> HsStmtP -> HsStmtP -> (Bool, HsStmtP)
foldStmt ss p e s1@(HsGenerator _ p1 e1 s0) s2@(HsGenerator _ p2 e2 s3)
 | p1 == p2 && sameOccurrence e1 e2 = foldStmt ss (p++[p1]) e s0 s3
 | otherwise = (False, s1)
foldStmt (HsLastAtom ee) p e s1@(HsQualifier e1 s3) (HsLast e2)
 | isReturn ee && e2 == defaultExp = (True, newStmt)
 | sameOccurrence e1 e2 = (True, s1)
      where
          newStmt = (HsGenerator loc0 (Pat (HsPTuple loc0 p)) e s3)
foldStmt ee p e s1@(HsQualifier e1 s0) s2@(HsQualifier e2 s3)
 | sameOccurrence e1 e2 = foldStmt ee p e s0 s3
 | otherwise = (False, s1)
foldStmt (HsLastAtom ee) p e s1@(HsLast e1) s2@(HsLast e2)
 | isReturn ee && e2 == defaultExp = (True, newStmt)
 | e2 == defaultExp = (True, s1)
 | sameOccurrence e1 e2 && isReturn ee = (True, newStmt)
 | sameOccurrence e1 e2 = (True, s1)
         where 
            newStmt = (HsGenerator loc0 (Pat (HsPTuple loc0 p)) e s1) 
foldStmt ee p e s1 s2 = (False, s1)
 
isReturn e = (render.ppi) (head (flatternApp e)) == "return"
flatternApp :: HsExpP -> [HsExpP]
flatternApp (Exp (HsApp e1 e2)) = flatternApp e1 ++ flatternApp e2
flatternApp (Exp (HsParen e)) = flatternApp e
flatternApp x = [x] 
  
grabPNT :: PNT -> [PNT] -> PNT
grabPNT x [] = x
grabPNT x (y:ys)
  | defineLoc x == defineLoc y = y
  | otherwise = grabPNT x ys  
  
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
      
foldAgainstAbs :: [HsPatP] -> HsExpP -> HsExpP -> [ HsExpP ]
foldAgainstAbs _ e1 e2 
 | e1 == defaultExp || e2 == defaultExp = []
foldAgainstAbs pats e@(Exp (HsId (HsVar x))) (Exp (HsId (HsVar y)))
 | x == y && isTopLevelPNT x = []
 | x == y && isTopLevelPNT x = []
 | checkPNTInPat pats x  = []
 | otherwise = [e]
foldAgainstAbs pats e@(Exp (HsId (HsCon x))) (Exp (HsId (HsCon y)))
  | x == y    = []
  | otherwise = [e]
foldAgainstAbs pats e@(Exp (HsLit s l1)) (Exp (HsLit s2 l2))
  | l1 == l2  = []
  | otherwise = [(Exp (HsLit loc0 l1))]
foldAgainstAbs pats e@(Exp (HsInfixApp e1 o1 e2)) (Exp (HsInfixApp e3 o2 e4))
  = (e1' ++ o1' ++ e2')
     where
       e1' = foldAgainstAbs pats e1 e3
       o1' 
        | o1 == o2  = []
        | otherwise = [Exp (HsId o1)]
       e2' = foldAgainstAbs pats e2 e4
foldAgainstAbs pats e@(Exp (HsApp e1 e2)) (Exp (HsApp e3 e4))
 = (foldAgainstAbs pats e1 e3) ++ (foldAgainstAbs pats e2 e4)
foldAgainstAbs pats e@(Exp (HsNegApp s1 e1)) (Exp (HsNegApp s2 e2))
 = (foldAgainstAbs pats e1 e2)
foldAgainstAbs pats1 e@(Exp (HsLambda pats e1)) (Exp (HsLambda pats2 e2))
 = []
foldAgainstAbs pats e@(Exp (HsLet decs e1)) (Exp (HsLet decs2 e2))
 = (foldAgainstAbs pats e1 e2)
foldAgainstAbs pats e@(Exp (HsIf e1 e2 e3)) (Exp (HsIf e4 e5 e6))
 = (e1' ++ e2' ++ e3')
    where
     e1' = foldAgainstAbs pats e1 e4
     e2' = foldAgainstAbs pats e2 e5
     e3' = foldAgainstAbs pats e3 e6
foldAgainstAbs pats e@(Exp (HsCase e1 alts1)) (Exp (HsCase e2 alts2))
  = []
foldAgainstAbs pats e@(Exp (HsParen e1)) (Exp (HsParen e2))
 = (foldAgainstAbs pats e1 e2)
foldAgainstAbs pats (Exp (HsParen e1)) e2
 = foldAgainstAbs pats e1 e2
foldAgainstAbs pats e1 (Exp (HsParen e2))
 = foldAgainstAbs pats e1 e2 
foldAgainstAbs pats (Exp (HsTuple es1)) (Exp (HsTuple es2))
 = concat (foldAgainstAbs' pats es1 es2)
foldAgainstAbs pats (Exp (HsList es1)) (Exp (HsList es2))
 = concat (foldAgainstAbs' pats es1 es2)
foldAgainstAbs pats (Exp (HsLeftSection e1 o1)) (Exp (HsLeftSection e2 o2))
 = e1' ++ o1'
   where
      e1' = foldAgainstAbs pats e1 e2
      o1'
       | o1 == o2 = []
       | otherwise = [Exp (HsId o1)]
foldAgainstAbs pats (Exp (HsRightSection o1 e1)) (Exp (HsRightSection o2 e2))
 = o1' ++ e1'
  where
    e1' = foldAgainstAbs pats e1 e2
    o1'
     | o1 == o2 = []
     | otherwise = [Exp (HsId o1)]
foldAgainstAbs pats (Exp (HsEnumFrom e1)) (Exp (HsEnumFrom e2))
 = foldAgainstAbs pats e1 e2
foldAgainstAbs pats (Exp (HsEnumFromTo e1 e2)) (Exp (HsEnumFromTo e3 e4))
 = foldAgainstAbs pats e1 e2 ++ foldAgainstAbs pats e3 e4
foldAgainstAbs pats (Exp (HsEnumFromThen e1 e2)) (Exp (HsEnumFromThen e3 e4))
 = foldAgainstAbs pats e1 e2 ++ foldAgainstAbs pats e3 e4
foldAgainstAbs pats (Exp (HsEnumFromThenTo e1 e2 e3)) (Exp (HsEnumFromThenTo e4 e5 e6))
 = foldAgainstAbs pats e1 e4 ++ foldAgainstAbs pats e2 e5 ++ foldAgainstAbs pats e3 e6 
foldAgainstAbs pats (Exp (HsAsPat i1 e1)) (Exp (HsAsPat i2 e2))
 = i1' ++ e1'
   where
     e1' = foldAgainstAbs pats e1 e2
     i1'
      | i1 == i2 = []
      | otherwise = [Exp (HsId (HsVar i1))]
foldAgainstAbs pats (Exp (HsIrrPat e1)) (Exp (HsIrrPat e2))
 = foldAgainstAbs pats e1 e2 
foldAgainstAbs pats (Exp (HsDo e1)) (Exp (HsDo e2))
 = foldAgainstAbsStmts pats e1 e2    
foldAgainstAbs pats e1 e2 = [e1] 
foldAgainstAbsAlt pats as _ = as

foldAgainstAbs' pats [] [] = []
foldAgainstAbs' p x  [] = []
foldAgainstAbs' p [] x  = [] 
foldAgainstAbs' p (e:es) (x:xs) = foldAgainstAbs p e x : foldAgainstAbs' p es xs

foldAgainstAbsStmts pats a@(HsGenerator _ p1 e1 s1) b@(HsGenerator _ p2 e2 s2)
 = foldAgainstAbs (pats++[p1]++[p2]) e1 e2 ++ foldAgainstAbsStmts (pats++[p1]++[p2]) s1 s2
foldAgainstAbsStmts pats (HsQualifier e1 s1) (HsQualifier e2 s2)
 = foldAgainstAbs pats e1 e2 ++ foldAgainstAbsStmts pats s1 s2
foldAgainstAbsStmts pats (HsLast e1) (HsLast e2)
 = foldAgainstAbs pats e1 e2
foldAgainstAbsStmts pats (HsLast e1) (HsQualifier e2 s1)
 = foldAgainstAbs pats e1 e2

-- createParameters :: HsExpP -> HsDeclP
-- createParameters mod n [] = return []
createParameters mods n Nothing = return Nothing
createParameters mods n (Just e)
   = do
        numParams <- countParams e
        let nameParams = mkNewNames (length numParams) e []
        
        e' <- renameNormals e nameParams
        let newDec = createDec (transformBindings e') nameParams
        return (Just newDec)
        where
          transformBindings (Exp (HsDo stmts))
           = (Exp (HsDo (transformBind [] stmts)))
          transformBindings e = e
          
          transformBind pats (HsGenerator s p1 e1 stmts)
            = (HsGenerator s p1 e1 (transformBind (pats++[p1]) stmts))
          transformBind pats (HsQualifier e stmts)
            = (HsQualifier e (transformBind pats stmts))
          transformBind pats (HsLast e)
           | e == defaultExp
              = (HsLast (Exp (HsApp (nameToExp "return") (Exp (HsTuple (getPats pats))))))
           | pats /= [] = (HsQualifier e (HsLast (Exp (HsApp (nameToExp "return") (Exp (HsTuple (getPats pats)))))))
           | otherwise = (HsLast e)
        
          
          getPats [] = []
          getPats (p:ps) = nameToExp (pNTtoName (patToPNT p)) : getPats ps
        
          createDec e' nameParams
            = Dec (HsFunBind loc0 [HsMatch loc0 (nameToPNT newName) 
                                                (map nameToPat nameParams)
                                                (HsBody e') 
                                                [] ])
           
           
          newName = mkNewName "abs" (map pNTtoName (hsPNTs mods)) n
           
          renameNormals e [] = return e
          renameNormals e (x:xs)
             = do
                  e' <- renameANorm e x
                  res <- renameNormals e' xs
                  return res
           where
             renameANorm e x
               = applyTP (once_tdTP (failTP `adhocTP` (inPNT x))) e
             inPNT x (p::PNT) 
              | pNTtoName p == "$I" = return (nameToPNT x)
             inPNT _ _ = mzero  
        
          countParams t
            = applyTU (full_tdTU (constTU [] `adhocTU` inPNT)) t
          inPNT (p::PNT)
            | pNTtoName p == "$I" = return [p]
          inPNT x = return []
        
          mkNewNames :: Int -> HsExpP -> [String] -> [String]
          mkNewNames 0 e names = names 
          mkNewNames n e names
            = mkNewNames (n-1) e (result : names) 
              where
                result = mkNewName "p" (oldNames ++ names) n
                oldNames = map pNTtoName (hsPNTs e)
       
posToExp :: (Term t) => [PosToken] -> t -> [(SimpPos, SimpPos)] -> [HsExpP]
posToExp _ _ [] = []
posToExp toks mod ((x,y):xs) 
  = locToExp x y toks mod    : posToExp toks mod xs   

-- compareExp takes a clone class and tries to
-- figure out which parts can be extracted away or not.

-- we take all the variables out of each expression and compare them
-- the ones that match stay in the abstraction, 
createAbs' :: [ HsExpP ] -> [ HsExpP ]
createAbs' [] = []
createAbs' [x] = [compareExp [] x x]
createAbs' (x:y:es)
 = int : createAbs' (y:es)
  where 
    int = compareExp [] x y

createAbs'' :: [ HsExpP ] -> Maybe HsExpP
createAbs'' [] = Nothing
createAbs'' [x] = Just x
createAbs'' (x:y:xs)
 = createAbs'' ((compareExp [] x y):xs)

createAbs :: [ HsExpP ] -> Maybe HsExpP 
createAbs list
  = let f = createAbs' list in (createAbs'' f)


compareExp :: [HsPatP] -> HsExpP -> HsExpP -> HsExpP
compareExp pats e@(Exp (HsId (HsVar x))) (Exp (HsId (HsVar y)))
  | x == y && isTopLevelPNT x = e
  | checkPNTInPat pats x = e
  | otherwise = (Exp (HsId (HsVar (nameToPNT "$I"))))
compareExp pats e@(Exp (HsId (HsCon x))) (Exp (HsId (HsCon y)))
  | x == y    = e
  | otherwise = (Exp (HsId (HsVar (nameToPNT "$I"))))
compareExp pats e@(Exp (HsLit s l1)) (Exp (HsLit s2 l2))
  | l1 == l2  = e
  | otherwise = (Exp (HsId (HsVar (nameToPNT "$I"))))
compareExp pats e@(Exp (HsInfixApp e1 o1 e2)) (Exp (HsInfixApp e3 o2 e4))
  = Exp (HsInfixApp e1' o1' e2')
     where
       e1' = compareExp pats e1 e3
       o1' 
        | o1 == o2  = o1
        | otherwise = HsVar (nameToPNT "$I")
       e2' = compareExp pats e2 e4
compareExp pats e@(Exp (HsApp e1 e2)) (Exp (HsApp e3 e4))
 = Exp (HsApp (compareExp pats e1 e3) (compareExp pats e2 e4))
compareExp pats e@(Exp (HsNegApp s1 e1)) (Exp (HsNegApp s2 e2))
 = Exp (HsNegApp s1 (compareExp pats e1 e2))
compareExp pats1 e@(Exp (HsLambda pats e1)) (Exp (HsLambda pats2 e2))
 = Exp (HsLambda pats (compareExp pats1 e1 e2))
compareExp pats e@(Exp (HsLet decs e1)) (Exp (HsLet decs2 e2))
 = Exp (HsLet decs (compareExp pats e1 e2))
compareExp pats e@(Exp (HsIf e1 e2 e3)) (Exp (HsIf e4 e5 e6))
 = Exp (HsIf e1' e2' e3')
    where
     e1' = compareExp pats e1 e4
     e2' = compareExp pats e2 e5
     e3' = compareExp pats e3 e6
compareExp pats e@(Exp (HsCase e1 alts1)) (Exp (HsCase e2 alts2))
 = Exp (HsCase (compareExp pats e1 e2) (compareAlt pats alts1 alts2))
compareExp pats e@(Exp (HsParen e1)) (Exp (HsParen e2))
 = Exp (HsParen (compareExp pats e1 e2))
compareExp pats (Exp (HsParen e1)) e2
 = compareExp pats e1 e2
compareExp pats e1 (Exp (HsParen e2))
 = compareExp pats e1 e2 
compareExp pats (Exp (HsList es1)) (Exp (HsList es2))
 = Exp (HsList (compareExp' pats es1 es2))
compareExp pats (Exp (HsTuple es1)) (Exp (HsTuple es2))
 = Exp (HsTuple (compareExp' pats es1 es2))
compareExp pats (Exp (HsLeftSection e1 i1)) (Exp (HsLeftSection e2 i2))
 = Exp (HsLeftSection (compareExp pats e1 e2) i2')
   where
     i2' 
       | i1 == i2 = i1 
       | otherwise = HsVar (nameToPNT "$I")
compareExp pats (Exp (HsRightSection i1 e1)) (Exp (HsRightSection i2 e2))
 = Exp (HsRightSection i1' (compareExp pats e1 e2))
   where
     i1' 
      | i1 == i2 = i1
      | otherwise = HsVar (nameToPNT "$I" )
compareExp pats (Exp (HsEnumFrom e1)) (Exp (HsEnumFrom e2))
 = Exp (HsEnumFrom (compareExp pats e1 e2))
compareExp pats (Exp (HsEnumFromTo e1 e2)) (Exp (HsEnumFromTo e3 e4))
 = Exp (HsEnumFromTo (compareExp pats e1 e3) (compareExp pats e2 e4))
compareExp pats (Exp (HsEnumFromThen e1 e2)) (Exp (HsEnumFromThen e3 e4))
 = Exp (HsEnumFromThen (compareExp pats e1 e3) (compareExp pats e2 e4))
compareExp pats (Exp (HsEnumFromThenTo e1 e2 e3)) (Exp (HsEnumFromThenTo e4 e5 e6))
 = Exp (HsEnumFromThenTo (compareExp pats e1 e4) (compareExp pats e2 e5) (compareExp pats e3 e6))
compareExp pats (Exp (HsAsPat i1 e1)) (Exp (HsAsPat i2 e2))
 = Exp (HsAsPat i1' (compareExp pats e1 e2))
   where
    i1' 
     | i1 == i2 = i1
     | otherwise = (nameToPNT "$I")
compareExp pats (Exp (HsIrrPat e1)) (Exp (HsIrrPat e2))
 = Exp (HsIrrPat (compareExp pats e1 e2))
compareExp pats e1@(Exp (HsDo stmts1)) e2@(Exp (HsDo stmts2))
 = Exp (HsDo (compareStmts pats stmts1 stmts2))
compareExp pats e1 e2 = (Exp (HsId (HsVar (nameToPNT "$I"))))
compareAlt pats as _ = as

compareStmts pats (HsGenerator s p1 e1 s1) (HsGenerator _ p2 e2 s2)
 = HsGenerator s p1 (compareExp (pats++[p1]++[p2]) e1 e2) (compareStmts (pats++[p1]++[p2]) s1 s2)
compareStmts pats (HsQualifier e1 stmts1) (HsQualifier e2 stmts2)
 = HsQualifier (compareExp pats e1 e2) (compareStmts pats stmts1 stmts2)
compareStmts pats (HsLast e1) (HsLast e2)
 = HsLast (compareExp pats e1 e2)
compareStmts pats s1 s2 = s1


compareExp' p [] [] = []
compareExp' p _ [] = []
compareExp' p [] _ = []
compareExp' p (e:es) (x:xs) = compareExp p e x : compareExp' p es xs
       
catPositions :: String -> [ String ]
catPositions [] = []
catPositions ('[':ps)
   = grabbed : catPositions ps'
      where 
        (grabbed, ps') = (grabPositions ps, dropPositions ps)
        grabPositions [] = []
        grabPositions (']':xs) = []
        grabPositions ('<':'&':'>':ps)
          = ":" ++ grabPositions ps
        grabPositions (x:xs) = x : grabPositions xs
        
        dropPositions [] = []
        dropPositions (']':xs) = xs
        dropPositions (x:xs) = dropPositions xs

        
prunePositions :: String -> [String] -> [ [(SimpPos, SimpPos)] ]
prunePositions [] [] = []
prunePositions [] _  = []
prunePositions _ []  = []
prunePositions as (p:ps) 
   = createSet as p : prunePositions remAnswers ps
    where
      remAnswers = drop ((length (filter (==':') p)) + 1) as
    
      createSet :: String -> String -> [ (SimpPos, SimpPos) ]
      createSet [] [] = []
      createSet [] _  = []
      createSet _  [] = []
      createSet ('y':xs) ps    
         = ((read p2)::(SimpPos, SimpPos)) : createSet xs ps'
           where
             p2  = getPos ps 
             ps' = dropPos ps
             getPos [] = []
             getPos (':':xs) = []
             getPos (x:xs)   = x : getPos xs
             
             dropPos [] = []
             dropPos (':':xs) = xs
             dropPos (x:xs)   = dropPos xs
         
      createSet ('n':xs) ps
         = createSet xs ps'
            where
             ps' = dropPos ps
             
             dropPos [] = []
             dropPos (':':xs) = xs
             dropPos (x:xs)   = dropPos xs

      createSet _ _ = []