module RefacDeForest(deforest) where

import PrettyPrint
import PosSyntax hiding(moduleName)
import Maybe
import TypedIds
import ScopeModule
import UniqueNames hiding (srcLoc)
import PNT 
import TiPNT 
import PFE0
import List  
import RefacUtils
import AbstractIO
import Prelude hiding(putStrLn,putStr)

-- this refactoring trys to eliminate intermeidate list.
deforest args
 = do let fileName= ghead "filename" args     
      modName <- fileNameToModName fileName 
      (inscps, exps, mod, tokList) <- parseSourceFile fileName
      let (newDecs,oldPNs,newPNs) = unzip3( head(getHsMatch mod) )   	
      (mod',((tokList',m),_)) <- doFuseCurrent mod tokList newDecs oldPNs newPNs fileName        
      clients<-clientModsAndFiles modName  
      let (clientsMod,clientFiles)= unzip clients         
      refactoredClients <- mapM (doFuseInClient tokList newDecs oldPNs newPNs ) clients
      writeRefactoredFiles False $ ((fileName,m),(tokList',mod')):refactoredClients

  where
	
    simpDec mod = fromJust ( applyTP ( full_tdTP ( idTP `adhocTP` simplifyDecl) ) mod)

    fil x mod = filter notInUsed x where
		notInUsed:: HsDeclP -> Bool
		notInUsed t = not (isDeclaredIn (getPN t) mod )


    getHsMatch  m = applyTU (full_tdTU (constTU [] `adhocTU`  special ) ) m where
		    special x = do  p <- simplifyDecl x
				    convertDec p 
		    simpDec m = applyTP (full_tdTP (idTP `adhocTP` simplifyDecl) ) m
	

    doFuseInClient tokList newDecs oldPNs newPNs (modName,fileName)
      = do (inscps, exps, mod, tokList) <- parseSourceFile fileName
  	   (mod',((tokList',m),_)) <- doFuseClient mod tokList newDecs oldPNs newPNs fileName 
	   return ( (fileName,True),(tokList',mod'))

    doFuseCurrent  mod tokList  newDecs oldPNs newPNs fileName 
      =runStateT (fus mod) (( tokList,unmodified), (-1000, 0)) where
	fus mod =do mod' <- addDecl mod Nothing (fil newDecs mod , Nothing )True 
		    replaceFold mod' oldPNs newPNs  
			
			--replace all :  foldr f n (fb) -> fb_workder f n 


    doFuseClient  mod tokList  newDecs oldPNs newPNs  fileName
	= runStateT ( replaceFold mod  oldPNs newPNs  )  (( tokList,unmodified), (-1000, 0))


    replaceFold mod  oldPNs newPNs 
       = applyTP ( full_tdTP (idTP `adhocTP` convertFold) ) mod 
      where
	convertFold  a@(Exp(HsApp(Exp(HsApp (Exp(HsApp fol f )) n ) ) exp  ) ) 
	  | (isFunc fol "foldr") && (findPNs  oldPNs (strip exp) ) -- can be fused
	   = do newExp <-  melt exp p newP f n
		update a newExp a 
	  | otherwise = return a
           where
	     p = getPNFromExp (strip(exp))
	     newP = newPNs !!  ( fromJust ( elemIndex p oldPNs))

	     convertFold a = return a

	     melt exp pn newPn f n = ( applyTP (full_tdTP (idTP `adhocTP` changeF)) exp)
               where
		changeF exp@(Exp(HsId(HsVar(PNT pName a b ) ) )) 
		   | (pName== pn)= return (Exp(HsApp (Exp(HsApp (Exp(HsId(HsVar(PNT newPn a b)))) f )) n ))
	   	   | otherwise = return exp
		changeF exp = return exp
	     

    getCataFun = applyTU (full_tdTU ( constTU[] `adhocTU` recToCata) ) 	


strip (Exp(HsApp exp1 exp2 ) ) = strip exp1
strip a@(Exp(_)) = a
                        

build [] = nameToExp "n"
build (x:xs) = Exp(HsApp (Exp(HsApp (nameToExp "c") x))  (build xs) )

--get PN from a Decl 
getPN ( Dec(HsFunBind t ( (HsMatch src (PNT pn _ _) pat body loc):xs))) = pn 


colListCons :: HsIdentI PNT -> [ [HsIdentI PNT]]
colListCons x = if (isListCons x) then  return [x] else return []

-- takes an Exp and return itself if it is an (:) list constructor 
isListCons  (HsCon (PNT (PN (UnQual ":") (G (PlainModule "Prelude") ":"_ )) _ _))    = True
isListCons _ = False


--check if this Exp has a fun call `name` 
isFunc f@(Exp (HsId (HsVar (PNT (PN (UnQual fName) _) _  _)))) name = (fName == name)
isFunc _ _= False



bodyHasCons (HsBody(e)) =  expHasCons e


expHasCons (Exp (HsInfixApp _ cons _ )) =  isListCons cons
expHasCons (Exp ( HsApp (Exp(HsApp (Exp(HsId(cons)))  exp1 )) exp2   ) ) = isListCons cons
expHasCons (Exp(HsList _)) = True
expHasCons _ = False



modBody (HsBody e) = (HsBody (modExp e))

