{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} module Language.Haskell.Refact.Refactoring.MoveDef ( liftToTopLevel , compLiftToTopLevel , liftOneLevel , compLiftOneLevel , demote , compDemote -- ,liftingInClientMod ) where import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB import qualified Data.Generics.Zipper as Z import qualified Exception as GHC import qualified GHC as GHC import qualified Name as GHC import qualified RdrName as GHC import Control.Exception import Control.Monad.State import Data.Foldable import Data.List import Data.Maybe import qualified Language.Haskell.GhcMod as GM import Language.Haskell.Refact.API import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint import Data.Generics.Strafunski.StrategyLib.StrategyLib import System.Directory -- import Debug.Trace -- --------------------------------------------------------------------- -- data Direction = UptoTopLevel | UpOneLevel | Down {--------This function handles refactorings involving moving a definition-------- According to the Haskell's syntax, a declaration may occur in one of the following six contexts: 1. A top level declaration in the module: old: HsModule SrcLoc ModuleName (Maybe [HsExportSpecI i]) [HsImportDeclI i] ds new: (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], Maybe LHsDocString) HsGroup hs_valds :: HsValBinds id ... 2. A local declaration in a Match: (of a FunBind) old: HsMatch SrcLoc i [p] (HsRhs e) ds new: Match [LPat id] (Maybe (LHsType id)) (GRHSs id) 3. A local declaration in a pattern binding: old: HsPatBind SrcLoc p (HsRhs e) ds new: PatBind (LPat idL) (GRHSs idR) PostTcType NameSet (Maybe tickish) 4. A local declaration in a Let expression: old: HsLet ds e new: HsLet (HsLocalBinds id) (LHsExpr id) 5. A local declaration in a Case alternative: old: HsAlt SrcLoc p (HsRhs e) ds new: HsCase (LHsExpr id) (MatchGroup id) new is same as in a FunBind. 6. A local declaration in a Do statement: old: HsLetStmt ds (HsStmt e p ds) new: LetStmt (HsLocalBindsLR idL idR) in context GRHS [LStmt id] (LHsExpr id) -} -- | Lift a definition to the top level liftToTopLevel :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath] liftToTopLevel settings opts fileName (row,col) = do absFileName <- canonicalizePath fileName runRefacSession settings opts (compLiftToTopLevel absFileName (row,col)) compLiftToTopLevel :: FilePath -> SimpPos -> RefactGhc [ApplyRefacResult] compLiftToTopLevel fileName (row,col) = do parseSourceFileGhc fileName parsed <- getRefactParsed nm <- getRefactNameMap let (Just (modName,_)) = getModuleName parsed let maybePn = locToRdrName (row, col) parsed case maybePn of Just ln@(GHC.L l _) -> liftToTopLevel' modName (GHC.L l (rdrName2NamePure nm ln)) _ -> error "\nInvalid cursor position!\n" {- Refactoring Names: 'liftToTopLevel' This refactoring lifts a local function/pattern binding to the top level of the module, so as to make it accessible to other functions in the current module, and those modules that import current module. In the current implementation, a definition will be lifted only if none of the identifiers defined in this definition will cause name clash/capture problems in the current module after lifting. In the case that the whole current module is exported implicitly, the lifted identifier will be exported automatically after lifting. If the identifier will cause name clash/ambiguous occurrence problem in a client module, it will be hided in the import declaration of the client module (Note: this might not be the best solution, we prefer hiding it in the server module instead of in the client module in the final version). In the case of indirect importing, it might be time-consuming to trace whether the lifted identifier will cause any problem in a client module that indirectly imports the current module. The current solution is: suppose a defintion is lifted to top level in module A, and module A is imported and exported by module B, then the lifted identifier will be hided in the import declaration of B no matter whether it causes problems in module B or not. Function name: liftToTopLevel parameters: fileName--current file name. mod -- the scoped abstract syntax tree of the module. pn -- the function/pattern name to be lifted. -} liftToTopLevel' :: GHC.ModuleName -- -> (ParseResult,[PosToken]) -> FilePath -> GHC.Located GHC.Name -> RefactGhc [ApplyRefacResult] liftToTopLevel' modName pn@(GHC.L _ n) = do renamed <- getRefactRenamed parsed <- getRefactParsed nm <- getRefactNameMap targetModule <- getRefactTargetModule logm $ "liftToTopLevel':pn=" ++ (showGhc pn) if isLocalFunOrPatName nm n parsed then do (refactoredMod,declPns) <- applyRefac liftToMod RSAlreadyLoaded logm $ "liftToTopLevel' applyRefac done " if modIsExported modName renamed then do clients <- clientModsAndFiles targetModule 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 {-step1: divide the module's top level declaration list into three parts: 'parent' is the top level declaration containing the lifted declaration, 'before' and `after` are those declarations before and after 'parent'. step2: get the declarations to be lifted from parent, bind it to liftedDecls step3: remove the lifted declarations from parent and extra arguments may be introduced. step4. test whether there are any names need to be renamed. -} liftToMod = do parsed' <- getRefactParsed parsed <- liftT $ balanceAllComments parsed' nm <- getRefactNameMap logDataWithAnns "parsed after balanceAllComments" parsed declsp <- liftT $ hsDecls parsed (before,parent,after) <- divideDecls declsp pn {- ++AZ++TODO: reinstate this, hsDecls does : hsBinds does not return class or instance definitions when (isClassDecl $ ghead "liftToMod" parent) $ error "Sorry, the refactorer cannot lift a definition from a class declaration!" when (isInstDecl $ ghead "liftToMod" parent) $ error "Sorry, the refactorer cannot lift a definition from an instance declaration!" -} nameMap <- getRefactNameMap -- declsParent <- liftT $ hsDecls (ghead "liftToMod" parent) -- logm $ "liftToMod:(declsParent)=" ++ (showGhc declsParent) let liftedDecls = definingDeclsRdrNames nameMap [n] parent True True declaredPns = nub $ concatMap (definedNamesRdr nameMap) liftedDecls liftedSigs = definingSigsRdrNames nameMap declaredPns parent mLiftedSigs = liftedSigs -- TODO: what about declarations between this -- one and the top level that are used in this one? pns <- pnsNeedRenaming parsed parent liftedDecls declaredPns logm $ "liftToMod:(pns needing renaming)=" ++ (showGhc pns) decls <- liftT $ hsDecls parsed' let dd = getDeclaredVarsRdr nm decls logm $ "liftToMod:(ddd)=" ++ (showGhc dd) if pns == [] then do (parent',liftedDecls',mLiftedSigs') <- addParamsToParentAndLiftedDecl n dd parent liftedDecls mLiftedSigs let defName = (ghead "liftToMod" (definedNamesRdr nameMap (ghead "liftToMod2" parent'))) parsed1 <- liftT $ replaceDecls parsed (before++parent'++after) parsed2 <- moveDecl1 parsed1 (Just defName) [GHC.unLoc pn] liftedDecls' declaredPns mLiftedSigs' putRefactParsed parsed2 emptyAnns return declaredPns else askRenamingMsg pns "lifting" -- --------------------------------------------------------------------- -- | Move a definition one level up from where it is now liftOneLevel :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath] liftOneLevel settings opts fileName (row,col) = do absFileName <- canonicalizePath fileName runRefacSession settings opts (compLiftOneLevel absFileName (row,col)) compLiftOneLevel :: FilePath -> SimpPos -> RefactGhc [ApplyRefacResult] compLiftOneLevel fileName (row,col) = do parseSourceFileGhc fileName parsed <- getRefactParsed nm <- getRefactNameMap let (Just (modName,_)) = getModuleName parsed let maybePn = locToRdrName (row, col) parsed case maybePn of Just ln@(GHC.L l _) -> do rs <- liftOneLevel' modName (GHC.L l (rdrName2NamePure nm ln)) 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" {- Refactoring Names: 'liftOneLevel' Description: this refactoring lifts a local function/pattern binding only one level up. By 'lifting one-level up' , I mean: case1: In a module (HsModule SrcLoc ModuleName (Maybe [HsExportSpecI i]) [HsImportDeclI i] ds): A local declaration D will be lifted to the same level as the 'ds', if D is in the where clause of one of ds's element declaration. new: (HsModule mmn mexp imps ds mdepr _haddock) In pactice this means processing a. Matches in a FunBind (Match mln pats _typ (GRHSs grhs ds)) b. A PatBind (PatBind lhs (GRHSs grhs ds) _typ _fvs _ticks) and lifting a decl D from ds to the top. VarBinds and AbsBinds are introduced by the type checker, so can be ignored here. A PatSynBind does not have decls in it, so is ignored. case2: In a match ( HsMatch SrcLoc i [p] (HsRhs e) ds) : A local declaration D will be lifted to the same level as the 'ds', if D is in the where clause of one of ds's element declaration. A declaration D,say,in the rhs expression 'e' will be lifted to 'ds' if D is Not local to other declaration list in 'e' (in a FunBind) new: (Match mln pats _typ (GRHSs grhs lb)) case3: In a pattern binding (HsPatBind SrcLoc p (HsRhs e) ds): A local declaration D will be lifted to the same level as the 'ds', if D is in the where clause of one of ds's element declaration. A declaration D,say,in the rhs expression 'e' will be lifted to 'ds' if D is Not local to other declaration list in 'e' new: (PatBind lhs (GRHSs grhs ds) _typ _fvs _ticks) case4: In the Let expression (Exp (HsLet ds e): A local declaration D will be lifted to the same level as the 'ds', if D is in the where clause of one of ds's element declaration. A declaration D, say, in the expression 'e' will be lifted to 'ds' if D is not local to other declaration list in 'e' new: HsLet ds e case5: In the case Alternative expression:(HsAlt loc p rhs ds) A local declaration D will be lifted to the same level as the 'ds', if D is in the where clause of one of ds's element declaration. A declaration D in 'rhs' will be lifted to 'ds' if D is not local to other declaration list in 'rhs'. new: HsCase (LHsExpr id) (MatchGroup id) new is same as in a FunBind. case6: In the do statement expression:(HsLetStmt ds stmts) A local declaration D will be lifted to the same level as the 'ds', if D is in the where clause of one of ds's element declaration. A declaration D in 'stmts' will be lifted to 'ds' if D is not local to other declaration list in 'stmts'. new: LetStmt (HsLocalBindsLR idL idR) in context GRHS [LStmt id] (LHsExpr id) Function name: liftOneLevel parameters: fileName--current file name. mod -- the scoped abstract syntax tree of the module. pn -- the function/pattern name to be lifted. -} liftOneLevel' :: GHC.ModuleName -> GHC.Located GHC.Name -> RefactGhc [ApplyRefacResult] liftOneLevel' modName pn@(GHC.L _ n) = do renamed <- getRefactRenamed parsed <- getRefactParsed nm <- getRefactNameMap targetModule <- getRefactTargetModule if isLocalFunOrPatName nm n parsed then do (refactoredMod,(b,pns)) <- applyRefac doLiftOneLevel RSAlreadyLoaded logm $ "liftOneLevel':main refactoring done:(p,pns)=" ++ showGhc (b,pns) if b && modIsExported modName renamed then do logm $ "liftOneLevel':looking for clients" clients <- clientModsAndFiles targetModule logm $ "liftOneLevel':(clients,pns)=" ++ (showGhc (clients,pns)) 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 doLiftOneLevel = do logm $ "in doLiftOneLevel" parsed <- getRefactParsed logDataWithAnns "doLiftOneLevel:parsed" parsed nm <- getRefactNameMap ans <- liftT getAnnsT zp <- ztransformStagedM SYB.Parser (Nothing `SYB.mkQ` (liftToModQ nm ans) `SYB.extQ` (liftToMatchQ nm ans) `SYB.extQ` (liftToLetQ nm ans) ) (Z.toZipper parsed) let parsed' = Z.fromZipper zp putRefactParsed parsed' emptyAnns liftedToTopLevel pn parsed' where isMatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Bool isMatch _ = True isHsLet :: GHC.LHsExpr GHC.RdrName -> Bool isHsLet (GHC.L _ (GHC.HsLet _ _)) = True isHsLet _ = False -- ------------------------ liftToModQ :: NameMap -> Anns -> GHC.ParsedSource -> Maybe (SYB.Stage -> Z.Zipper GHC.ParsedSource -> RefactGhc (Z.Zipper GHC.ParsedSource)) liftToModQ nm ans (p :: GHC.ParsedSource) | nonEmptyList candidateBinds = Just (doLiftZ p declsp) | otherwise = Nothing where (declsp ,_,_) = runTransform ans (hsDecls p) doOne bs = (definingDeclsRdrNames nm [n] declsbs False False,bs) where (declsbs,_,_) = runTransform ans (hsDeclsGeneric bs) candidateBinds = map snd $ filter (\(l,_bs) -> nonEmptyList l) $ map doOne $ declsp getHsDecls ans t = decls where (decls,_,_) = runTransform ans (hsDeclsGeneric t) -- ------------------------ liftToMatchQ :: (SYB.Data a) => NameMap -> Anns -> GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a)) liftToMatchQ nm ans (m@(GHC.L _ (GHC.Match _ _pats _mtyp (GHC.GRHSs _rhs ds)))::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) | (nonEmptyList (definingDeclsRdrNames nm [n] (getHsDecls ans ds) False False)) = Just (doLiftZ m (getHsDecls ans ds)) | otherwise = Nothing -- ------------------------ liftToLetQ :: SYB.Data a => NameMap -> Anns -> GHC.LHsExpr GHC.RdrName -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a)) liftToLetQ nm ans ll@(GHC.L _ (GHC.HsLet ds _e)) | nonEmptyList (definingDeclsRdrNames nm [n] (getHsDecls ans ds) False False) = Just (doLiftZ ll (getHsDecls ans ll)) | otherwise = Nothing liftToLetQ _ _ _ = Nothing -- ------------------------ doLiftZ :: (SYB.Data t,SYB.Data a) => t -- ^Item containing the decls which contain the ones to be lifted -> [GHC.LHsDecl GHC.RdrName] -- ^decls containing the ones to be lifted. -- ++AZ++:TODO: these are redundant, can be pulled out of t -> SYB.Stage -- ++AZ++:TODO: get rid of this -> Z.Zipper a -> RefactGhc (Z.Zipper a) doLiftZ ds decls _stage z = do logm $ "doLiftZ entered" logDataWithAnns "doLiftZ:ds" ds logDataWithAnns "doLiftZ:decls" decls let zu = case (Z.up z) of Just zz -> fromMaybe (error $ "MoveDef.liftToLet.1" ++ SYB.showData SYB.Parser 0 decls) $ upUntil (False `SYB.mkQ` isMatch `SYB.extQ` isHsLet ) zz Nothing -> z let wtop (ren::GHC.ParsedSource) = do logm $ "wtop entered" nm <- getRefactNameMap let (_,DN dd) = (hsFreeAndDeclaredRdr nm ren) -- ++AZ++ : TODO: get rid of worker in favour of -- workerTop worker ren decls pn dd -- workerTop ren decls dd wmatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) wmatch (m@(GHC.L _ (GHC.Match _mln _pats _typ grhss))) = do logm $ "wmatch entered:" ++ SYB.showData SYB.Parser 0 m nm <- getRefactNameMap let (_,DN dd) = hsFreeAndDeclaredRdr nm grhss decls' <- liftT $ hsDecls m workerTop m decls' dd wlet :: GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName) wlet l@(GHC.L _ (GHC.HsLet dsl _e)) = do logm $ "wlet entered " nm <- getRefactNameMap let (_,DN dd) = hsFreeAndDeclaredRdr nm dsl dsl' <- workerTop l decls dd return dsl' wlet x = return x ds' <- Z.transM ( SYB.mkM wtop `SYB.extM` wmatch `SYB.extM` wlet ) zu return ds' -- ---------------------------------------- -- This is currently used for everything but the top level workerTop :: (HasDecls t) => t -- ^The destination of the lift operation -> [GHC.LHsDecl GHC.RdrName] -- ^ list containing the decl to be -- lifted -> [GHC.Name] -- ^Declared variables in the destination -> RefactGhc t workerTop dest ds dd =do logm $ "MoveDef.worker: dest" ++ SYB.showData SYB.Parser 0 dest logm $ "MoveDef.workerTop: ds=" ++ (showGhc ds) done <- getRefactDone if done then return dest else do setRefactDone let parent = dest nm <- getRefactNameMap let liftedDecls = definingDeclsRdrNames' nm [n] parent declaredPns = nub $ concatMap (definedNamesRdr nm) liftedDecls logm $ "MoveDef.workerTop: n=" ++ (showGhc n) logm $ "MoveDef.workerTop: liftedDecls=" ++ (showGhc liftedDecls) pns <- pnsNeedRenaming dest parent liftedDecls declaredPns logm $ "MoveDef.workerTop: pns=" ++ (showGhc pns) if pns==[] then do (parent',liftedDecls',mLiftedSigs')<-addParamsToParentAndLiftedDecl n dd parent liftedDecls [] logm $ "MoveDef.workerTop: liftedDecls'=" ++ (showGhc liftedDecls') --True means the new decl will be at the same level with its parant. let toMove = parent' pdecls <- liftT $ hsDecls toMove -- logm $ "MoveDef.workerTop:toMove=" ++ SYB.showData SYB.Parser 0 toMove -- logm $ "MoveDef.workerTop:pdecls=" ++ (showGhc pdecls) let mAfter = case pdecls of [] -> Nothing _ -> (Just (ghead "worker" (definedNamesRdr nm (glast "workerTop" ds)))) dest' <- moveDecl1 toMove mAfter [n] liftedDecls' declaredPns mLiftedSigs' return dest' else askRenamingMsg pns "lifting" -- ---------------------------------------- -- TODO: get rid of this in favour of workerTop worker :: (HasDecls t) => t -- ^The destination of the lift operation -> [GHC.LHsDecl GHC.RdrName] -- ^ list containing the decl to be -- lifted -> GHC.Located GHC.Name -- ^ The name of the decl to be lifted -> [GHC.Name] -- ^Declared variables in the destination -> RefactGhc t worker dest ds pnn dd =do -- logm $ "MoveDef.worker: dest" ++ (showGhc dest) logm $ "MoveDef.worker: ds=" ++ (showGhc ds) done <- getRefactDone if done then return dest else do setRefactDone (before,parent,after) <- divideDecls ds pnn -- parent is misnomer, it is the decl to be moved logm $ "MoveDef.worker:(before,parent,after)" ++ showGhc (before,parent,after) nm <- getRefactNameMap let liftedDecls = definingDeclsRdrNames nm [n] parent True True declaredPns = nub $ concatMap (definedNamesRdr nm) liftedDecls pns <- pnsNeedRenaming dest parent liftedDecls declaredPns logm $ "MoveDef.worker: pns=" ++ (showGhc pns) if pns==[] then do (parent',liftedDecls',mLiftedSigs')<-addParamsToParentAndLiftedDecl n dd parent liftedDecls [] --True means the new decl will be at the same level with its parant. toMove <- liftT $ replaceDecls dest (before++parent'++after) dest' <- moveDecl1 toMove (Just (ghead "worker" (definedNamesRdr nm (ghead "worker" parent')))) [n] liftedDecls' declaredPns mLiftedSigs' return dest' else askRenamingMsg pns "lifting" -- --------------------------------------------------------------------- -- | Move a definition one level down demote :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath] demote settings opts fileName (row,col) = do absFileName <- canonicalizePath fileName runRefacSession settings opts (compDemote absFileName (row,col)) compDemote ::FilePath -> SimpPos -> RefactGhc [ApplyRefacResult] compDemote fileName (row,col) = do parseSourceFileGhc fileName parsed <- getRefactParsed nm <- getRefactNameMap -- TODO: make the next one an API call, that also gets the -- parsed source let (Just (modName,_)) = getModuleName parsed let maybePn = locToRdrName (row, col) parsed case maybePn of Just pn@(GHC.L l _) -> demote' modName (GHC.L l (rdrName2NamePure nm pn)) _ -> error "\nInvalid cursor position!\n" -- --------------------------------------------------------------------- moveDecl1 :: (SYB.Data t) => t -- ^ The syntax element to update -> Maybe GHC.Name -- ^ If specified, add defn after this one -> [GHC.Name] -- ^ The first one is the decl to move -> [GHC.LHsDecl GHC.RdrName] -> [GHC.Name] -- ^ The signatures to remove. May be multiple if -- decl being moved has a patbind. -> [GHC.LSig GHC.RdrName] -- ^ lifted decls signature if present -> RefactGhc t -- ^ The updated syntax element (and tokens in monad) moveDecl1 t defName ns mliftedDecls sigNames mliftedSigs = do logm $ "moveDecl1:(defName,ns,sigNames,mliftedDecls)=" ++ showGhc (defName,ns,sigNames,mliftedDecls) -- logm $ "moveDecl1:(t)=" ++ SYB.showData SYB.Parser 0 (t) -- TODO: rmDecl can now remove the sig at the same time. (t'',_sigsRemoved) <- rmTypeSigs sigNames t -- logm $ "moveDecl1:after rmTypeSigs:t''" ++ SYB.showData SYB.Parser 0 t'' logm $ "moveDecl1:mliftedSigs=" ++ showGhc mliftedSigs (t',_declRemoved,_sigRemoved) <- rmDecl (ghead "moveDecl3.1" ns) False t'' -- logm $ "moveDecl1:after rmDecl:t'" ++ SYB.showData SYB.Parser 0 t' let sigs = map wrapSig mliftedSigs r <- addDecl t' defName (sigs++mliftedDecls,Nothing) return r -- --------------------------------------------------------------------- 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) -- |Get the subset of 'pns' that need to be renamed before lifting. pnsNeedRenaming :: (SYB.Data t1,SYB.Data t2) => t1 -> t2 -> t3 -> [GHC.Name] -> RefactGhc [GHC.Name] pnsNeedRenaming dest parent _liftedDecls pns = do logm $ "MoveDef.pnsNeedRenaming entered:pns=" ++ showGhc pns r <- mapM pnsNeedRenaming' pns return (concat r) where pnsNeedRenaming' pn = do logm $ "MoveDef.pnsNeedRenaming' entered" nm <- getRefactNameMap let (FN f,DN d) = hsFDsFromInsideRdr nm dest --f: free variable names that may be shadowed by pn --d: declaread variables names that may clash with pn logm $ "MoveDef.pnsNeedRenaming':(f,d)=" ++ showGhc (f,d) DN vs <- hsVisibleDsRdr nm pn parent --vs: declarad variables that may shadow pn logm $ "MoveDef.pnsNeedRenaming':vs=" ++ showGhc vs let vars = map pNtoName (nub (f `union` d `union` vs) \\ [pn]) -- `union` inscpNames 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 if elem (pNtoName pn) vars || isInScope && findNameInRdr nm pn dest then return [pn] else return [] pNtoName = showGhc -- --------------------------------------------------------------------- addParamsToParent :: (SYB.Data t) => GHC.Name -> [GHC.RdrName] -> t -> RefactGhc t addParamsToParent _pn [] t = return t addParamsToParent pn params t = do logm $ "addParamsToParent:(pn,params)" ++ (showGhc (pn,params)) nm <- getRefactNameMap applyTP (full_buTP (idTP `adhocTP` (inExp nm))) t where #if __GLASGOW_HASKELL__ <= 710 inExp nm (e@(GHC.L l (GHC.HsVar n)) :: GHC.LHsExpr GHC.RdrName) = do #else inExp nm (e@(GHC.L l (GHC.HsVar (GHC.L _ n))) :: GHC.LHsExpr GHC.RdrName) = do #endif let ne = rdrName2NamePure nm (GHC.L l n) if GHC.nameUnique ne == GHC.nameUnique pn then addActualParamsToRhs pn params e else return e inExp _ e = return e -- addActualParamsToRhs pn params t -- |Do refactoring in the client module. that is to hide the identifer -- in the import declaration if it will cause any problem in the -- client module. liftingInClientMod :: GHC.ModuleName -> [GHC.Name] -> TargetModule -> RefactGhc [ApplyRefacResult] liftingInClientMod serverModName pns targetModule = do logm $ "liftingInClientMod:targetModule=" ++ (show targetModule) getTargetGhc targetModule parsed <- getRefactParsed clientModule <- getRefactModule logm $ "liftingInClientMod:clientModule=" ++ (showGhc clientModule) modNames <- willBeUnQualImportedBy serverModName logm $ "liftingInClientMod:modNames=" ++ (showGhc modNames) if isJust modNames then do pns' <- namesNeedToBeHided clientModule (gfromJust "liftingInClientMod" modNames) pns let pnsRdr' = map GHC.nameRdrName pns' logm $ "liftingInClientMod:pns'=" ++ (showGhc pns') if (nonEmptyList pns') then do (refactoredMod,_) <- applyRefac (addHiding serverModName parsed pnsRdr') RSAlreadyLoaded return [refactoredMod] else return [] else return [] -- --------------------------------------------------------------------- -- |Test whether an identifier defined in the modules specified by -- 'names' will be exported by current module. 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)) (gfromJust "willBeExportedByClientMod" exps))) names where simpModule (GHC.L _ (GHC.IEModuleContents (GHC.L _ m))) = Just m simpModule _ = Nothing -- |get the module name or alias name by which the lifted identifier -- will be imported automatically. -- TODO: maybe move this into TypeUtils -- willBeUnQualImportedBy::HsName.ModuleName->HsModuleP->Maybe [HsName.ModuleName] 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 -- --------------------------------------------------------------------- -- |get the subset of 'pns', which need to be hided in the import -- declaration in module 'mod' -- Note: these are newly exported from the module, so we cannot use -- the GHC name resolution in this case. 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 -- | Strip the package prefix from the name and return the -- stripped name together with any names in the local module that -- may match the stripped one 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:(hsBinds renamed)=" ++ (showGhc (hsBinds renamed)) logm $ "needToBeHided:(pn,uwoq)=" ++ (showGhc (pn,uwoq)) if (any (== True) uwoq --the same name is used in the module unqualifiedly or --is exported unqualifiedly by an Ent decl -- TODO: ++AZ++ check if next line needs to be reinstated -- was || any (\m -> causeNameClashInExports oldPN pn m renamed) modNames) || False) then return [pn] else return [] -- **************************************************************************************************************-- -- --------------------------------------------------------------------- -- |When liftOneLevel is complete, identify whether any new declarations have -- been put at the top level liftedToTopLevel :: GHC.Located GHC.Name -> GHC.ParsedSource -> RefactGhc (Bool,[GHC.Name]) liftedToTopLevel (GHC.L _ pn) parsed = do logm $ "liftedToTopLevel entered:pn=" ++ showGhc pn nm <- getRefactNameMap decls <- liftT $ hsDecls parsed let topDecs = definingDeclsRdrNames nm [pn] decls False False -- ++AZ++ :TODO: we are not updating the nameMap to reflect moved decls if nonEmptyList topDecs then do let liftedDecls = definingDeclsRdrNames nm [pn] topDecs False False declaredPns = nub $ concatMap (definedNamesRdr nm) liftedDecls return (True, declaredPns) else return (False, []) -- --------------------------------------------------------------------- addParamsToParentAndLiftedDecl :: (SYB.Data t) => GHC.Name -- ^name of decl being lifted -> [GHC.Name] -- ^Declared names in parent -> t -- ^parent -> [GHC.LHsDecl GHC.RdrName] -- ^ decls being lifted -> [GHC.LSig GHC.RdrName] -- ^ lifted decls signature if present -> RefactGhc (t, [GHC.LHsDecl GHC.RdrName], [GHC.LSig GHC.RdrName]) addParamsToParentAndLiftedDecl pn dd parent liftedDecls mLiftedSigs =do logm $ "addParamsToParentAndLiftedDecl:liftedDecls=" ++ (showGhc liftedDecls) nm <- getRefactNameMap let (FN ef,_) = hsFreeAndDeclaredRdr nm parent let (FN lf,_) = hsFreeAndDeclaredRdr nm liftedDecls logm $ "addParamsToParentAndLiftedDecl:(ef,lf)=" ++ showGhc (ef,lf) -- parameters to be added to pn because of lifting let newParamsNames = ((nub lf) \\ (nub ef)) \\ dd newParams = map GHC.nameRdrName newParamsNames logm $ "addParamsToParentAndLiftedDecl:(newParams,ef,lf,dd)=" ++ (showGhc (newParams,ef,lf,dd)) if newParams /= [] then if (any isComplexPatDecl liftedDecls) then error "This pattern binding cannot be lifted, as it uses some other local bindings!" else do -- first remove the decls to be lifted, so they are not disturbed (parent'',liftedDecls'',_msig) <- rmDecl pn False parent parent' <- addParamsToParent pn newParams parent'' liftedDecls' <- addParamsToDecls [liftedDecls''] pn newParams mLiftedSigs' <- mapM (addParamsToSigs newParamsNames) mLiftedSigs logm $ "addParamsToParentAndLiftedDecl:mLiftedSigs'=" ++ showGhc mLiftedSigs' return (parent',liftedDecls', mLiftedSigs') else return (parent,liftedDecls,mLiftedSigs) -- --------------------------------------------------------------------- {- -- TODO: perhaps move this to TypeUtils addParamsToSigs :: [GHC.Name] -> GHC.LSig GHC.RdrName -> RefactGhc (GHC.LSig GHC.RdrName) addParamsToSigs [] ms = return ms addParamsToSigs newParams (GHC.L l (GHC.TypeSig lns ltyp pns)) = do mts <- mapM getTypeForName newParams let ts = catMaybes mts logm $ "addParamsToSigs:ts=" ++ showGhc ts logDataWithAnns "addParamsToSigs:ts=" ts let newStr = ":: " ++ (intercalate " -> " $ map printSigComponent ts) ++ " -> " logm $ "addParamsToSigs:newStr=[" ++ newStr ++ "]" typ' <- liftT $ foldlM addOneType ltyp (reverse ts) sigOk <- isNewSignatureOk ts logm $ "addParamsToSigs:(sigOk,newStr)=" ++ show (sigOk,newStr) if sigOk then return (GHC.L l (GHC.TypeSig lns typ' pns)) else error $ "\nNew type signature may fail type checking: " ++ newStr ++ "\n" where addOneType :: GHC.LHsType GHC.RdrName -> GHC.Type -> Transform (GHC.LHsType GHC.RdrName) addOneType et t = do hst <- typeToLHsType t ss1 <- uniqueSrcSpanT hst1 <- case t of (GHC.FunTy _ _) -> do ss <- uniqueSrcSpanT let t1 = GHC.L ss (GHC.HsParTy hst) setEntryDPT hst (DP (0,0)) addSimpleAnnT t1 (DP (0,0)) [((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))] return t1 _ -> return hst let typ = GHC.L ss1 (GHC.HsFunTy hst1 et) addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnRarrow),DP (0,1))] return typ addParamsToSigs np ls = error $ "addParamsToSigs: no match for:" ++ showGhc (np,ls) -- --------------------------------------------------------------------- printSigComponent :: GHC.Type -> String printSigComponent x = ppType x -- --------------------------------------------------------------------- -- |Fail any signature having a forall in it. -- TODO: this is unnecesarily restrictive, but needs -- a) proper reversing of GHC.Type to GHC.LhsType -- b) some serious reverse type inference to ensure that the -- constraints are modified properly to merge the old signature -- part and the new. isNewSignatureOk :: [GHC.Type] -> RefactGhc Bool isNewSignatureOk types = do -- NOTE: under some circumstances enabling Rank2Types or RankNTypes -- can resolve the type conflict, this can potentially be checked -- for. -- NOTE2: perhaps proceed and reload the tentative refactoring into -- the GHC session and accept it only if it type checks let r = SYB.everythingStaged SYB.TypeChecker (++) [] ([] `SYB.mkQ` usesForAll) types usesForAll (GHC.ForAllTy _ _) = [1::Int] usesForAll _ = [] return $ emptyList r -- --------------------------------------------------------------------- -- TODO: perhaps move this to TypeUtils -- TODO: complete this typeToLHsType :: GHC.Type -> Transform (GHC.LHsType GHC.RdrName) typeToLHsType (GHC.TyVarTy v) = do ss <- uniqueSrcSpanT let typ = GHC.L ss (GHC.HsTyVar (GHC.nameRdrName $ Var.varName v)) addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] return typ typeToLHsType (GHC.AppTy t1 t2) = do t1' <- typeToLHsType t1 t2' <- typeToLHsType t2 ss <- uniqueSrcSpanT return $ GHC.L ss (GHC.HsAppTy t1' t2') typeToLHsType t@(GHC.TyConApp _tc _ts) = tyConAppToHsType t typeToLHsType (GHC.FunTy t1 t2) = do t1' <- typeToLHsType t1 t2' <- typeToLHsType t2 ss <- uniqueSrcSpanT let typ = GHC.L ss (GHC.HsFunTy t1' t2') addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnRarrow),DP (0,1))] return typ typeToLHsType (GHC.ForAllTy _v t) = do t' <- typeToLHsType t ss1 <- uniqueSrcSpanT ss2 <- uniqueSrcSpanT return $ GHC.L ss1 (GHC.HsForAllTy GHC.Explicit Nothing (GHC.HsQTvs [] []) (GHC.L ss2 []) t') typeToLHsType (GHC.LitTy (GHC.NumTyLit i)) = do ss <- uniqueSrcSpanT let typ = GHC.L ss (GHC.HsTyLit (GHC.HsNumTy (show i) i)) :: GHC.LHsType GHC.RdrName addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] return typ typeToLHsType (GHC.LitTy (GHC.StrTyLit s)) = do ss <- uniqueSrcSpanT let typ = GHC.L ss (GHC.HsTyLit (GHC.HsStrTy "" s)) :: GHC.LHsType GHC.RdrName addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] return typ {- data Type = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) | AppTy -- See Note [AppTy invariant] Type Type -- ^ Type application to something other than a 'TyCon'. Parameters: -- -- 1) Function: must /not/ be a 'TyConApp', -- must be another 'AppTy', or 'TyVarTy' -- -- 2) Argument type | TyConApp -- See Note [AppTy invariant] TyCon [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. -- Invariant: saturated appliations of 'FunTyCon' must -- use 'FunTy' and saturated synonyms must use their own -- constructors. However, /unsaturated/ 'FunTyCon's -- do appear as 'TyConApp's. -- Parameters: -- -- 1) Type constructor being applied to. -- -- 2) Type arguments. Might not have enough type arguments -- here to saturate the constructor. -- Even type synonyms are not necessarily saturated; -- for example unsaturated type synonyms -- can appear as the right hand side of a type synonym. | FunTy Type Type -- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@ -- See Note [Equality-constrained types] | ForAllTy Var -- Type or kind variable Type -- ^ A polymorphic type | LitTy TyLit -- ^ Type literals are simillar to type constructors. -} tyConAppToHsType :: GHC.Type -> Transform (GHC.LHsType GHC.RdrName) tyConAppToHsType (GHC.TyConApp tc _ts) = r (show $ GHC.tyConName tc) where r str = do ss <- uniqueSrcSpanT let typ = GHC.L ss (GHC.HsTyLit (GHC.HsStrTy str $ GHC.mkFastString str)) :: GHC.LHsType GHC.RdrName addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,1))] return typ -- tyConAppToHsType t@(GHC.TyConApp _tc _ts) -- = error $ "tyConAppToHsType: unexpected:" ++ (SYB.showData SYB.TypeChecker 0 t) {- HsType HsForAllTy HsExplicitFlag (LHsTyVarBndrs name) (LHsContext name) (LHsType name) HsTyVar name HsAppTy (LHsType name) (LHsType name) HsFunTy (LHsType name) (LHsType name) HsListTy (LHsType name) HsPArrTy (LHsType name) HsTupleTy HsTupleSort [LHsType name] HsOpTy (LHsType name) (LHsTyOp name) (LHsType name) HsParTy (LHsType name) HsIParamTy HsIPName (LHsType name) HsEqTy (LHsType name) (LHsType name) HsKindSig (LHsType name) (LHsKind name) HsQuasiQuoteTy (HsQuasiQuote name) HsSpliceTy (HsSplice name) FreeVars PostTcKind HsDocTy (LHsType name) LHsDocString HsBangTy HsBang (LHsType name) HsRecTy [ConDeclField name] HsCoreTy Type HsExplicitListTy PostTcKind [LHsType name] HsExplicitTupleTy [PostTcKind] [LHsType name] HsTyLit HsTyLit HsWrapTy HsTyWrapper (HsType name) -} -} --------------------------------End of Lifting----------------------------------------- {-Refactoring : demote a function/pattern binding(simpe or complex) to the declaration where it is used. Descritption: if a declaration D, say, is only used by another declaration F,say, then D can be demoted into the local declaration list (where clause) in F. So currently, D can not be demoted if more than one declaration use it. In a multi-module context, a top-level definition can not be demoted if it is used by other modules. In the case that the demoted identifer is in the hiding list of import declaration in a client module, it should be removed from the hiding list. Function name:demote parameters: fileName--current file name. mod -- the scoped abstract syntax tree of the module. pn -- the function/pattern name to be demoted. -} demote' :: GHC.ModuleName -- -> FilePath -- -> (ParseResult,[PosToken]) -> GHC.Located GHC.Name -> RefactGhc [ApplyRefacResult] demote' modName (GHC.L _ pn) = do renamed <- getRefactRenamed parsed <- getRefactParsed nm <- getRefactNameMap targetModule <- getRefactTargetModule if isFunOrPatName nm pn parsed then do isTl <- isTopLevelPN pn if isTl && isExplicitlyExported nm pn parsed then error "This definition can not be demoted, as it is explicitly exported by the current module!" else do (refactoredMod,declaredPns) <- applyRefac (doDemoting pn) RSAlreadyLoaded if isTl && modIsExported modName renamed then do logm $ "demote':isTl && isExported" clients <- clientModsAndFiles targetModule logm $ "demote':clients=" ++ (showGhc clients) refactoredClients <-mapM (demotingInClientMod declaredPns) clients return (refactoredMod:refactoredClients) else do return [refactoredMod] else error "\nInvalid cursor position!" -- |Do refactoring in the client module, that is: -- a) Check whether the identifier is used in the module body -- b) If the identifier is not used but is hided by the import -- declaration, then remove it from the hiding. demotingInClientMod :: [GHC.Name] -> TargetModule -> RefactGhc ApplyRefacResult demotingInClientMod pns targetModule = do logm $ "demotingInClientMod:(pns,targetModule)=" ++ showGhc (pns,targetModule) getTargetGhc targetModule modu <- getRefactModule (refactoredMod,_) <- applyRefac (doDemotingInClientMod pns modu) RSAlreadyLoaded return refactoredMod doDemotingInClientMod :: [GHC.Name] -> GHC.Module -> RefactGhc () doDemotingInClientMod pns modName = do logm $ "doDemotingInClientMod:(pns,modName)=" ++ showGhc (pns,modName) (GHC.L _ p) <- getRefactParsed nm <- getRefactNameMap if any (\pn -> findNameInRdr nm pn (GHC.hsmodDecls p) || findNameInRdr nm pn (GHC.hsmodExports p)) pns then error $ "This definition can not be demoted, as it is used in the client module '"++(showGhc modName)++"'!" else if any (\pn->findNameInRdr nm pn (GHC.hsmodImports p)) pns -- TODO: reinstate this then do -- (mod',((ts',m),_))<-runStateT (rmItemsFromImport mod pns) ((ts,unmodified),(-1000,0)) return () else return () -- --------------------------------------------------------------------- doDemoting :: GHC.Name -> RefactGhc [GHC.Name] doDemoting pn = do clearRefactDone -- Only do this action once parsed <- getRefactParsed parsed' <- everywhereMStaged' SYB.Parser (SYB.mkM demoteInMod `SYB.extM` demoteInMatch `SYB.extM` demoteInPat `SYB.extM` demoteInLet `SYB.extM` demoteInStmt ) parsed putRefactParsed parsed' emptyAnns nm <- getRefactNameMap decls <- liftT $ hsDecls parsed let demotedDecls'= definingDeclsRdrNames nm [pn] decls True False declaredPnsRdr = nub $ concatMap definedPNsRdr demotedDecls' declaredPns = map (rdrName2NamePure nm) declaredPnsRdr return declaredPns where --1. demote from top level demoteInMod x@(parsed :: GHC.ParsedSource) = do decls <- liftT $ hsDecls parsed nm <- getRefactNameMap if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False) then do logm "MoveDef:demoteInMod" -- ++AZ++ demoted <- doDemoting' parsed pn return demoted else return x --2. The demoted definition is a local decl in a match demoteInMatch match@(GHC.L _ (GHC.Match _ _pats _mt (GHC.GRHSs _ _ds))::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do -- decls <- liftT $ hsDecls ds decls <- liftT $ hsDecls match nm <- getRefactNameMap if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False) then do logm "MoveDef:demoteInMatch" -- ++AZ++ done <- getRefactDone match' <- if (not done) then doDemoting' match pn else return match return match' else return match --3. The demoted definition is a local decl in a pattern binding demoteInPat x@(pat@(GHC.L _ (GHC.ValD (GHC.PatBind _p (GHC.GRHSs _grhs _lb) _ _ _)))::GHC.LHsDecl GHC.RdrName) = do decls <- liftT $ hsDeclsPatBindD x nm <- getRefactNameMap if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False) then do logm "MoveDef:demoteInPat" -- ++AZ++ done <- getRefactDone pat' <- if (not done) then doDemoting' pat pn else return pat return pat' else return x demoteInPat x = return x --4: The demoted definition is a local decl in a Let expression demoteInLet x@(letExp@(GHC.L _ (GHC.HsLet _ds _e))::GHC.LHsExpr GHC.RdrName) = do decls <- liftT $ hsDecls x nm <- getRefactNameMap if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False) then do logm "MoveDef:demoteInLet" -- ++AZ++ done <- getRefactDone letExp' <- if (not done) then doDemoting' letExp pn else return letExp return letExp' else return x demoteInLet x = return x --6.The demoted definition is a local decl in a Let statement. -- demoteInStmt (letStmt@(HsLetStmt ds stmts):: (HsStmt (HsExpP) (HsPatP) [HsDeclP])) demoteInStmt (letStmt@(GHC.L _ (GHC.LetStmt _binds))::GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do decls <- liftT $ hsDecls letStmt nm <- getRefactNameMap if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False) then do logm "MoveDef:demoteInStmt" -- ++AZ++ done <- getRefactDone letStmt' <- if (not done) then doDemoting' letStmt pn else return letStmt return letStmt' else return letStmt demoteInStmt x = return x -- |Demote the declaration of 'pn' in the context of 't'. doDemoting' :: (UsedByRhs t) => t -> GHC.Name -> RefactGhc t doDemoting' t pn = do nm <- getRefactNameMap -- origDecls <- liftT $ hsDecls t origDecls <- liftT $ hsDeclsGeneric t let demotedDecls'= definingDeclsRdrNames nm [pn] origDecls True False declaredPns = nub $ concatMap (definedNamesRdr nm) demotedDecls' pnsUsed = usedByRhsRdr nm t declaredPns logm $ "doDemoting':(pn,declaredPns)=" ++ showGhc (pn,declaredPns) -- logm $ "doDemoting':t=" ++ (SYB.showData SYB.Renamer 0 t) logm $ "doDemoting':(declaredPns,pnsUsed)=" ++ showGhc (declaredPns,pnsUsed) r <- if not pnsUsed -- (usedByRhs t declaredPns) then do logm $ "doDemoting' no pnsUsed" -- dt <- liftT $ hsDecls t let dt = origDecls let demotedDecls = definingDeclsRdrNames nm [pn] dt True True otherBinds = (deleteFirstsBy (sameBindRdr nm) dt demotedDecls) {- From 'hsDecls t' to 'hsDecls t \\ demotedDecls'. Bug fixed 06/09/2004 to handle direct recursive function. -} xx = map (\b -> (b,uses nm declaredPns [b])) otherBinds useCount = sum $ concatMap snd xx logm $ "doDemoting': declaredPns=" ++ (showGhc declaredPns) logm $ "doDemoting': uses xx=" ++ (showGhc xx) logm $ "doDemoting': uses useCount=" ++ (show useCount) case useCount of 0 ->do error "\n Nowhere to demote this function!\n" 1 -> --This function is only used by one friend function do logm "MoveDef.doDemoting':target location found" -- ++AZ++ let (FN f,_d) = hsFreeAndDeclaredRdr nm demotedDecls (ds,removedDecl,_sigRemoved) <- rmDecl pn False t (t',demotedSigs) <- rmTypeSigs declaredPns ds logDataWithAnns "MoveDef.doDemoting':after rmTypeSigs:demotedSigs=" demotedSigs logm $ "MoveDef:declaredPns=" ++ (showGhc declaredPns) -- ++AZ++ dl <- mapM (flip (declaredNamesInTargetPlace nm) ds) declaredPns logm $ "mapM declaredNamesInTargetPlace done" --make sure free variable in 'f' do not clash with variables in 'dl', --otherwise do renaming. let clashedNames=filter (\x-> elem (id x) (map id f)) $ (nub.concat) dl --rename clashed names to new names created automatically,update TOKEN STREAM as well. 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 --duplicate demoted declarations to the right place. do duplicateDecls declaredPns removedDecl demotedSigs t' _ ->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" return r where ---find how many matches/pattern bindings use 'pn'------- uses :: NameMap -> [GHC.Name] -> [GHC.LHsDecl GHC.RdrName] -> [Int] uses nm pns t2 = concatMap used t2 where used :: GHC.LHsDecl GHC.RdrName -> [Int] #if __GLASGOW_HASKELL__ <= 710 used (GHC.L _ (GHC.ValD (GHC.FunBind _n _ (GHC.MG matches _ _ _) _ _ _))) #else used (GHC.L _ (GHC.ValD (GHC.FunBind _n (GHC.MG (GHC.L _ matches) _ _ _) _ _ _))) #endif = concatMap (usedInMatch pns) matches used (GHC.L _ (GHC.ValD (GHC.PatBind pat rhs _ _ _))) | (not $ findNamesRdr nm pns pat) && findNamesRdr nm pns rhs = [1::Int] used _ = [] usedInMatch pns' (GHC.L _ (GHC.Match _ pats _ rhs)) | (not $ findNamesRdr nm pns' pats) && findNamesRdr nm pns' rhs = [1::Int] usedInMatch _ _ = [] duplicateDecls :: (SYB.Data t,SYB.Typeable t) => [GHC.Name] -- ^ function names to be demoted -> GHC.LHsDecl GHC.RdrName -- ^Bind being demoted -> [GHC.LSig GHC.RdrName] -- ^Signatures being demoted, if any -> t -> RefactGhc t duplicateDecls pns demoted dsig o = do logm $ "duplicateDecls:t=" ++ SYB.showData SYB.Parser 0 o hasDeclsSybTransform workerHsDecls workerBind o where workerHsDecls :: forall t. HasDecls t => t -> RefactGhc t workerHsDecls t' = do dds <- liftT $ hsDecls t' ds'' <- duplicateDecls' pns demoted dsig dds liftT $ replaceDecls t' ds'' workerBind :: (GHC.LHsBind GHC.RdrName -> RefactGhc (GHC.LHsBind GHC.RdrName)) workerBind t'@(GHC.L _ (GHC.PatBind{})) = do dds <- liftT $ hsDeclsPatBind t' ds'' <- duplicateDecls' pns demoted dsig dds liftT $ replaceDeclsPatBind t' ds'' workerBind x = error $ "MoveDef.duplicateDecls.workerBind:unmatched LHsBind:" ++ showGhc x -- duplicate demotedDecls to the right place (the outer most level where it is used). duplicateDecls' :: [GHC.Name] -- ^ function names to be demoted -> GHC.LHsDecl GHC.RdrName -- ^Bind being demoted -> [GHC.LSig GHC.RdrName] -- ^Signatures being demoted, if any -> [GHC.LHsDecl GHC.RdrName] -- ^Binds of original top -- level entiity, -- including src and dst -> RefactGhc [GHC.LHsDecl GHC.RdrName] duplicateDecls' pns demoted dsig decls = do nm <- getRefactNameMap everywhereMStaged' SYB.Parser (SYB.mkM (dupInMatch nm) -- top-down approach `SYB.extM` (dupInPat nm)) decls where dupInMatch nm (match@(GHC.L _ (GHC.Match _ pats _mt rhs)) :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) | (not $ findNamesRdr nm pns pats) && findNamesRdr nm pns rhs = do done <- getRefactDone logm $ "duplicateDecls.dupInMatch:value of done=" ++ (show done) -- ++AZ++ if done then return match else do logm "duplicateDecls:setting done" -- ++AZ++ setRefactDone match' <- foldParams pns match decls demoted dsig return match' dupInMatch _ x = return x dupInPat nm ((GHC.PatBind pat rhs@(GHC.GRHSs grhs lb) ty fvs ticks) :: GHC.HsBind GHC.RdrName) | (not $ findNamesRdr nm pns pat) && findNamesRdr nm pns rhs = do logm $ "duplicateDecls.dupInPat" let declsToLift = definingDeclsRdrNames' nm pns t lb' <- moveDecl1 lb Nothing pns declsToLift pns [] return (GHC.PatBind pat (GHC.GRHSs grhs lb') ty fvs ticks) dupInPat _ x = return x -- demotedDecls = definingDecls pns decls True False --------------------------------------------------------------------- declaredNamesInTargetPlace :: (SYB.Data t) => NameMap -> GHC.Name -> t -> RefactGhc [GHC.Name] declaredNamesInTargetPlace nm pn' t' = do logm $ "declaredNamesInTargetPlace:pn=" ++ (showGhc pn') res <- applyTU (stop_tdTU (failTU `adhocTU` inMatch `adhocTU` inPat)) t' logm $ "declaredNamesInTargetPlace:res=" ++ (showGhc res) return res where inMatch ((GHC.Match _ _pats _ rhs) :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) | findNameInRdr nm pn' rhs = do logm $ "declaredNamesInTargetPlace:inMatch" -- fds <- hsFDsFromInside rhs let (_,DN ds) = hsFDsFromInsideRdr nm rhs return ds inMatch _ = return mzero inPat ((GHC.PatBind pat rhs _ _ _) :: GHC.HsBind GHC.RdrName) |findNameInRdr nm pn' rhs = do logm $ "declaredNamesInTargetPlace:inPat" let (_,DN ds) = hsFDsFromInsideRdr nm pat return ds inPat _= return mzero -- --------------------------------------------------------------------- {- foldParams:remove parameters in the demotedDecls if possible parameters: pn -- the function/pattern name to be demoted in PName format match--where the demotedDecls will be demoted to demotedDecls -- the declarations to be demoted. example: module Test where demote 'sq' module Test where sumSquares x y ===> sumSquares x y =(sq 0) + (sq y) = sq x 0+ sq x y where sq y=x ^ y sq x y=x^y -} --PROBLEM: TYPE SIGNATURE SHOULD BE CHANGED. --- TEST THIS FUNCTION!!! foldParams :: [GHC.Name] -- ^The (list?) function name being demoted -> GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -- ^The RHS of the place to receive the demoted decls -> [GHC.LHsDecl GHC.RdrName] -- ^Binds of original top level entiity, including src and dst -> GHC.LHsDecl GHC.RdrName -- ^The decls being demoted -> [GHC.LSig GHC.RdrName] -- ^Signatures being demoted, if any -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) foldParams pns match@(GHC.L l (GHC.Match _mfn _pats _mt rhs)) _decls demotedDecls dsig =do logm $ "MoveDef.foldParams entered" nm <- getRefactNameMap let matches = concatMap matchesInDecls [demotedDecls] pn = ghead "foldParams" pns --pns /=[] logm $ "MoveDef.foldParams before allParams" params <- allParams pn rhs [] logm $ "foldParams:params=" ++ showGhc params if (length.nub.map length) params==1 -- have same number of param && ((length matches)==1) -- only one 'match' in the demoted declaration then do let patsInDemotedDecls=(patsInMatch.(ghead "foldParams")) matches subst = mkSubst nm patsInDemotedDecls params fstSubst = map fst subst sndSubst = map snd subst rhs' <- rmParamsInParent pn sndSubst rhs let ls = map (hsFreeAndDeclaredRdr nm) sndSubst let newNames = ((concatMap (fn . fst) ls)) \\ (fstSubst) --There may be name clashing because of introducing new names. clashedNames <- getClashedNames nm fstSubst newNames (ghead "foldParams" matches) logm $ "MoveDef.foldParams about to foldInDemotedDecls" demotedDecls''' <- foldInDemotedDecls pns clashedNames subst [demotedDecls] logm $ "MoveDef.foldParams foldInDemotedDecls done" let match' = GHC.L l ((GHC.unLoc match) {GHC.m_grhss = rhs' }) match'' <- addDecl match' Nothing (demotedDecls''',Nothing) logm $ "MoveDef.foldParams addDecl done 1" return match'' else do logm $ "foldParams:no params" let sigs = map wrapSig dsig match' <- addDecl match Nothing (sigs++[demotedDecls],Nothing) logm "MoveDef.foldParams addDecl done 2" return match' where matchesInDecls :: GHC.LHsDecl GHC.RdrName -> [GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)] #if __GLASGOW_HASKELL__ <= 710 matchesInDecls (GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _))) = matches #else matchesInDecls (GHC.L _ (GHC.ValD (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _))) = matches #endif matchesInDecls _x = [] patsInMatch (GHC.L _ (GHC.Match _ pats' _ _)) = pats' foldInDemotedDecls :: [GHC.Name] -- ^The (list?) of names to be demoted -> [GHC.Name] -- ^Any names that clash -> [(GHC.Name, GHC.HsExpr GHC.RdrName)] -- ^Parameter substitutions required -> [GHC.LHsDecl GHC.RdrName] -- ^Binds of original top level entity, including src and dst -> RefactGhc [GHC.LHsDecl GHC.RdrName] foldInDemotedDecls pns' clashedNames subst decls = do logm $ "foldInDemotedDecls:(pns',clashedNames,subst)=" ++ showGhc (pns',clashedNames,subst) logm $ "foldInDemotedDecls:decls=" ++ SYB.showData SYB.Parser 0 decls nm <- getRefactNameMap SYB.everywhereMStaged SYB.Parser (SYB.mkM (worker nm) `SYB.extM` (workerBind nm)) decls where #if __GLASGOW_HASKELL__ <= 710 worker nm (match'@(GHC.L _ (GHC.FunBind ln _ (GHC.MG _matches _ _ _) _ _ _)) :: GHC.LHsBind GHC.RdrName) #else worker nm (match'@(GHC.L _ (GHC.FunBind ln (GHC.MG _matches _ _ _) _ _ _)) :: GHC.LHsBind GHC.RdrName) #endif = do logm $ "foldInDemotedDecls:rdrName2NamePure nm ln=" ++ show (rdrName2NamePure nm ln) if isJust (find (== rdrName2NamePure nm ln) pns') then do logm $ "foldInDemotedDecls:found match'" match'' <- foldM (flip autoRenameLocalVar) match' clashedNames match''' <- foldM replaceExpWithUpdToks match'' subst rmParamsInDemotedDecls (map fst subst) match''' else return match' worker _ x = return x workerBind nm ((GHC.L ll (GHC.ValD d)) :: GHC.LHsDecl GHC.RdrName) = do (GHC.L _ d') <- worker nm (GHC.L ll d) return (GHC.L ll (GHC.ValD d')) workerBind _ x = return x ------Get all of the paramaters supplied to pn --------------------------- {- eg. sumSquares x1 y1 x2 y2 = rt x1 y1 + rt x2 y2 rt x y = x+y demote 'rt' to 'sumSquares', 'allParams pn rhs []' returns [[x1,x2],[y1,y2]] where pn is 'rt' and rhs is 'rt x1 y1 + rt x2 y2' -} allParams :: GHC.Name -> GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> [[GHC.HsExpr GHC.RdrName]] -> RefactGhc [[GHC.HsExpr GHC.RdrName]] allParams pn rhs1 initial -- pn: demoted function/pattern name. =do nm <- getRefactNameMap let p = getOneParam nm pn rhs1 -- putStrLn (show p) logm $ "allParams:p=" ++ showGhc p if (nonEmptyList p) then do rhs' <- rmOneParam pn rhs1 logDataWithAnns "allParams:rhs'=" rhs' allParams pn rhs' (initial++[p]) else return initial where getOneParam :: (SYB.Data t) => NameMap -> GHC.Name -> t -> [GHC.HsExpr GHC.RdrName] getOneParam nm pn1 = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` worker) -- =applyTU (stop_tdTU (failTU `adhocTU` worker)) where worker :: GHC.HsExpr GHC.RdrName -> [GHC.HsExpr GHC.RdrName] worker (GHC.HsApp e1 e2) |(expToNameRdr nm e1 == Just pn1) = [GHC.unLoc e2] worker _ = [] rmOneParam :: (SYB.Data t) => GHC.Name -> t -> RefactGhc t rmOneParam pn1 t -- This genuinely needs to be done once only. Damn. -- =applyTP (stop_tdTP (failTP `adhocTP` worker)) = do -- _ <- clearRefactDone nm <- getRefactNameMap everywhereMStaged' SYB.Parser (SYB.mkM (worker nm)) t where worker nm (GHC.L _ (GHC.HsApp e1 _e2 )) -- The param being removed is e2 |expToNameRdr nm e1 == Just pn1 = return e1 worker _ x = return x {- AST output addthree x y z becomes (HsApp (L {test/testdata/Demote/WhereIn6.hs:10:17-28} (HsApp (L {test/testdata/Demote/WhereIn6.hs:10:17-26} (HsApp (L {test/testdata/Demote/WhereIn6.hs:10:17-24} (HsVar {Name: WhereIn6.addthree})) (L {test/testdata/Demote/WhereIn6.hs:10:26} (HsVar {Name: x})))) (L {test/testdata/Demote/WhereIn6.hs:10:28} (HsVar {Name: y})))) (L {test/testdata/Demote/WhereIn6.hs:10:30} (HsVar {Name: z}))) ----- (HsApp (HsApp (HsApp (HsVar {Name: WhereIn6.addthree})) (HsVar {Name: x})))) (HsVar {Name: y})))) (HsVar {Name: z}))) ----- sq p x becomes (HsApp (HsApp (HsVar {Name: Demote.WhereIn4.sq})) (HsVar {Name: p})))) (HsVar {Name: x}))) ---- sq x becomes (HsApp (HsVar {Name: sq})) (HsVar {Name: x}))) -} -----------remove parameters in demotedDecls------------------------------- rmParamsInDemotedDecls :: [GHC.Name] -> GHC.LHsBind GHC.RdrName -> RefactGhc (GHC.LHsBind GHC.RdrName) rmParamsInDemotedDecls ps bind -- =applyTP (once_tdTP (failTP `adhocTP` worker)) = SYB.everywhereMStaged SYB.Parser (SYB.mkM worker) bind where worker :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) worker (GHC.Match mfn' pats2 typ rhs1) = do nm <- getRefactNameMap let pats'=filter (\x->not ((patToNameRdr nm x /= Nothing) && elem (gfromJust "rmParamsInDemotedDecls" $ patToNameRdr nm x) ps)) pats2 return (GHC.Match mfn' pats' typ rhs1) ----------remove parameters in the parent functions' rhs------------------- rmParamsInParent :: GHC.Name -> [GHC.HsExpr GHC.RdrName] -> GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) rmParamsInParent pn es grhss = do nm <- getRefactNameMap -- =applyTP (full_buTP (idTP `adhocTP` worker)) SYB.everywhereMStaged SYB.Renamer (SYB.mkM (worker nm)) grhss where worker nm expr@(GHC.L _ (GHC.HsApp e1 e2)) | findNamesRdr nm [pn] e1 && (elem (showGhc (GHC.unLoc e2)) (map (showGhc) es)) = do liftT $ transferEntryDPT expr e1 return e1 worker nm (expr@(GHC.L _ (GHC.HsPar e1))) |Just pn==expToNameRdr nm e1 = do liftT $ transferEntryDPT expr e1 return e1 worker _ x =return x getClashedNames :: NameMap -> [GHC.Name] -> [GHC.Name] -> GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc [GHC.Name] getClashedNames nm oldNames newNames match' = do let (_f,DN d) = hsFDsFromInsideRdr nm match' ds'' <- mapM (flip (hsVisibleDsRdr nm) match') oldNames let ds' = map (\(DN ds) -> ds) ds'' -- return clashed names return (filter (\x->elem ({- pNtoName -} x) newNames) --Attention: nub ( nub (d `union` (nub.concat) ds'))) ----- make Substitions between formal and actual parameters.----------------- mkSubst :: NameMap -> [GHC.LPat GHC.RdrName] -> [[GHC.HsExpr GHC.RdrName]] -> [(GHC.Name,GHC.HsExpr GHC.RdrName)] mkSubst nm pats1 params = catMaybes (zipWith (\x y -> if (patToNameRdr nm x/=Nothing) && (length (nub $ map showGhc y)==1) then Just (gfromJust "mkSubst" $ patToNameRdr nm x,(ghead "mkSubst") y) else Nothing) pats1 params) -- |substitute an old expression by new expression replaceExpWithUpdToks :: GHC.LHsBind GHC.RdrName -> (GHC.Name, GHC.HsExpr GHC.RdrName) -> RefactGhc (GHC.LHsBind GHC.RdrName) replaceExpWithUpdToks decls subst = do nm <- getRefactNameMap let worker (e@(GHC.L l _)::GHC.LHsExpr GHC.RdrName) |(expToNameRdr nm e) == Just (fst subst) = return (GHC.L l (snd subst)) worker x=return x -- = applyTP (full_buTP (idTP `adhocTP` worker)) decls everywhereMStaged' SYB.Parser (SYB.mkM worker) decls -- | return True if pn is a local function/pattern name isLocalFunOrPatName :: SYB.Data t => NameMap -> GHC.Name -> t -> Bool isLocalFunOrPatName nm pn scope = isLocalPN pn && isFunOrPatName nm pn scope -- EOF