module Language.Haskell.Refact.MoveDef
  ( liftToTopLevel
  , liftOneLevel
  , demote
  
  ) where
import qualified Data.Generics as SYB
import qualified GHC.SYB.Utils as SYB
import qualified Exception             as GHC
import qualified GHC
import qualified Name                  as GHC
import Control.Exception
import Control.Monad.State
import qualified Data.Generics.Zipper as Z
import Data.List
import Data.Maybe
import Language.Haskell.GhcMod
import Language.Haskell.Refact.Utils
import Language.Haskell.Refact.Utils.GhcUtils
import Language.Haskell.Refact.Utils.GhcVersionSpecific
import Language.Haskell.Refact.Utils.LocUtils
import Language.Haskell.Refact.Utils.Monad
import Language.Haskell.Refact.Utils.MonadFunctions
import Language.Haskell.Refact.Utils.TokenUtils
import Language.Haskell.Refact.Utils.TypeSyn
import Language.Haskell.Refact.Utils.TypeUtils
import Data.Generics.Strafunski.StrategyLib.StrategyLib
liftToTopLevel :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath]
liftToTopLevel settings cradle fileName (row,col) =
  runRefacSession settings cradle (compLiftToTopLevel fileName (row,col))
compLiftToTopLevel :: FilePath -> SimpPos
     -> RefactGhc [ApplyRefacResult]
compLiftToTopLevel fileName (row,col) = do
      getModuleGhc fileName
      renamed <- getRefactRenamed
      parsed  <- getRefactParsed
      let (Just (modName,_)) = getModuleName parsed
      let maybePn = locToName (row, col) renamed
      case maybePn of
        Just pn ->  do
            liftToTopLevel' modName pn
        _       ->  error "\nInvalid cursor position!\n"
liftOneLevel :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath]
liftOneLevel settings cradle fileName (row,col) =
  runRefacSession settings cradle (compLiftOneLevel fileName (row,col))
compLiftOneLevel :: FilePath -> SimpPos
     -> RefactGhc [ApplyRefacResult]
compLiftOneLevel fileName (row,col) = do
      getModuleGhc fileName
      renamed <- getRefactRenamed
      parsed  <- getRefactParsed
      
      logm $ "compLiftOneLevel:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) 
      let (Just (modName,_)) = getModuleName parsed
      let maybePn = locToName (row, col) renamed
      case maybePn of
        Just pn ->  do
            rs <- liftOneLevel' modName pn
            logm $ "compLiftOneLevel:rs=" ++ (show $ (refactDone rs,map (\((_,d),_) -> d) rs))
            if (refactDone rs)
              then return rs
              else error ( "Lifting this definition failed. "++
                       " This might be because that the definition to be "++
                       "lifted is defined in a class/instance declaration.")
        _       ->  error "\nInvalid cursor position!\n"
demote :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath]
demote settings cradle fileName (row,col) =
  runRefacSession settings cradle (compDemote fileName (row,col))
compDemote ::FilePath -> SimpPos
         -> RefactGhc [ApplyRefacResult]
compDemote fileName (row,col) = do
      getModuleGhc fileName
      renamed <- getRefactRenamed
      parsed  <- getRefactParsed
      let (Just (modName,_)) = getModuleName parsed
      let maybePn = locToName (row, col) renamed
      case maybePn of
        Just pn -> do
          demote' modName pn
        _       -> error "\nInvalid cursor position!\n"
liftToTopLevel' :: GHC.ModuleName 
                -> GHC.Located GHC.Name
                -> RefactGhc [ApplyRefacResult]