modExp  (Exp (HsInfixApp exp1 cons exp2)) = (addWrapper exp1 exp2)
modExp  (Exp ( HsApp (Exp(HsApp cons  exp1)) exp2 ) ) = (addWrapper exp1 exp2)
modExp  (Exp(HsList x )) = build x
modExp a = a


addWrapper exp1 exp2 = Exp (HsApp (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "c") (S loc0)) Value (N (Just loc0)))))) (  exp1  ))) (exp2  ))


getPnFromPNT (PNT pn _ _ ) = pn

getPNFromExp exp =  ( fromJust $ applyTU ( once_tdTU ( failTU `adhocTU` idPN) ) exp) where
    idPN :: PName -> Maybe PName
    idPN a = Just a


--convertDec takes a Dec check if we can convert it into cata form if not simply return itself
--convertDec :: HsDeclP ->  [ [ (HsDeclP,HsName,HsName) ] ] 

convertDec d@( Dec(HsFunBind t [m@(HsMatch src pnt pat body loc)]))= 
	if isFormed body then return [ ( (Dec (HsFunBind t [convertMatch m] ) ), getPnFromPNT pnt, getPnFromPNT $ change pnt)]
	else return []  where
		isFormed ((HsBody (Exp (HsCase exp1 alt) ))) = checkAltL alt where
			checkAltL [] = True
			checkAltL (x:xs) = (checkAlt x) && (checkAltL xs) where
				checkAlt (HsAlt src p bo d) = bodyHasCons bo
			
		 
		isFormed ((HsBody(e@(Exp( HsIf e1 e2 e3) ) ))) = checkIfExp e where
			checkIfExp (Exp(HsIf e1 e2 e3 )) = expHasCons e2  && checkIfExp e3
			checkIfExp e = expHasCons e
			--checkIfExp _ = True

			
		isFormed _ = False
	
		-- add "_worker" to the function name in PNT
		change p@(PNT ( PN (UnQual f) (G v1 f1 v2 ) )v3  pat )    = PNT (PN(UnQual (f++"_worker")) (G v1  (f++"_worker") v2 )) v3 pat   
		change p = p

		convertMatch (HsMatch src pnt pat body loc) = HsMatch src (change pnt) ([nameToPat "c",nameToPat "n"] ++ pat) (convertBody body) loc	where
			
			convertBody (HsBody(Exp (HsCase exp alt))) = (HsBody(Exp(HsCase exp (convertAlt alt))))
			convertBody (HsBody(Exp (HsIf e1 e2 e3))) = (HsBody(Exp( HsIf e1 e2' e3'))) where
				e2' = modIfExp e2 
				e3' = modIfExp e3 
				modIfExp (Exp(HsIf a1 a2 a3 )) = (Exp(HsIf a1 (changeFToF (modExp a2) pnt) (modIfExp a3) ))
				modIfExp e = changeFToF (modExp e) pnt




			convertAlt [] = []
			convertAlt (x :xs) = (con x) : (convertAlt xs)
			con (HsAlt src p bo d ) = changeFToF (HsAlt src p (modBody bo)d) pnt


			changeFToF m  p = fromJust $ (applyTP( full_tdTP ( idTP `adhocTP` changeFToF# ) )) m where
			    changeFToF# :: HsExpP -> Maybe  HsExpP
			    changeFToF# e@(Exp(HsId(HsVar pnt))) = if (p==pnt) then  
								return ( Exp(HsApp (Exp(HsApp (Exp(HsId(HsVar (change pnt)))) (nameToExp "c"))) (nameToExp "n") ))
								 else return e
			    changeFToF# a = Just a

			
		
convertDec d = return [] 


-- from recursion to cataformlism

recToCata :: HsDeclP -> [[HsDeclP]]
recToCata d@( Dec(HsFunBind t [m@(HsMatch src pnt pat body loc)])) = if (check body) then return [d] else return [] where
	check b@(HsBody (Exp (HsCase exp1 alt) )) = checkAlt alt
	check _ = False
	checkAlt [ (HsAlt src1 (Pat (HsPTuple _ p1)) bo1 d1), (HsAlt src2 (Pat (HsPTuple _ p2)) bo2 d2) ] = doCheck p1 p2
	checkAlt _ = False  
	doCheck p1 p2 = (match ==1 )where
		match = count p1 p2
		count (x:xs) (y:ys)= if (eq x y) then 0 + count xs ys
                                     else if (isEmptyPList x && isConsPat y) || 
                                                (isConsPat x && isEmptyPList y) then count xs ys + 1
				     else 2 + count xs ys
		count _  _ = 0
		isConsPat (Pat (HsPParen (Pat (HsPInfixApp a cons b)))) = isListPNT cons
		isConsPat _ = False

                
                -- takes an Exp and return itself if it is an (:) list constructor 
                isListPNT  (PNT (PN (UnQual ":") (G (PlainModule "Prelude") ":"_ )) _ _) = True
                isListPNT  _ = False

                isEmptyPList (Pat (HsPList _ [])) = True
                isEmptyPList _ = False 
		
		eq (Pat (HsPId (HsVar (PNT (PN pn1 _)  _ _))))   (Pat (HsPId (HsVar (PNT (PN pn2 _)  _ _)))) = pn2==pn1
		eq _ _ = False
					 
								   
recToCata _ = return []