module RefacGenDef(generaliseDef) where

import PrettyPrint
import PosSyntax
import Maybe
import TypedIds
import UniqueNames 
import PNT 
import TiPNT   
import List 
import RefacUtils

{-A definition can be generialised by selecting a sub-expression of the RHS of the definition,
  and introducing that sub-expression as a new argument to the function/constant at each of its 
  call sites. At the same time, a new formal parameter will be added to the generalised definition.

  When generalising a definition in a mutli-module context, there maybe several cases:
  1. The definition is not exported by the current module: refactoring only afftects this module.
  2. The definition is exported by the current module, but not used by any client modules.
  3. The definition is exported by the current module, and used any some client modules:
    2.1 The selected sub-expression does not contain any free variables.
    2.2 The selected sub-expression contains free variables. In this case, this is a possiblity that
        some of the free variables may not be visible in the client modules. These free variables might
        be from the current module, or from other modules that are imported by the current modules.One
        implementation option is to make these variables also visible to the client modules by modifying/
        adding import declarations. This involves chasing the origins of these free variables, and detecting
        possible name clashes/captures. Another implementation option is to define an auxiliary function
        to denote the sub-expression, and make this function visible to the client modules. We take the 
        second option in our implementation. To ensure that the new function name does not cause name clash
        in the client modules, we take the visble names both in the current module and in the client modules 
        into account when creating the new function name.
-}