liftToTopLevel' modName pn@(GHC.L _ n) = do
  renamed <- getRefactRenamed
  
  logm $ "liftToTopLevel':pn=" ++ (showGhc pn)
  if isLocalFunOrPatName n renamed
      then do
              (refactoredMod,declPns) <- applyRefac (liftToMod) RSAlreadyLoaded
              logm $ "liftToTopLevel' applyRefac done "
              
              if modIsExported modName renamed
               then do clients <- clientModsAndFiles modName
                       logm $ "liftToTopLevel':(clients,declPns)=" ++ (showGhc (clients,declPns))
                       refactoredClients <- mapM (liftingInClientMod modName declPns) clients
                       return (refactoredMod:(concat refactoredClients))
               else do return [refactoredMod]
      else error "\nThe identifier is not a local function/pattern name!"
    where
          
       liftToMod = do
                      renamed <- getRefactRenamed
                      let declsr = hsBinds renamed
                      let (before,parent,after) = divideDecls declsr pn
                      
                      
                      let liftedDecls = definingDeclsNames [n] parent True True
                          declaredPns = nub $ concatMap definedPNs liftedDecls
                      
                      
                      logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns))
                      
                      pns <- pnsNeedRenaming renamed parent liftedDecls declaredPns
                      
                      let dd = getDeclaredVars $ hsBinds renamed
                      logm $ "liftToMod:(ddd)=" ++ (showGhc dd)
                      drawTokenTree "liftToMod.a"
                      if pns==[]
                        then do (parent',liftedDecls',paramAdded)<-addParamsToParentAndLiftedDecl n dd parent liftedDecls
                                let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls'
                                                                else liftedDecls'
                                drawTokenTree "liftToMod.c"
                                logm $ "liftToMod:(declaredPns)=" ++ (showGhc declaredPns)
                                
                                
                                mod' <- moveDecl1 (replaceBinds renamed (before++parent'++after))
                                       (Just (ghead "liftToMod" (definedPNs (ghead "liftToMod2" parent')))) 
                                       [GHC.unLoc pn] declaredPns True
                                drawTokenTree "liftToMod.b"
                                
                                return declaredPns
                        else askRenamingMsg pns "lifting"
moveDecl1 :: (HsValBinds t)
  => t 
  -> Maybe GHC.Name 
     
     
  -> [GHC.Name]     
  -> [GHC.Name]     
                    
  -> Bool           
  -> RefactGhc t    
moveDecl1 t defName ns sigNames topLevel
   = do
        
        
        let n = ghead "moveDecl1" ns
        
        let funBinding = definingDeclsNames' [n] t
        logm $ "moveDecl1: (ns,funBinding)=" ++ (showGhc (ns,funBinding)) 
        let Just sspan = getSrcSpan funBinding
        
        funToks <- getToksForSpan sspan
        logm $ "moveDecl1:funToks=" ++ (showToks funToks)
        drawTokenTree "moveDecl1:after getting toks" 
        
        
        (t'',sigsRemoved) <- rmTypeSigs sigNames t
        
        drawTokenTreeDetailed "moveDecl1:after rmTypeSigs" 
        
        (t',_declRemoved,_sigRemoved)  <- rmDecl (ghead "moveDecl3.1"  ns) False t''
        
        
        drawTokenTreeDetailed "moveDecl1:after rmDecl" 
        let getToksForMaybeSig (GHC.L ss _) =
                             do
                               sigToks <- getToksForSpan ss
                               return sigToks
        
        maybeToksSigMulti <- mapM getToksForMaybeSig
                             $ sortBy (\(GHC.L s1 _) (GHC.L s2 _) -> compare (srcSpanToForestSpan s1) (srcSpanToForestSpan s2))  
                                sigsRemoved
        let maybeToksSig = concat maybeToksSigMulti
        logm $ "moveDecl1:maybeToksSig=" ++ (show maybeToksSig) 
        logm $ "moveDecl1:(defName,topLevel)" ++ (showGhc (defName,topLevel)) 
        addDecl t' defName (ghead "moveDecl1 2" funBinding,sigsRemoved,Just (maybeToksSig ++ funToks)) topLevel
askRenamingMsg :: [GHC.Name] -> String -> t
askRenamingMsg pns str
  = error ("The identifier(s): " ++ (intercalate "," $ map showPN pns) ++
           " will cause name clash/capture or ambiguity occurrence problem after "
           ++ str ++", please do renaming first!")
  where
    showPN pn = showGhc (pn,GHC.nameSrcLoc pn)
pnsNeedRenaming :: (SYB.Data t1) =>
  t1 -> [GHC.LHsBind GHC.Name] -> t2 -> [GHC.Name]
  -> RefactGhc [GHC.Name]
pnsNeedRenaming dest parent _liftedDecls pns
   =do
       r <- mapM pnsNeedRenaming' pns
       return (concat r)
  where
     pnsNeedRenaming' pn
       = do
            let (f,d) = hsFDsFromInside dest 
                                             
            let vs = hsVisiblePNs pn parent  
            let 
                vars = map pNtoName (nub (f `union` d `union` vs) \\ [pn]) 
            
            isInScope <- isInScopeAndUnqualifiedGhc (pNtoName pn) Nothing
            logm $ "MoveDef.pnsNeedRenaming:(f,d,vs,vars,isInScope)=" ++ (showGhc (f,d,vs,vars,isInScope))
            if elem (pNtoName pn) vars  || isInScope && findEntity pn dest
               then return [pn]
               else return []
     
     pNtoName = showGhc
addParamsToParent :: (HsValBinds t) => GHC.Name -> [GHC.Name] -> t -> RefactGhc t
addParamsToParent _pn [] t = return t
addParamsToParent  pn params t = do
  logm $ "addParamsToParent:(pn,params)" ++ (showGhc (pn,params))
  t' <- addActualParamsToRhs True pn params t
  
  return t'
liftingInClientMod :: GHC.ModuleName -> [GHC.Name] -> GHC.ModSummary
  -> RefactGhc [ApplyRefacResult]
liftingInClientMod serverModName pns modSummary = do
       getModuleDetails modSummary
       renamed <- getRefactRenamed
       
       let clientModule = GHC.ms_mod modSummary
       logm $ "liftingInClientMod:clientModule=" ++ (showGhc clientModule)
  
       
       modNames <- willBeUnQualImportedBy serverModName
       logm $ "liftingInClientMod:modNames=" ++ (showGhc modNames)
       if isJust modNames
        then do
             pns' <- namesNeedToBeHided clientModule (fromJust modNames) pns
             logm $ "liftingInClientMod:pns'=" ++ (showGhc pns')
             
             if (nonEmptyList pns')
                 
                 then do (refactoredMod,_) <- applyRefac (addHiding serverModName renamed pns') RSAlreadyLoaded 
                         return [refactoredMod]
                 else return []
        else return []
willBeExportedByClientMod :: [GHC.ModuleName] -> GHC.RenamedSource -> Bool
willBeExportedByClientMod names renamed =
  let (_,_,exps,_) = renamed
  in if isNothing exps
        then False
        else any isJust $ map (\y-> (find (\x-> (simpModule x==Just y)) (fromJust exps))) names
     where simpModule (GHC.L _ (GHC.IEModuleContents m)) = Just m
           simpModule _  = Nothing
willBeUnQualImportedBy :: GHC.ModuleName -> RefactGhc (Maybe [GHC.ModuleName])
willBeUnQualImportedBy modName = do
   (_,imps,_,_) <- getRefactRenamed
   let ms = filter (\(GHC.L _ (GHC.ImportDecl (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as h))
                     -> modName == modName1 && (not isQualified) && (isNothing h || (isJust h && ((fst (fromJust h)) == True))))
                   imps
       res = if (emptyList ms) then Nothing
                               else Just $ nub $ map getModName ms
       getModName (GHC.L _ (GHC.ImportDecl (GHC.L _ modName2) _qualify _source _safe _isQualified _isImplicit as _h))
        = if isJust as then simpModName (fromJust as)
                       else modName2
       simpModName m = m
   logm $ "willBeUnQualImportedBy:(ms,res)=" ++ (showGhc (ms,res))
   return res
namesNeedToBeHided :: GHC.Module -> [GHC.ModuleName] -> [GHC.Name]
   -> RefactGhc [GHC.Name]
namesNeedToBeHided clientModule modNames pns = do
  renamed <- getRefactRenamed
  parsed <- getRefactParsed
  logm $ "namesNeedToBeHided:willBeExportedByClientMod=" ++ (show $ willBeExportedByClientMod modNames renamed)
  gnames <- GHC.getNamesInScope
  let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames
  logm $ "namesNeedToBeHided:(clientInscopes)=" ++ (showGhc (clientInscopes))
  pnsMapped <- mapM getLocalEquiv pns
  logm $ "namesNeedToBeHided:pnsMapped=" ++ (showGhc pnsMapped)
  let pnsMapped' = filter (\(_,_,ns) -> not $ emptyList ns) pnsMapped
  if willBeExportedByClientMod modNames renamed
      then return pns
      else do
        ff <- mapM (needToBeHided parsed) pnsMapped'
        return $ concat ff
  where
    
    
    
    getLocalEquiv :: GHC.Name -> RefactGhc (GHC.Name,String,[GHC.Name])
    getLocalEquiv pn = do
      let pnStr = stripPackage $ showGhc pn
      logm $ "MoveDef getLocalEquiv: about to parseName:" ++ (show pnStr)
      ecns <- GHC.gtry $ GHC.parseName pnStr
      let cns = case ecns of
                 Left (_e::SomeException) -> []
                 Right v -> v
      logm $ "MoveDef getLocalEquiv: cns:" ++ (showGhc cns)
      return (pn,pnStr,cns)
    stripPackage :: String -> String
    stripPackage str = reverse s
      where
        (s,_) = break (== '.') $ reverse str
    needToBeHided :: GHC.ParsedSource -> (GHC.Name,String,[GHC.Name]) -> RefactGhc [GHC.Name]
    needToBeHided parsed (pn,_pnStr,pnsLocal) = do
      let uwoq = map (\n -> usedWithoutQualR n parsed) pnsLocal
      
      logm $ "needToBeHided:(pn,uwoq)=" ++ (showGhc (pn,uwoq))
      if (any (== True) uwoq 
                
            
            
            
            || False)
           then return [pn]
           else return []
liftOneLevel' :: GHC.ModuleName
                -> GHC.Located GHC.Name
                -> RefactGhc [ApplyRefacResult]
liftOneLevel' modName pn@(GHC.L _ n) = do
  renamed <- getRefactRenamed
  if isLocalFunOrPatName n renamed
        then do 
                (refactoredMod,_) <- applyRefac (liftOneLevel'') RSAlreadyLoaded
                let (b, pns) = liftedToTopLevel pn renamed
                if b &&  modIsExported modName renamed
                  then do clients<-clientModsAndFiles modName
                          
                          refactoredClients <- mapM (liftingInClientMod modName pns) clients
                          return (refactoredMod:(concat refactoredClients))
                  else do return [refactoredMod]
        else error "\nThe identifer is not a function/pattern name!"
   where
      liftOneLevel''= do
             logm $ "in liftOneLevel''"
             renamed <- getRefactRenamed
             ztransformStagedM SYB.Renamer (Nothing
                                `SYB.mkQ` liftToModQ
                                `SYB.extQ` liftToMatchQ'
                                `SYB.extQ` liftToLet'
                                
                                
                                    ) (Z.toZipper renamed)
           where
             isValBinds :: GHC.HsValBinds GHC.Name -> Bool
             isValBinds _ = True
             isGRHSs :: GHC.GRHSs GHC.Name -> Bool
             isGRHSs _ = True
             isHsLet :: GHC.HsExpr GHC.Name -> Bool
             isHsLet (GHC.HsLet _ _) = True
             isHsLet _               = False
             liftToModQ ((g,_imps,_exps,_docs):: GHC.RenamedSource)
                | nonEmptyList candidateBinds
                  = Just (doLiftZ candidateBinds)
                | otherwise = Nothing
                where
                 candidateBinds = map snd
                                $ filter (\(l,_bs) -> nonEmptyList l)
                                $ map (\bs -> (definingDeclsNames [n] (hsBinds bs) False False,bs)) 
                                $ (hsBinds g)
             liftToMatchQ' :: (SYB.Data a) => GHC.Match GHC.Name -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a))
             liftToMatchQ' ((GHC.Match _pats _mtyp (GHC.GRHSs rhs ds))::GHC.Match GHC.Name)
                 | (nonEmptyList (definingDeclsNames [n] (hsBinds  ds) False False)) 
                    = Just (doLiftZ ds)
                 | (nonEmptyList (definingDeclsNames [n] (hsBinds rhs) False False))
                    = Just (doLiftZ rhs)
                 | otherwise = Nothing
             liftToLet' :: GHC.HsExpr GHC.Name -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a))
             liftToLet' ((GHC.HsLet ds _e)::GHC.HsExpr GHC.Name)
               | nonEmptyList (definingDeclsNames [n] (hsBinds ds) False  False)
                 = Just (doLiftZ ds)
               | otherwise = Nothing
             liftToLet' _ = Nothing
             doLiftZ :: (HsValBinds t)
               => t -> SYB.Stage -> Z.Zipper a
               -> RefactGhc (Z.Zipper a)
             doLiftZ ds _stage z =
                  do
                    logm $ "in liftOneLevel''.liftToLet in ds"
                    let zu = case (Z.up z) of
                              Just zz -> fromMaybe (error "MoveDef.liftToLet.1")
                                  $ upUntil (False `SYB.mkQ` isGRHSs
                                                   `SYB.extQ` isHsLet
                                                   `SYB.extQ` isValBinds)
                                     zz
                              Nothing -> z
                    let
                      wtop (ren::GHC.RenamedSource) = do
                        worker ren (hsBinds ds) pn True
                      wgrhs (grhss::GHC.GRHSs GHC.Name) = do
                         let (_,dd) = (hsFreeAndDeclaredPNs grhss)
                         worker1 grhss (hsBinds ds) pn dd False
                      wlet :: GHC.HsExpr GHC.Name -> RefactGhc (GHC.HsExpr GHC.Name)
                      wlet l@(GHC.HsLet dsl _e) = do
                        let (_,dd) = hsFreeAndDeclaredPNs dsl
                        dsl' <- worker1 l (hsBinds ds) pn dd False
                        return dsl'
                      wvalbinds (vb::GHC.HsValBinds GHC.Name) = do
                         let (_,dd) = (hsFreeAndDeclaredPNs vb)
                         worker1 vb (hsBinds ds) pn dd False
                    ds' <- Z.transM (SYB.mkM wtop `SYB.extM` wgrhs
                                     `SYB.extM` wlet `SYB.extM` wvalbinds) zu
                    return ds'
             
             worker :: (HsValBinds t)
                => t 
                -> [GHC.LHsBind GHC.Name] 
                                
                -> GHC.Located GHC.Name 
                                
                -> Bool 
                -> RefactGhc t
             worker dest ds pnn toToplevel
                  =do let (before,parent,after)=divideDecls ds pnn 
                          
                          liftedDecls=definingDeclsNames [n] parent True  True
                          declaredPns=nub $ concatMap definedPNs liftedDecls
                      logm $ "MoveDef.worker: (dest)=" ++ (SYB.showData SYB.Renamer 0 dest)
                      logm $ "MoveDef.worker: (ds)=" ++ (showGhc (ds))
                      logm $ "MoveDef.worker: parent=" ++ (showGhc parent)
                      let (_, dd) = hsFreeAndDeclaredPNs dest
                      
                      pns<-pnsNeedRenaming dest parent liftedDecls declaredPns
                      logm $ "MoveDef.worker: pns=" ++ (showGhc pns)
                      if pns==[]
                        then do
                                (parent',liftedDecls',paramAdded)<-addParamsToParentAndLiftedDecl n dd
                                                                     parent liftedDecls 
                                let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls'
                                                                else liftedDecls'
                                
                                dest'<-moveDecl1 (replaceBinds dest (before++parent'++after))
                                           (Just (ghead "worker" (definedPNs (ghead "worker" parent')))) 
                                           [n] declaredPns toToplevel 
                                return dest'
                                
                                
                        else askRenamingMsg pns "lifting"
             worker1 :: (HsValBinds t)
                => t 
                -> [GHC.LHsBind GHC.Name] 
                                
                -> GHC.Located GHC.Name 
                                
                -> [GHC.Name] 
                -> Bool 
                -> RefactGhc t
             worker1 dest ds pnn dd toToplevel
                  =do let (_before,decl,_after)=divideDecls ds pnn
                          liftedDecls=definingDeclsNames [n] decl True  True
                          declaredPns=nub $ concatMap definedPNs liftedDecls
                      logm $ "MoveDef.worker1: (dest)=" ++ (SYB.showData SYB.Renamer 0 dest)
                      logm $ "MoveDef.worker1: (ds)=" ++ (showGhc (ds))
                      logm $ "MoveDef.worker1: decl=" ++ (showGhc decl)
                      pns <- pnsNeedRenaming dest decl liftedDecls declaredPns
                      logm $ "MoveDef.worker1: pns=" ++ (showGhc pns)
                      if pns==[]
                        then do
                                (dest',liftedDecls',paramAdded)
                                    
                                    <- addParamsToParentAndLiftedDecl n dd dest liftedDecls 
                                let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls'
                                                                else liftedDecls'
                                
                                logm $ "MoveDef.worker1:dest'=" ++ (SYB.showData SYB.Renamer 0 dest')
                                
                                dest'<-moveDecl1 dest' Nothing
                                           [n] declaredPns toToplevel 
                                return dest'
                                
                                
                        else askRenamingMsg pns "lifting"
liftedToTopLevel :: GHC.Located GHC.Name -> GHC.RenamedSource -> (Bool,[GHC.Name])
liftedToTopLevel pnt@(GHC.L _ pn) renamed
  = if nonEmptyList (definingDeclsNames [pn] (hsBinds renamed) False True)
     then let (_, parent,_) = divideDecls (hsBinds renamed) pnt
              liftedDecls=definingDeclsNames [pn] (hsBinds parent) True True
              declaredPns  = nub $ concatMap definedPNs liftedDecls
          in (True, declaredPns)
     else (False, [])
addParamsToParentAndLiftedDecl :: HsValBinds t =>
  GHC.Name
  -> [GHC.Name] 
  -> t
  -> [GHC.LHsBind GHC.Name]
  -> RefactGhc (t, [GHC.LHsBind GHC.Name], Bool)
addParamsToParentAndLiftedDecl pn dd parent liftedDecls
  =do  let (ef,_) = hsFreeAndDeclaredPNs parent
       let (lf,_) = hsFreeAndDeclaredPNs liftedDecls
       let eff = getFreeVars $ hsBinds parent
       let lff = getFreeVars liftedDecls
       logm $ "addParamsToParentAndLiftedDecl:(eff,lff)=" ++ (showGhc (eff,lff))
       
       let newParams=((nub lff)\\ (nub eff)) \\ dd  
       logm $ "addParamsToParentAndLiftedDecl:(newParams,ef,lf,dd)=" ++ (showGhc (newParams,ef,lf,dd))
       if newParams/=[]
         then if  (any isComplexPatBind liftedDecls)
                then error "This pattern binding cannot be lifted, as it uses some other local bindings!"
                else do parent' <- addParamsToParent pn newParams parent
                        liftedDecls'<-addParamsToDecls liftedDecls pn newParams True 
                        return (parent', liftedDecls',True)
         else return (parent,liftedDecls,False)
demote' ::
     GHC.ModuleName
  
  
  -> GHC.Located GHC.Name
  -> RefactGhc [ApplyRefacResult]
demote' modName (GHC.L _ pn) = do
  renamed <- getRefactRenamed
  if isFunOrPatName pn renamed
    then do
       isTl <- isTopLevelPN pn
       if isTl && isExplicitlyExported pn renamed
          then error "This definition can not be demoted, as it is explicitly exported by the current module!"
          else do 
                  (refactoredMod,_) <- applyRefac (doDemoting pn) RSAlreadyLoaded
                  
                  if isTl && modIsExported modName renamed
                    then do let demotedDecls'= definingDeclsNames [pn] (hsBinds renamed) True False
                                declaredPns  = nub $ concatMap definedPNs demotedDecls'
                            clients <- clientModsAndFiles modName
                            logm $ "demote':clients=" ++ (showGhc clients)
                            refactoredClients <-mapM (demotingInClientMod declaredPns) clients
                            
                            return (refactoredMod:refactoredClients)
                    else do return [refactoredMod]
    else error "\nInvalid cursor position!"
demotingInClientMod ::
  [GHC.Name] -> GHC.ModSummary
  -> RefactGhc ApplyRefacResult
demotingInClientMod pns modSummary = do
  getModuleDetails modSummary
  (refactoredMod,_) <- applyRefac (doDemotingInClientMod pns (GHC.ms_mod modSummary)) RSAlreadyLoaded
  return refactoredMod
doDemotingInClientMod :: [GHC.Name] -> GHC.Module -> RefactGhc ()
doDemotingInClientMod pns modName = do
  renamed@(_g,imps,exps,_docs) <- getRefactRenamed
  
  if any (\pn->findPN pn (hsBinds renamed) || findPN pn (exps)) pns
     then error $ "This definition can not be demoted, as it is used in the client module '"++(showGhc modName)++"'!"
     else if any (\pn->findPN pn imps) pns
             
             then do 
                     return ()
             else return ()
doDemoting :: GHC.Name -> RefactGhc ()
doDemoting  pn = do
  clearRefactDone 
  renamed  <- getRefactRenamed
  logm $ "MoveDef.doDemoting:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) 
  
  renamed' <- everywhereMStaged' SYB.Renamer (SYB.mkM   demoteInMod
                                             `SYB.extM` demoteInMatch
                                             `SYB.extM` demoteInPat
                                             `SYB.extM` demoteInLet
                                             `SYB.extM` demoteInStmt
                                            ) renamed
  
  putRefactRenamed renamed'
  
  
  return ()
    where
       
       
       demoteInMod (renamed :: GHC.RenamedSource)
         | not $ emptyList decls
         = do
              logm "MoveDef:demoteInMod" 
              demoted <- doDemoting' renamed pn
              return demoted
         where
           decls = (definingDeclsNames [pn] (hsBinds renamed) False False)
       demoteInMod x = return x
       
       
       demoteInMatch (match@(GHC.Match _pats _mt rhs)::GHC.Match GHC.Name)
         
         | not $ emptyList (definingDeclsNames [pn] (hsBinds rhs) False False)
         = do
              logm "MoveDef:demoteInMatch" 
              done <- getRefactDone
              match' <- if (not done)
                then doDemoting' match pn
                else return match
              return match'
       demoteInMatch  x = return x
       
       
       demoteInPat (pat@((GHC.PatBind _p rhs _ _ _))::GHC.HsBind GHC.Name)
         
         | not $ emptyList (definingDeclsNames [pn] (hsBinds rhs) False False)
          = do
              logm "MoveDef:demoteInPat" 
              done <- getRefactDone
              pat' <- if (not done)
                then doDemoting' pat pn
                else return pat
              return pat'
       demoteInPat x = return x
       
       
       demoteInLet (letExp@(GHC.HsLet ds _e)::GHC.HsExpr GHC.Name)
         
         | not $ emptyList (definingDeclsNames [pn] (hsBinds ds) False False)
          = do
              logm "MoveDef:demoteInLet" 
              done <- getRefactDone
              letExp' <- if (not done)
                 then doDemoting' letExp pn
                 else return letExp
              return letExp'
       demoteInLet x = return x
       
       
       
       demoteInStmt (letStmt@(GHC.LetStmt binds)::GHC.Stmt GHC.Name)
         
         | not $ emptyList (definingDeclsNames [pn] (hsBinds binds) False False)
          = do
              logm "MoveDef:demoteInStmt" 
              done <- getRefactDone
              letStmt' <- if (not done)
                then doDemoting' letStmt pn
                else return letStmt
              return letStmt'
       demoteInStmt x =return x
       
doDemoting' :: (HsValBinds t, UsedByRhs t) => t -> GHC.Name -> RefactGhc t
doDemoting' t pn
 = let origDecls = hsBinds t
       demotedDecls'= definingDeclsNames [pn] origDecls True False
       declaredPns = nub $ concatMap definedPNs demotedDecls'
   in if not (usedByRhs t declaredPns)
      
       then do
              
              let demotedDecls = definingDeclsNames [pn] (hsBinds t) True True
              
              
              
              let 
                  otherBinds = (deleteFirstsBy sameBind (hsBinds t) demotedDecls)
                  
                      
                  
                  xx = map (\b -> (b,uses declaredPns [b])) otherBinds
                  uselist = concatMap (\(b,r) -> if (emptyList r) then [] else [b]) xx
              logm $ "doDemoting': uses xx=" ++ (showGhc xx)
              logm $ "doDemoting': uses uselist=" ++ (showGhc uselist)
              case length uselist  of
                  0 ->do error "\n Nowhere to demote this function!\n"
                  1 -> 
                      do
                         drawTokenTree "" 
                         logm "MoveDef.doDemoting':target location found" 
                         
                         let (f,_d) = hsFreeAndDeclaredPNs demotedDecls
                         
                         (ds,removedDecl,_sigRemoved) <- rmDecl pn False (hsBinds t)
                         (t',demotedSigs) <- rmTypeSigs declaredPns t
                         let (GHC.L ssd _) = removedDecl
                         demotedToks <- getToksForSpan ssd
                         
                         let getToksForMaybeSig (GHC.L ss _) = do
                                                   sigToks <- getToksForSpan ss
                                                   return sigToks
                         demotedSigToksLists <- mapM getToksForMaybeSig demotedSigs
                         let demotedSigToks = concat demotedSigToksLists
                         
                         logm $ "MoveDef:declaredPns=" ++ (showGhc declaredPns) 
                         logm $ "MoveDef:demotedSigToks=" ++ (show demotedSigToks) 
                         logm $ "MoveDef:sig and decl toks[" ++ (GHC.showRichTokenStream (demotedSigToks ++ demotedToks)) ++ "]" 
                         
                         
                         dl <- mapM (flip declaredNamesInTargetPlace ds) declaredPns
                         logm $ "mapM declaredNamesInTargetPlace done"
                         
                         
                         let clashedNames=filter (\x-> elem (id x) (map id f)) $ (nub.concat) dl
                         
                         if clashedNames/=[]
                            then error ("The identifier(s):" ++ showGhc clashedNames ++
                                       ", declared in where the definition will be demoted to, will cause name clash/capture"
                                       ++" after demoting, please do renaming first!")  
                                 
                            else  
                                 do
                                    logm $ "MoveDef: about to duplicateDecls"
                                    
                                    ds'' <- duplicateDecls declaredPns removedDecl demotedSigs (Just (demotedSigToks ++ demotedToks)) ds
                                    logm $ "MoveDef:duplicateDecls done"
                                    
                                    return (replaceBinds t' ds'')
                  _ ->error "\nThis function/pattern binding is used by more than one friend bindings\n"
                  
                  
       else error "This function can not be demoted as it is used in current level!\n"
       
       
       
    where
          
          
          
          uses pns t
               = concat $ SYB.everythingStaged SYB.Renamer (++) []
                   ([] `SYB.mkQ`  usedInMatch
                       `SYB.extQ` usedInPat) t
                where
                  
                  
                  usedInMatch ((GHC.Match pats _ rhs) :: GHC.Match GHC.Name)
                    
                    | (not $ findPNs pns pats) && findPNs pns rhs
                     = return [1::Int]
                  usedInMatch _ = return []
                  
                  
                  usedInPat ((GHC.PatBind pat rhs _ _ _) :: GHC.HsBind GHC.Name)
                    
                    | (not $ findPNs pns pat) && findPNs pns rhs
                    = return [1::Int]
                  usedInPat  _ = return []
                  
          
          
          duplicateDecls :: [GHC.Name] 
                         -> GHC.LHsBind GHC.Name 
                         -> [GHC.LSig GHC.Name] 
                         -> Maybe [PosToken]          
                         -> [GHC.LHsBind GHC.Name]    
                         -> RefactGhc [GHC.LHsBind GHC.Name]
          
          duplicateDecls pns demoted dsig dtoks decls
             
             = do
                  
                  
                  everywhereMStaged' SYB.Renamer (SYB.mkM dupInMatch 
             
                                                `SYB.extM` dupInPat) decls
             
               where
                 
                 dupInMatch (match@(GHC.Match pats _mt rhs) :: GHC.Match GHC.Name)
                   
                   | (not $ findPNs pns pats) && findPNs pns rhs
                   =  do
                        done <- getRefactDone
                        logm $ "duplicateDecls:value of done=" ++ (show done) 
                        if done
                          then return match
                          else do
                            logm "duplicateDecls:setting done"  
                            setRefactDone
                            
                            
                            
                            
                            
                            match' <- foldParams pns match decls demoted dsig dtoks
                            return match'
                 
                 dupInMatch x = return x
                 
                 dupInPat ((GHC.PatBind pat rhs ty fvs ticks) :: GHC.HsBind GHC.Name)
                    
                    | (not $ findPNs pns pat) && findPNs pns rhs
                   
                   = do
                       
                       
                       
                       rhs' <- moveDecl1 rhs Nothing pns pns False
                       return (GHC.PatBind pat rhs' ty fvs ticks)
                 
                 dupInPat x = return x
                 
          
          
          declaredNamesInTargetPlace :: (SYB.Data t)
                            => GHC.Name -> t
                            
                            -> RefactGhc [GHC.Name]
          declaredNamesInTargetPlace pn t = do
             logm $ "declaredNamesInTargetPlace:pn=" ++ (showGhc pn)
             res <- applyTU (stop_tdTUGhc (failTU
                                           `adhocTU` inMatch
                                           `adhocTU` inPat)) t
             logm $ "declaredNamesInTargetPlace:res=" ++ (showGhc res)
             return res
               where
                 
                 inMatch ((GHC.Match _pats _ rhs) :: GHC.Match GHC.Name)
                    | findPN pn rhs = do
                     logm $ "declaredNamesInTargetPlace:inMatch"
                     let fds = hsFDsFromInside rhs
                     return $ snd fds
                     
                 
                 inMatch _ = return mzero
                 
                 inPat ((GHC.PatBind pat rhs _ _ _) :: GHC.HsBind GHC.Name)
                    |findPN pn rhs = do
                     logm $ "declaredNamesInTargetPlace:inPat"
                     let fds = hsFDsFromInside pat
                     return $ snd fds
                     
                 
                 inPat _=  return mzero
foldParams :: [GHC.Name]             
           -> GHC.Match GHC.Name     
           -> [GHC.LHsBind GHC.Name] 
           -> GHC.LHsBind GHC.Name   
           -> [GHC.LSig GHC.Name]    
           -> Maybe [PosToken]          
           -> RefactGhc (GHC.Match GHC.Name)
foldParams pns ((GHC.Match pats mt rhs)::GHC.Match GHC.Name) _decls demotedDecls dsig dtoks
     =do
         logm $ "MoveDef.foldParams entered"
         
         let matches=concatMap matchesInDecls [GHC.unLoc demotedDecls]
             pn=ghead "foldParams" pns    
         params <- allParams pn rhs []
         if (length.nub.map length) params==1                  
             && ((length matches)==1)      
           then do
                   let patsInDemotedDecls=(patsInMatch.(ghead "foldParams")) matches
                       subst=mkSubst patsInDemotedDecls params
                       fstSubst=map fst subst
                       sndSubst=map snd subst
                   
                   rhs' <- rmParamsInParent pn sndSubst rhs
                   
                   
                   
                   let ls = map hsFreeAndDeclaredPNs sndSubst
                   
                   
                   let newNames=((concatMap fst ls)) \\ (fstSubst)
                   
                   clashedNames<-getClashedNames fstSubst newNames (ghead "foldParams" matches)
                   logm $ "MoveDef.foldParams about to foldInDemotedDecls"
                   
                   
                   demotedDecls''' <- foldInDemotedDecls pns clashedNames subst [demotedDecls]
                   logm $ "MoveDef.foldParams foldInDemotedDecls done"
                   let [(GHC.L declSpan _)] = demotedDecls'''
                   declToks <- getToksForSpan declSpan
                   logm $ "MoveDef.foldParams addDecl adding to (hsBinds):[" ++ (SYB.showData SYB.Renamer 0 $ hsBinds rhs') ++ "]" 
                   rhs'' <- addDecl rhs' Nothing (ghead "foldParams 2" demotedDecls''',[],Just declToks) False
                   logm $ "MoveDef.foldParams addDecl done"
                   return (GHC.Match pats mt rhs'')
           else  do  
                     
                     logm $ "MoveDef.foldParams about to addDecl:dtoks=" ++ (show dtoks)
                     drawTokenTree "" 
                     rhs' <- addDecl rhs Nothing (demotedDecls,dsig,dtoks) False
                     return (GHC.Match pats mt rhs')
         
    where
       
       matchesInDecls (GHC.FunBind _ _ (GHC.MatchGroup matches _) _ _ _) = matches
       matchesInDecls _x = []
       
       
       patsInMatch (GHC.L _ (GHC.Match pats _ _)) = pats
       
       foldInDemotedDecls :: [GHC.Name]  
                          -> [GHC.Name]  
                          -> [(GHC.Name, GHC.HsExpr GHC.Name)] 
                          -> [GHC.LHsBind GHC.Name] 
                          -> RefactGhc [GHC.LHsBind GHC.Name]
       foldInDemotedDecls  pns clashedNames subst decls
          = everywhereMStaged SYB.Renamer (SYB.mkM worker) decls
          where
          
          worker (match@(GHC.FunBind (GHC.L _ pname) _ (GHC.MatchGroup _matches _) _ _ _) :: GHC.HsBind GHC.Name)
            | isJust (find (==pname) pns)
            = do
                 match'  <- foldM (flip (autoRenameLocalVar True)) match clashedNames
                 match'' <- foldM replaceExpWithUpdToks match' subst
                 rmParamsInDemotedDecls (map fst subst) match''
          worker x = return x
      
            
       allParams :: GHC.Name -> GHC.GRHSs GHC.Name -> [[GHC.HsExpr GHC.Name]]
                 -> RefactGhc [[GHC.HsExpr GHC.Name]]
       allParams pn rhs initial  
        =do 
            let p = getOneParam pn rhs
            
            if (nonEmptyList p) then do rhs' <- rmOneParam pn rhs
                                        
                                        
                                        allParams pn rhs' (initial++[p])
                     else return initial
        where
           getOneParam :: (SYB.Data t) => GHC.Name -> t -> [GHC.HsExpr GHC.Name]
           getOneParam pn
              = SYB.everythingStaged SYB.Renamer (++) []
                   ([] `SYB.mkQ`  worker)
              
                where
                  worker :: GHC.HsExpr GHC.Name -> [GHC.HsExpr GHC.Name]
                  worker (GHC.HsApp e1 e2)
                   |(expToName e1==pn) = [GHC.unLoc e2]
                  worker _ = []
           rmOneParam :: (SYB.Data t) => GHC.Name -> t -> RefactGhc t
           rmOneParam pn t
              
              
             = do
                
                everywhereMStaged' SYB.Renamer (SYB.mkM worker) t
                where
                  
                  worker (GHC.HsApp e1 _e2 ) 
                    |expToName e1==pn = return (GHC.unLoc e1)
                  worker x = return x
       
       rmParamsInDemotedDecls :: [GHC.Name] -> GHC.HsBind GHC.Name
                              -> RefactGhc (GHC.HsBind GHC.Name)
       rmParamsInDemotedDecls ps bind
         
         
         = everywhereMStaged SYB.Renamer (SYB.mkM worker) bind
            
            where worker (GHC.Match pats typ rhs)
                    = do
                         let pats'=filter (\x->not ((patToPNT x /= Nothing) &&
                                          elem (fromJust $ patToPNT x) ps)) pats
                         let (startPos,endPos) = getBiggestStartEndLoc pats
                         
                         
                         if (emptyList pats')
                           then removeToksForPos (startPos,endPos)
                           else 
                                updateToksWithPos (startPos,endPos) pats' pprPat False
                         
                         
                         
                         
                         
                         return (GHC.Match pats' typ rhs)
       pprPat pat = intercalate " " $ map (\p -> (prettyprint p )) pat
       
       
       rmParamsInParent :: GHC.Name -> [GHC.HsExpr GHC.Name] -> GHC.GRHSs GHC.Name 
                        -> RefactGhc (GHC.GRHSs GHC.Name)
       rmParamsInParent pn es
         
         = everywhereMStaged SYB.Renamer (SYB.mkM worker)
            where worker exp@(GHC.L _ (GHC.HsApp e1 e2))
                   
                   | findPN pn e1 && (elem (showGhc (GHC.unLoc e2)) (map (showGhc) es))
                      = update exp e1 exp
                  worker (exp@(GHC.L _ (GHC.HsPar e1)))
                    |pn==expToName e1
                       = update exp e1 exp
                  worker x =return x
       getClashedNames oldNames newNames match
         = do  let (_f,d) = hsFDsFromInside match
               
               let ds' = map (flip hsVisiblePNs match) oldNames
               
               return (filter (\x->elem ( x) newNames)  
                                   ( nub (d `union` (nub.concat) ds')))
       
       
       mkSubst :: [GHC.LPat GHC.Name] -> [[GHC.HsExpr GHC.Name]] -> [(GHC.Name,GHC.HsExpr GHC.Name)]
       mkSubst pats params
           = catMaybes (zipWith (\x y -> if (patToPNT x/=Nothing) && (length (nub $ map showGhc y)==1)
                                          then Just (fromJust $ patToPNT x,(ghead "mkSubst") y)
                                          else Nothing) pats params)
           
replaceExpWithUpdToks :: (SYB.Data t)
                      => t -> (GHC.Name, GHC.HsExpr GHC.Name)
                      -> RefactGhc t
replaceExpWithUpdToks  decls subst
  
  = everywhereMStaged' SYB.Renamer (SYB.mkM worker) decls
         where worker (e@(GHC.L l _)::GHC.LHsExpr GHC.Name)
                 |(expToName e/=defaultName) &&  (expToName e)==(fst subst)
                     = update e (GHC.L l (snd subst)) e
               worker x=return x
isLocalFunOrPatName :: SYB.Data t => GHC.Name -> t -> Bool
isLocalFunOrPatName pn scope
 = isLocalPN pn && isFunOrPatName pn scope
divideDecls ::
  SYB.Data a =>
  [a] -> GHC.Located GHC.Name -> ([a], [a], [a])
divideDecls ds pnt
  
  = let (before,after)=break (\x->findPNT pnt x) ds
    in if (not $ emptyList after)
         then (before, [ghead "divideDecls" after], tail after)
         else (ds,[],[])