generaliseDef args
 = let fileName     = args!!0
       newParamName = args!!1            
       beginPos     = (read (args!!2), read (args!!3))::(Int,Int)
       endPos       = (read (args!!4), read (args!!5)) :: (Int,Int)
   in if isVarId newParamName -- the parameter name is a valid name.
      then do modName <- RefacUtils.fileNameToModName fileName
              (inscps,exps,mod, tokList) <- parseSourceFile fileName 
              let (pnt,subExp) = findDefNameAndExp tokList beginPos endPos  mod
                  pn           = pNTtoPN pnt
              if pn == defaultPN || subExp == defaultExp
                then error ("The highlighted source does not contain a rhs sub-expression, " ++
                       "or the selected sub-expression does not contain any identifiers so that the refactor could not locate it.")
                            
                else if isExported pnt exps 
                       then do clients <- clientModsAndFiles modName  -- returns [(module name ,filename)]
                               info    <- mapM parseSourceFile (map snd clients)   -- parse all the client modules
                               let funPName
                                    =if clients /= [] && hasFreeVars subExp  --THIS CONDITION MIGHT A LITTLE BIT LOOSE. 
                                                                              --HOW ABOUT NONE OF THE CLIENTS USE IT?
                                        then let inscpNames =map (\ (x,_,_,_)->x) $ concatMap inScopeInfo (map myfst info) -- calculate all visibe names
                                             in  Just =<< mkNewFunPName pn (hsDecls mod) modName inscpNames
                                        else Nothing
                                   subExp' = if isJust funPName then pNtoExp (fromJust funPName) else subExp 
                               (mod',((tokList',m),_)) <- doGeneralise pnt fileName subExp newParamName funPName mod tokList
                                                                           
                               refactoredClients   <- mapM (generaliseInClientMod pnt subExp' modName funPName)
                                                       $ zip info (map snd clients)
                               writeRefactoredFiles False $ ((fileName,m), (tokList',mod')):refactoredClients                        
                       else do (mod',((tokList',m),_))<-doGeneralise pnt fileName subExp newParamName Nothing mod tokList
                               writeRefactoredFiles False [((fileName,m), (tokList',mod'))]
      else error "Invalid parameter name!" 
  where
   
   --find the definition name whose sub-expression has been selected, and the selected sub-expression.
   findDefNameAndExp toks beginPos endPos t 
    = fromMaybe (defaultPNT, defaultExp) (applyTU (once_tdTU (failTU `adhocTU` inMatch
                                                                     `adhocTU` inPat)) t)  --CAN NOT USE 'once_tdTU' here. 

     where  --The selected sub-expression is in the rhs of a match
           inMatch (match@(HsMatch loc1  pnt pats rhs ds)::HsMatchP)
             | locToExp beginPos endPos toks rhs /= defaultExp
             = Just (pnt, locToExp beginPos endPos toks rhs)
           inMatch _ = Nothing
        
           --The selected sub-expression is in the rhs of a pattern-binding
           inPat (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)
             | locToExp beginPos endPos toks rhs /= defaultExp
             = if isSimplePatBind' pat
                then Just (patToPNT ps, locToExp beginPos endPos toks rhs)    
                else error "A complex pattern binding can not be generalised!"
           inPat _ = Nothing


           isSimplePatBind' (Dec (HsPatBind _ p _ _)) = isPatID p

           isPatID (Pat (HsPId (HsVar pnt))) = True
           isPatID p = False
 
   -- Do generalisation in current module.
   doGeneralise pnt@(PNT pn _ _) fileName subExp newParamName newFunPName mod tokList
     = runStateT (if isJust newFunPName
                    then do -- add the new function name to the export list
                            mod'<-addItemsToExport mod (Just pn) False (Left [pNtoName (fromJust newFunPName)]) 
                            doGeneralise' mod'
                    else doGeneralise' mod) ((tokList,unmodified),(-1000,0))
      where 
    
      doGeneralise' mod 
         = applyTP (once_tdTP (failTP `adhocTP` inMod
                                      `adhocTP` inMatch
                                      `adhocTP` inPat
                                      `adhocTP` inLet
                                      `adhocTP` inAlt
                                      `adhocTP` inStmt) `choiceTP` failure) mod               
        where

           --1.pn is declared in top level
           inMod (mod@(HsModule loc name exps imps ds):: HsModuleP)  
               | definingDecls [pn] ds False False/=[] 
              = do worker pnt subExp newParamName mod ds newFunPName 
           inMod _ =mzero  
           
           --2. pn is declared locally in the where clause of a match.
           inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)
               | definingDecls [pn] ds False  False/=[] 
              = worker pnt subExp newParamName match ds newFunPName
           inMatch _ =mzero

           --3. pn is declared locally in the where clause of a pattern binding.
           inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)
               | definingDecls [pn] ds False  False /=[] 
              =  worker pnt subExp newParamName pat ds newFunPName                  
           inPat _=mzero
  
           --4: pn is declared locally in a  Let expression
           inLet (letExp@(Exp (HsLet ds e))::HsExpP)
               | definingDecls [pn] ds False  False /=[] 
               = worker pnt subExp newParamName letExp ds newFunPName 
           inLet _=mzero
                
           --5. pn is declared locally in a  case alternative.
           inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)
               | definingDecls [pn] ds False  False/=[] 
               = worker pnt subExp newParamName alt ds newFunPName
           inAlt _=mzero
      
            --6.pn is declared locally in a let statement.
           inStmt (letStmt@(HsLetStmt ds stmts):: HsStmtP)
               | definingDecls [pn] ds False  False/=[] 
             = worker pnt subExp newParamName letStmt ds newFunPName 
           inStmt _=mzero
            
           failure=idTP `adhocTP` mod
               where mod (m::HsModuleP)=error "Refactoring failed"
          

      worker pnt@(PNT pn _ _) subExp newParamName parent ds newFunPName
       = do --add formal parameter to the generalised function
           let newParamPName = nameToPN newParamName 
               declToBeGeneralised = definingDecls [pn] ds False False
           doChecking declToBeGeneralised
           parent' <- if isJust newFunPName 
                       then do let declToAdd=Dec (HsPatBind loc0 (pNtoPat (fromJust newFunPName)) (HsBody subExp) [])
                               addDecl parent (Just pn) ([declToAdd],Nothing) True 
                       else return parent                               
           ds''<-replaceExpByParam pn subExp newParamPName =<<commentOutTypeSig pn (hsDecls parent')
           ds'''<-addParamsToDecls ds'' pn [newParamPName] True

           --ds''<- addFormalParam pn subExp newParamName =<<commentOutTypeSig pn ds'  
           --Check clashed names because of the adding of subExp as a actual parameter.
           parent''<- renamingCheck pn subExp $ replaceDecls parent' ds'''
           --Adding the actual parameter to each call site of the generalised function name.
           addActualArg False pn subExp parent''
        where
         doChecking decl   
          = do (expFreeVars,_) <- hsFreeAndDeclaredPNs subExp
               (defFreeVars,_) <- hsFreeAndDeclaredPNs decl
               if expFreeVars \\ defFreeVars /= [] 
                 then do error "The selected expression should not contain locally declared variables!" 
                 else do (f,d) <- hsFDsFromInside =<<  replaceExpByDefault subExp decl       
                         d'   <- hsVisiblePNs  subExp decl                
                         if elem newParamName $ map pNtoName (f `union` d `union` d')
                          then error "The parameter name will cause name clash or semantics change, please choose another name!"
                          else return ()
                  
           
         {- substitute the occurrence of an expression by the default expression,
            in order to get rid of the free variables in the generalised sub-expression -}
         replaceExpByDefault e = applyTP (once_tdTP (failTP `adhocTP` inExp)) 
          where
             --only replace the higelighted expression 
            inExp (e1::HsExpP)
             |sameOccurrence e1 e 
              = return defaultExp
            inExp x = mzero

         --Replace occurrence of the highlighted expression by the formal parameter.
         replaceExpByParam pn e paramPName = applyTP (once_tdTP (failTP `adhocTP` inDecl))                  
          where
            --The sub-expression is in the rhs of a function definition.
           inDecl (fun@(Dec (HsFunBind _  ((HsMatch _ (PNT pname _ _) _ _ _):ms)))::HsDeclP)
             | pn == pname 
              = replaceExpByParam' fun
            --The sub-expression is in the rhs of a pattern binding
           inDecl (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)
             | pn == patToPN  ps
              = replaceExpByParam' pat
           inDecl _ =mzero  
  
           replaceExpByParam'= applyTP (stop_tdTP (failTP `adhocTP` inExp))  -- use once_td to only replace the 
                                                                                       -- highlighted occurrence.
             where
              inExp (e1 ::HsExpP)
                | e1 == e  -- && srcLocs e == srcLocs e1   --ONLY REPLACE THE HIGHLIGHTED EXP.                                 
                = do let newExp=pNtoExp paramPName
                     update e1 newExp e1                             

              inExp e = mzero
                                 
         renamingCheck pn subExp parent
          = do --free variables declared in the highlighted expression
               (f,_) <- hsFreeAndDeclaredPNs subExp
                --visible variables to the generalised function name in its use places.
               vVars <- hsVisiblePNs pn parent
               --clasedNames names come  from the vVars
               let clashedNames = filter (\x->elem (pNtoName x) (map pNtoName f)) $  (nub vVars \\ nub f)
               if clashedNames == [] 
                 then return parent
                 else error ("The identifier(s):" ++ showEntities showPNwithLoc clashedNames ++
                          " will cause name capture/clash after generalisation, please do renaming first!")   

      {- if the generalised declaration is a direct recursion function, then add the parameter 
         as the actual argument; otherwise add the highlighted expression as a actual paramter 
         to the generalised function at each of its call sites -}
    
   addActualArg recursion pn subExp
        = if recursion then applyTP (stop_tdTP (failTP `adhocTP` funApp))
                       else applyTP (stop_tdTP (failTP `adhocTP` inDecl
                                                       `adhocTP` funApp))
       where 
         inDecl (fun@(Dec (HsFunBind _  ((HsMatch _ (PNT pname _ _) _ _ _):ms)))::HsDeclP)
           | pn == pname 
           = return fun

         inDecl (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)
           | pn == patToPN  ps
           = return pat             
         inDecl _ = mzero
        
         funApp (Exp (HsApp e  exp@(Exp (HsId (HsVar pnt@(PNT pname _ _ )))))::HsExpP)
           | pname == pn --ganrantee this is a use place of pn 
          = do exp'<-doAddingActulaArg pnt exp subExp True
               return (Exp (HsApp e  exp'))

         funApp (exp@(Exp (HsId (HsVar pnt@(PNT pname _ _))))::HsExpP)   
           | pname == pn  --ganrantee this is a use place of pn
          = doAddingActulaArg pnt exp subExp False

         funApp _ = mzero

   doAddingActulaArg pnt pntExp subExp addParen
     = do let newExp = if isSimpleExp subExp || isParenExp subExp 
                         then if addParen then (Exp (HsParen (Exp (HsApp pntExp subExp)))) 
                                          else (Exp (HsApp pntExp subExp))
                         else if addParen then (Exp (HsParen (Exp (HsApp pntExp (Exp (HsParen subExp))))))
                                          else (Exp (HsApp pntExp (Exp (HsParen subExp))))
          update pntExp newExp pntExp          

     where 

       
       isSimpleExp (Exp (HsId _))=True
       isSimpleExp (Exp (HsLit _ _))=True
       isSimpleExp _ =False

       isParenExp (Exp (HsParen _))=True
       isParenExp _=False
     
   addActualArgInClientMod pn qual funName toBeQualified t
      = applyTP (stop_tdTP (failTP `adhocTP`funApp)) t
       where 
         funApp (Exp (HsApp e  exp@(Exp (HsId (HsVar pnt@(PNT pname _ _ )))))::HsExpP)
           | pname == pn --ganrantee this is a use place of pn 
          = do vs <- hsVisibleNames pnt t 
               let e'=if toBeQualified || elem (pNtoName funName) vs  
                        then pNtoExp (qualifyPName qual funName)
                        else pNtoExp funName
               exp'<- doAddingActulaArg pnt exp  e' True             
               return (Exp (HsApp e  exp'))

         funApp (exp@(Exp (HsId (HsVar pnt@(PNT pname _ _))))::HsExpP)   
           | pname == pn  --ganrantee this is a use place of pn
          = do vs <- hsVisibleNames pnt t 
               let e'=if toBeQualified || elem (pNtoName funName) vs  
                        then pNtoExp (qualifyPName qual funName)
                        else pNtoExp funName
               doAddingActulaArg pnt exp e' False       
      
         funApp _ = mzero
        
   generaliseInClientMod pnt subExp serverModName newFunPName ((inscps, exps, mod,ts) ,fileName)
      = let qual  = hsQualifier  pnt inscps
            pn    = pNTtoPN pnt
        in if qual==[]
            then --This name is not imported
                 return ((fileName,unmodified), (ts,mod))
            else do (mod',((ts',m), _))
                       <- runStateT (if isNothing newFunPName 
                                       then addActualArg False pn subExp mod
                                       else do let funName=fromJust newFunPName
                                               mod' <- addItemsToImport serverModName (Just pn) (Left [pNtoName funName]) mod
                                               mod''<- addItemsToExport mod' (Just pn) False (Left [pNtoName funName]) 
                                               if isInScopeAndUnqualified (pNtoName pn) inscps
                                                 then addActualArgInClientMod pn  (head qual) funName False mod''
                                                 else addActualArgInClientMod pn  (head qual) funName True mod'')
                                     ((ts,unmodified), (-1000,0))
                    return ((fileName,m),(ts',mod'))    

myfst (a,_,_,_) = a  

{- Create the auxiliary function name. Suppose the original function name is 'f', 
   then the auxiliary function name is like 'f_gen_i', where i is an integer. -}
mkNewFunPName pn e modName inscopeNames 
   =do  (f1,d1) <- hsFDsFromInside e
        let name=mkNewName ((pNtoName pn)++"_gen") (nub ((map pNtoName (f1 `union` d1)) `union` inscopeNames)) 0  
        return (PN (UnQual name) (G modName name (N (Just loc0))))