HaRe 0.8.1.1 → 0.8.2.0
raw patch · 15 files changed
+802/−39 lines, 15 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Language.Haskell.Refact.API: addItemsToExport :: ParsedSource -> Maybe PName -> Bool -> Either [String] [LIE RdrName] -> RefactGhc ParsedSource
+ Language.Haskell.Refact.Refactoring.AddRmParam: addOneParameter :: RefactSettings -> Options -> FilePath -> String -> SimpPos -> IO [FilePath]
+ Language.Haskell.Refact.Utils.TypeUtils: addItemsToExport :: ParsedSource -> Maybe PName -> Bool -> Either [String] [LIE RdrName] -> RefactGhc ParsedSource
Files
- ChangeLog +6/−0
- HaRe.cabal +5/−2
- src/Language/Haskell/Refact/API.hs +1/−1
- src/Language/Haskell/Refact/Refactoring/AddRmParam.hs +586/−0
- src/Language/Haskell/Refact/Refactoring/DupDef.hs +2/−3
- src/Language/Haskell/Refact/Refactoring/MoveDef.hs +13/−3
- src/Language/Haskell/Refact/Utils/MonadFunctions.hs +1/−1
- src/Language/Haskell/Refact/Utils/TypeUtils.hs +87/−23
- src/Language/Haskell/Refact/Utils/Utils.hs +23/−6
- test/MoveDefSpec.hs +10/−0
- test/RenamingSpec.hs +13/−0
- test/UtilsSpec.hs +7/−0
- test/testdata/BCppTC.hs +17/−0
- test/testdata/LiftToToplevel/Collapse1.expected.hs +16/−0
- test/testdata/LiftToToplevel/Collapse1.hs +15/−0
ChangeLog view
@@ -1,3 +1,9 @@+2015-10-07 v0.8.2.0+ * Work around a bug in GHC 7.10.2 that will not process pragmas+ after a comment at the top of a file, when comments are returned+ for ghc-exactprint processing.+ * Add parameters to all use sites in the original location when+ lifting a declaration. 2015-10-05 v0.8.1.1 * Move to new/old home at https://github.com/RefactoringTools/HaRe 2015-10-05 v0.8.1.0
HaRe.cabal view
@@ -1,5 +1,5 @@ Name: HaRe-Version: 0.8.1.1+Version: 0.8.2.0 Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer: Alan Zimmerman Stability: Alpha@@ -142,13 +142,14 @@ Exposed-modules: Language.Haskell.Refact.API , Language.Haskell.Refact.HaRe+ , Language.Haskell.Refact.Refactoring.AddRmParam , Language.Haskell.Refact.Refactoring.Case , Language.Haskell.Refact.Refactoring.DupDef , Language.Haskell.Refact.Refactoring.MoveDef , Language.Haskell.Refact.Refactoring.Renaming , Language.Haskell.Refact.Refactoring.RoundTrip- , Language.Haskell.Refact.Refactoring.SwapArgs , Language.Haskell.Refact.Refactoring.Simple+ , Language.Haskell.Refact.Refactoring.SwapArgs , Language.Haskell.Refact.Utils.Binds , Language.Haskell.Refact.Utils.ExactPrint , Language.Haskell.Refact.Utils.GhcBugWorkArounds@@ -178,6 +179,7 @@ other-modules: Language.Haskell.Refact.API , Language.Haskell.Refact.HaRe+ , Language.Haskell.Refact.Refactoring.AddRmParam , Language.Haskell.Refact.Refactoring.Case , Language.Haskell.Refact.Refactoring.RoundTrip , Language.Haskell.Refact.Utils.Binds@@ -266,6 +268,7 @@ , Language.Haskell.Refact.API , Language.Haskell.Refact.HaRe+ , Language.Haskell.Refact.Refactoring.AddRmParam , Language.Haskell.Refact.Refactoring.Case , Language.Haskell.Refact.Refactoring.RoundTrip , Language.Haskell.Refact.Utils.Binds
src/Language/Haskell/Refact/API.hs view
@@ -155,7 +155,7 @@ -- * Program transformation -- *** Adding- ,addDecl, addItemsToImport, addHiding+ ,addDecl, addItemsToImport, addItemsToExport, addHiding ,addParamsToDecls, addActualParamsToRhs, addImportDecl, duplicateDecl -- , moveDecl -- *** Removing ,rmDecl, rmTypeSig, rmTypeSigs
+ src/Language/Haskell/Refact/Refactoring/AddRmParam.hs view
@@ -0,0 +1,586 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- module Language.Haskell.Refact.Refactoring.AddRmParam(addOneParameter,rmOneParameter) where+module Language.Haskell.Refact.Refactoring.AddRmParam(addOneParameter) where++-- import PosSyntax+-- import TypedIds+-- import UniqueNames hiding (srcLoc)+-- import PNT+-- import TiPNT++import qualified Data.Generics as SYB+import qualified GHC.SYB.Utils as SYB++import qualified GHC+import qualified RdrName as GHC++import qualified Language.Haskell.GhcMod as GM+import Language.Haskell.GhcMod.Internal as GM+import Language.Haskell.Refact.API++import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Transform++import System.Directory+import Data.Maybe+import Data.List hiding (delete)+-- import RefacUtils+-- import Data.Char++import Data.Generics.Strafunski.StrategyLib.StrategyLib++import Control.Exception++-----------------------------------------------------------------------------------------------------+{- An argument can be added to the definition of a function or constant. Adding an argument to a constant+ definition will change the constant definition to a function definition. The new parameter is always+ added as the first parameter of the function. A default parameter will be added as the first argument+ to each of the function's call site. Suppose a new parameter named 'p' is added to function 'f',+ then default parameter will be defined automatically as p_f_i=undefined, where 'i' is an integer.+ To ensure that the default parameter name does not cause name clash in the client modules, we take the+ visble names both in the current module and in the client modules into account when creating the+ name.++-}+-----------------------------------------------------------------------------------------------------++addOneParameter :: RefactSettings -> GM.Options -> FilePath -> String -> SimpPos -> IO [FilePath]+addOneParameter settings opts fileName paramName (row,col) = do+ absFileName <- canonicalizePath fileName+ runRefacSession settings opts (compAdd absFileName paramName (row,col))++compAdd :: FilePath -> String -> SimpPos -> RefactGhc [ApplyRefacResult]+compAdd fileName paramName (row, col) = do+ if isVarId paramName+ then+ do+ parseSourceFileGhc fileName+ renamed <- getRefactRenamed+ parsed <- getRefactParsed+ targetModule <- getRefactTargetModule+ logm $ "AddRmParam.compAdd:got targetModule"+ let (Just (modName,_)) = getModuleName parsed+ let maybePn = locToName (row, col) renamed+ case maybePn of+ Just pnt@(GHC.L _ pn) ->+ do+ logm $ "AddRmParam.compAdd:about to applyRefac for:pn=" ++ SYB.showData SYB.Parser 0 pn+ -- make sure this name is defined in this module+ if isFunOrPatName pn renamed+ then do+ exported <- isExported pn+ if exported+ then do+ assert False undefined+ else do+ (refactoredMod,_) <- applyRefac (doAddingParam undefined modName pn paramName Nothing False) (RSFile fileName)+ return [refactoredMod]++ else error "Invalid cursor position or identifier is not a function/pattern name defined in this module!\n"+ Nothing -> error "Invalid cursor position or identifier is not a function/pattern name defined in this module!\n"+ else error $ "Invalid parameter name:" ++ paramName ++ "!"++{-+addOneParameter args+ = let fileName = args!!0+ paramName= args!!1+ row = read (args!!2)::Int+ col = read (args!!3)::Int+ in if isVarId paramName+ then do modName <-fileNameToModName fileName+ (inscps, exps, mod, tokList)<-parseSourceFile fileName+ let pnt@(PNT pn _ _)=locToPNT fileName (row, col) mod+ --make sure this name is defined in this module+ if pn /= defaultPN && isFunOrPatName pn mod+ then if isExported pnt exps+ then do clients <- clientModsAndFiles modName+ info <- mapM parseSourceFile $ map snd clients+ defaultArg <-mkTopLevelDefaultArgName pn paramName fileName modName+ ( map (\(x, _,_,_)->x) (concatMap inScopeInfo (map myfst info))) (hsDecls mod)+ (mod',((ts',m), _))<-doAddingParam fileName modName pn paramName+ (Just defaultArg) True mod tokList+ refactoredClients<-mapM (addArgInClientMod pnt defaultArg modName) $ zip info (map snd clients)+ writeRefactoredFiles False $ ((fileName,m),(ts',mod')):refactoredClients+ else do (mod',((ts',m),_))<-doAddingParam fileName modName pn paramName Nothing False mod tokList+ writeRefactoredFiles False [((fileName,m),(ts',mod'))]+ else error "Invalid cursor position or identifier is not a function/pattern name defined in this module!\n"+ else error "Invalid parameter name!\n"+-}++-- ---------------------------------------------------------------------++doAddingParam :: FilePath -> GHC.ModuleName -> GHC.Name -> String -> Maybe String -> Bool+ -> RefactGhc ()+doAddingParam fileName modName pn newParam defaultArg isExported = do+ assert False undefined+ {-+ parsed <- getRefactParsed+ r <- applyTP (once_tdTP (failTP `adhocTP` inMod+ -- `adhocTP` inMatch+ -- `adhocTP` inPat+ -- `adhocTP` inLet+ -- `adhocTP` inAlt+ -- `adhocTP` inLetStmt+ )+ `choiceTP` failure) parsed+ putRefactParsed r emptyAnns+ return ()+ where+ --1.pn is declared in top level+ -- inMod (mod@(HsModule loc name exps imps ds):: HsModuleP)+ -- | definingDecls [pn] ds False False/=[]+ -- = do mod'<-doAdding mod ds+ -- if isExported && isExplicitlyExported pn mod+ -- then addItemsToExport mod' (Just pn) False (Left [pNtoName (fromJust defaultArg)])+ -- else return mod'+ -- inMod _ = mzero+ inMod (modu :: GHC.HsModule GHC.RdrName) = do+ nm <- getRefactNameMap+ if definingDeclsRdrNames nm [pn] modu /= []+ then+ do+ ds <- liftT $ hsDecls modu+ modu' <- doAdding modu ds+ if isExported && isExplicitlyExported pn modu+ then addItemsToExport modu' (Just pn) False (Left [(fromJust defaultArg)])+ else return modu'+ else return mzero++{-+ --2. pn is declared locally in the where clause of a match.+ inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+ | definingDecls [pn] ds False False/=[] = doAdding match ds+ inMatch _ = mzero++ --3. pn is declared locally in the where clause of a pattern binding.+ inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+ | definingDecls [pn] ds False False/=[] = doAdding pat ds+ inPat _ = mzero++ --4: pn is declared locally in a Let expression+ inLet (letExp@(Exp (HsLet ds e))::HsExpP)+ | definingDecls [pn] ds False False /=[] = doAdding letExp ds+ inLet _ = mzero++ --5. pn is declared locally in a case alternative.+ inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)+ | definingDecls [pn] ds False False/=[] = doAdding alt ds+ inAlt _ = mzero++ --6.pn is declared locally in a let statement.+ inLetStmt (letStmt@(HsLetStmt ds stmts):: HsStmtP)+ | definingDecls [pn] ds False False/=[] = doAdding letStmt ds+ inLetStmt _ = mzero+-}+ failure = idTP `adhocTP` mod+ where modu (m::GHC.ParsedSource) = error "Refactoring failed"++ doAdding parent ds+ = if paramNameOk pn newParam ds+ then+ do ds' <- addParamsToDecls ds pn [mkRdrName newParam] True --addFormalParam pn newParam ds+ defaultParamPName <-if isNothing defaultArg+ then mkLocalDefaultArgName pn newParam modName parent+ else return (fromJust defaultArg)+ parent' <- addDefaultActualArg False pn defaultParamPName (replaceDecls parent ds')+ parent''<- addDefaultActualArgDecl defaultParamPName parent' pn isExported+ ds'' <- addArgToSig pn (hsDecls parent'')+ return (replaceDecls parent'' ds'')+ else error " Refactoring failed."+-}+-- ---------------------------------------------------------------------+{-+doAddingParam fileName modName pn newParam defaultArg isExported mod tokList+ = runStateT (applyTP (once_tdTP (failTP `adhocTP` inMod+ `adhocTP` inMatch+ `adhocTP` inPat+ `adhocTP` inLet+ `adhocTP` inAlt+ `adhocTP` inLetStmt)+ `choiceTP` failure) mod) ((tokList,unmodified),(-1000,0))+ where+ --1.pn is declared in top level+ inMod (mod@(HsModule loc name exps imps ds):: HsModuleP)+ | definingDecls [pn] ds False False/=[]+ = do mod'<-doAdding mod ds+ if isExported && isExplicitlyExported pn mod+ then addItemsToExport mod' (Just pn) False (Left [pNtoName (fromJust defaultArg)])+ else return mod'++ inMod _ = mzero++ --2. pn is declared locally in the where clause of a match.+ inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+ | definingDecls [pn] ds False False/=[] = doAdding match ds+ inMatch _ = mzero++ --3. pn is declared locally in the where clause of a pattern binding.+ inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+ | definingDecls [pn] ds False False/=[] = doAdding pat ds+ inPat _ = mzero++ --4: pn is declared locally in a Let expression+ inLet (letExp@(Exp (HsLet ds e))::HsExpP)+ | definingDecls [pn] ds False False /=[] = doAdding letExp ds+ inLet _ = mzero++ --5. pn is declared locally in a case alternative.+ inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)+ | definingDecls [pn] ds False False/=[] = doAdding alt ds+ inAlt _ = mzero++ --6.pn is declared locally in a let statement.+ inLetStmt (letStmt@(HsLetStmt ds stmts):: HsStmtP)+ | definingDecls [pn] ds False False/=[] = doAdding letStmt ds+ inLetStmt _ = mzero++ failure = idTP `adhocTP` mod+ where mod (m::HsModuleP) = error "Refactoring failed"++ doAdding parent ds+ = if paramNameOk pn newParam ds+ then+ do ds' <- addParamsToDecls ds pn [nameToPN newParam] True --addFormalParam pn newParam ds+ defaultParamPName <-if isNothing defaultArg+ then mkLocalDefaultArgName pn newParam modName parent+ else return (fromJust defaultArg)+ parent' <- addDefaultActualArg False pn defaultParamPName (replaceDecls parent ds')+ parent''<- addDefaultActualArgDecl defaultParamPName parent' pn isExported+ ds'' <- addArgToSig pn (hsDecls parent'')+ return (replaceDecls parent'' ds'')+ else error " Refactoring failed."+-}++-- ---------------------------------------------------------------------++paramNameOk = assert False undefined+{-++-- check whether the new parameter is a legal.++paramNameOk pn newParam t = (fromMaybe True) (applyTU (once_tdTU (failTU `adhocTU` decl)) t)+ where+ decl ((Dec (HsFunBind _ matches@((HsMatch _ fun pats rhs ds):ms)))::HsDeclP)+ | pNTtoPN fun == pn+ = do results'<-mapM checkInMatch matches+ Just (all (==True) results')+ decl pat@(Dec (HsPatBind loc p rhs ds))+ | patToPN p == pn+ = do (f,d) <- hsFDNamesFromInside pat+ if elem newParam (f `union` d)+ then error "The new parameter name will cause name clash or semantics change, please select another name!"+ else Just True+ decl (Dec (HsPatBind _ p _ _))+ | patToPN p /= pn && elem pn (hsPNs p)+ = error "Parameter can not be added to complex pattern binding"+ decl _=mzero++ checkInMatch match+ = do (f,d) <- hsFDNamesFromInside match+ if elem newParam (f `union` d)+ then error "The new parameter name will cause name clash or semantics change, please choose another name!"+ else return True+-}+-- ---------------------------------------------------------------------+addDefaultActualArgDecl = assert False undefined+{-+--add the default argument declaration right after the declaration defining pn+addDefaultActualArgDecl defaultParamPName parent pn isExported+ =if not (findEntity pn parent) && not isExported+ then return parent+ else addDecl parent (Just pn) (defaultArgDecl,Nothing) True+ where+ defaultArgDecl= [Dec (HsPatBind loc0 (nameToPat (pNtoName defaultParamPName))(HsBody (nameToExp "undefined"))[])]++-}+-- ---------------------------------------------------------------------++mkLocalDefaultArgName = assert False undefined+{-+--suppose function name is f, parameter name is p, then the default argument name is like f_p.+mkLocalDefaultArgName fun paramName modName t+ =do (f,d)<-hsFDNamesFromInside t+ vs<-hsVisibleNames fun t+ let name=mkNewName ((pNtoName fun)++"_"++paramName) (nub (f `union` d `union` vs)) 0+ return (PN (UnQual name) (S loc0))++-}+-- ---------------------------------------------------------------------+{-+mkTopLevelDefaultArgName fun paramName fileName modName inscopeNames t+ =do (f,d)<-hsFDNamesFromInside t+ let name=mkNewName ((pNtoName fun)++"_"++paramName) (nub (f `union` d `union` inscopeNames)) 0+ let loc = SrcLoc fileName 0 (-1000) (-1000)+ return (PN (UnQual name) (G modName name (N (Just loc))))++-}+-- ---------------------------------------------------------------------+addDefaultActualArg = assert False undefined+{-++addDefaultActualArg recursion pn argPName+ = if recursion then applyTP (stop_tdTP (failTP `adhocTP` funApp))+ else applyTP (stop_tdTP (failTP `adhocTP` inDecl+ `adhocTP` funApp))+ where+ inDecl (fun@(Dec (HsFunBind _ ((HsMatch _ (PNT pname _ _) _ _ _):ms)))::HsDeclP)+ | pn == pname+ = return fun++ inDecl (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)+ | pn == patToPN ps+ = return pat+ inDecl _ = mzero++ funApp (exp@(Exp (HsId (HsVar (PNT pname _ _))))::HsExpP)+ |pname==pn+ = update exp (Exp (HsParen (Exp (HsApp exp (pNtoExp argPName))))) exp++ funApp _ = mzero++-}+-- ---------------------------------------------------------------------++addArgToSig = assert False undefined+{-+--Add type arg to type siginature+addArgToSig pn decls+ = let (before,after)=break (\d ->definesTypeSig pn d) decls+ in if after==[]+ then return decls+ else do newSig<-addArgToSig' [(head after)] --no problem with head.+ return (before++newSig++(tail after))++ where+ addArgToSig' sig@[(Dec (HsTypeSig loc is c tp))]+ =do let tVar=mkNewTypeVarName sig+ typeVar=newTypeVar tVar tp+ let newSig=if length is==1+ then --the type sig only defines the type for pn+ [Dec (HsTypeSig loc is c typeVar)]+ else --otherwise, seperate it into two type signatures.+ [Dec (HsTypeSig loc (filter (\x->pNTtoPN x/=pn) is) c tp),+ Dec (HsTypeSig loc (filter (\x->pNTtoPN x==pn) is) c typeVar)]+ update sig newSig sig++ --compose a type application using type expressions tv and tp+ newTypeVar tVar tp+ =(Typ (HsTyFun (Typ (HsTyVar (PNT (PN (UnQual tVar) (S loc0))+ (Type (TypeInfo {defType=Nothing, constructors=[], fields=[]})) (N (Just loc0))))) tp))++ {- make a fresh type variable name. the new name is the first letter in the alphabet which is not+ used in the type signature. -}+ mkNewTypeVarName sig+ =mkNewName "a" $ map pNtoName $ (snd.hsTypeVbls) sig+ where mkNewName initName v+ =if elem initName v+ then mkNewName ((intToDigit (digitToInt(head initName)+1)):tail initName) v+ else initName++addArgInClientMod pnt defaultArg serverModName ((inscps, exps, mod,ts), fileName)+ = let qual = hsQualifier pnt inscps+ pn = pNTtoPN pnt+ in if qual == []+ then return ((fileName,unmodified), (ts,mod))+ else do (mod',((ts',m), _))<-+ runStateT (do mod'<-addItemsToImport serverModName (Just pn) (Left [pNtoName defaultArg]) mod+ mod''<-addItemsToExport mod (Just pn) False (Left [pNtoName defaultArg])+ if isInScopeAndUnqualified (pNtoName pn) inscps+ then addDefaultActualArgInClientMod pn (head qual) defaultArg False mod''+ else addDefaultActualArgInClientMod pn (head qual) defaultArg True mod'')+ ((ts,unmodified), (-1000,0))+ return ((fileName,m),(ts',mod'))+++--add default actual argument to pn in all the calling places.+addDefaultActualArgInClientMod pn qual argPName toBeQualified t+ = applyTP (stop_tdTP (failTP `adhocTP` funApp)) t+ where+ funApp (exp@(Exp (HsId (HsVar pnt@(PNT pname _ _))))::HsExpP)+ | pname == pn+ = do vs <- hsVisibleNames pnt t+ let argExp=if toBeQualified || elem (pNtoName argPName) vs+ then pNtoExp (qualifyPName qual argPName)+ else pNtoExp argPName+ newExp =(Exp (HsParen (Exp (HsApp exp argExp))))+ update exp newExp exp+ funApp _=mzero++myfst (a,_,_,_) = a+-------------------------------End of adding a parameter-----------------------------------++-----------------------------------------------------------------------------------------------------+{-Refactoring: Remove a parameter+ Description: The refactoring removes a user specified formal parameter in a function binding,and+ the corresponding actual parameters in all calling places of this function. The+ condition acompanying this refactoring is that the parameter to be removed is not being used.++ --To select a parameter, just stop the cursor at any position between the start and end position of this parameter.+-}+-----------------------------------------------------------------------------------------------------++rmOneParameter args+ =do let fileName=args!!0+ row=read (args!!1)::Int+ col=read (args!!2)::Int+ (inscps, exps, mod, tokList)<-parseSourceFile fileName+ --pn is the function names.+ --nth is the nth paramter of pn is to be removed,index starts form 0.+ let (pnt,nth)=getParam tokList (row,col) mod+ pn=pNTtoPN pnt+ if pn/=defaultPN+ then do (mod',((ts',m), _))<-doRmParam pn nth mod fileName tokList+ if isExported pnt exps+ then do modName <- RefacUtils.fileNameToModName fileName+ clients<-clientModsAndFiles modName+ refactoredClients<-mapM (rmParamInClientMod pnt nth) clients+ writeRefactoredFiles False $ ((fileName,m),(ts',mod')):refactoredClients+ else writeRefactoredFiles False [((fileName,m), (ts',mod'))]+ else error "Invalid cursor position!"++--pn: function name; nth: the index of the parameter to be removed.+doRmParam pn nth mod fileName tokList+ =runStateT (applyTP ((once_tdTP (failTP `adhocTP` inMod+ `adhocTP` inMatch+ `adhocTP` inPat+ `adhocTP` inLet+ `adhocTP` inAlt+ `adhocTP` inLetStmt)) `choiceTP` failure) mod)+ ((tokList,unmodified),(-1000,0))+ where+ --1. pn is declared in top level.+ inMod (mod@(HsModule loc name exps imps ds):: HsModuleP)+ |definingDecls [pn] ds False False/=[] = doRemoving mod ds+ inMod _ =mzero++ --2. pn is declared locally in the where clause of a match.+ inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+ |definingDecls [pn] ds False False /=[] = doRemoving match ds+ inMatch _ =mzero++ --3. pn is declared locally in the where clause of a pattern binding.+ inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+ | definingDecls [pn] ds False False/=[] = doRemoving pat ds+ inPat _=mzero++ --4: pn is declared locally in a Let expression+ inLet (letExp@(Exp (HsLet ds e))::HsExpP)+ | definingDecls [pn] ds False False/=[] = doRemoving letExp ds+ inLet _=mzero++ --5. pn is declared locally in a case alternative.+ inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)+ | definingDecls [pn] ds False False/=[] = doRemoving alt ds+ inAlt _=mzero++ --6.pn is declared locally in a let statement.+ inLetStmt (letStmt@(HsLetStmt ds stmts):: HsStmtP)+ | definingDecls [pn] ds False False/=[] = doRemoving letStmt ds+ inLetStmt _=mzero++ failure=idTP `adhocTP` mod+ where mod (m::HsModuleP)=error "Refactoring failed"++ doRemoving parent ds --PROBLEM: How about doRemoving fails?+ =do rmFormalArg pn nth False True =<<rmNthArgInFunCall pn nth False ds+ ds'<-rmNthArgInSig pn nth =<<rmFormalArg pn nth True False ds+ rmNthArgInFunCall pn nth True (replaceDecls parent ds')++ -- just remove the nth formal parameter.+ rmFormalArg pn nth updateToks checking+ =applyTP (stop_tdTP (failTP `adhocTP` rmInMatch))++ where+ rmInMatch (match@(HsMatch loc fun pats rhs decls)::HsMatchP) --a formal parameter only exists in a match+ |pNTtoPN fun==pn+ =let pat=pats!!nth --get the nth formal parameter+ pNames=hsPNs pat --get all the names in this pat. (the pat may be just be a variable)+ in if checking && not ( all (==False) ((map (flip findPN rhs) pNames)) && --not used in rhs+ all (==False) ((map (flip findPN decls) pNames))) --not used in the where clause+ then error "This parameter can not be removed, as it is used!"+ else if updateToks+ then do pats'<-delete pat pats+ return (HsMatch loc fun pats' rhs decls)+ else return (HsMatch loc fun (pats\\[pat]) rhs decls)+ rmInMatch _=mzero+++--remove the nth argument of function pn in all the calling places. the index for the first argument is zero.+rmNthArgInFunCall pn nth updateToks=applyTP (stop_tdTP (failTP `adhocTP` funApp))+ where+ funApp (exp@(Exp (HsParen (Exp (HsApp e1 e2))))::HsExpP)+ |nth==0 && pn==expToPN e1+ =do if updateToks+ then do update exp e1 exp --handle the case like '(fun x) => fun "+ else return e1+ funApp (exp@(Exp (HsApp e1 e2))::HsExpP)+ |pn==(expToPN.(ghead "rmNthArgInFunCall").unfoldHsApp) exp --test if this application is a calling of fun pn.+ =do let (before,after)=splitAt (nth+1) (unfoldHsApp exp) --remove the nth argument+ if updateToks+ then delete (ghead "rmNthArgInFunCall" after) exp+ else return (foldHsApp (before++tail after)) --reconstruct the function application.++ funApp _=mzero++ --deconstruct a function application into a list of expressions.+ unfoldHsApp exp=+ case exp of+ (Exp (HsApp e1 e2))->(unfoldHsApp e1)++[e2]+ _ ->[exp]+ --reconstruct a function application by a list of expressions.+ foldHsApp exps=foldl1 (\e1 e2->(Exp (HsApp e1 e2))) exps+++rmNthArgInSig pn nth decls+ = let (before,after)=break (\d ->definesTypeSig pn d) decls+ in if after==[]+ then return decls+ else do newSig<-rmNthArgInSig' nth [(head after)] --no problem with 'head'+ return (before++newSig++(tail after))++ where rmNthArgInSig' nth sig@[(Dec (HsTypeSig loc is c tp))]+ =do let newSig=if length is ==1+ then --this type signature only defines the type of pn+ [Dec (HsTypeSig loc is c (rmNth tp))]+ else --this type signature also defines the type of other ids.+ [Dec (HsTypeSig loc (filter (\x->pNTtoPN x/=pn) is) c tp),+ Dec (HsTypeSig loc (filter (\x->pNTtoPN x==pn) is) c (rmNth tp))]+ update sig newSig sig++ rmNth tp=let (before,after)=splitAt nth (unfoldHsTypApp tp)+ in (foldHsTypApp (before ++ tail after))++ --deconstruct a type application into a list of types+ unfoldHsTypApp typ =+ case typ of (Typ (HsTyFun t1 t2)) ->t1:unfoldHsTypApp t2+ _ ->[typ]++ --reconstruct a type application by a list of type expression.+ foldHsTypApp ts=foldr1 (\t1 t2->(Typ (HsTyFun t1 t2))) ts++--get the function name and the index of the parameter to be removed from the cursor position.+getParam toks pos+ =(fromMaybe (defaultPNT, 0)).(applyTU (once_tdTU (failTU `adhocTU` inMatch)))+ where+ inMatch (match@(HsMatch loc fun pats rhs decls)::HsMatchP)+ |inRange pos (getStartEndLoc toks pats)+ =let paramPosRanges=map (getStartEndLoc toks) pats+ elem=find (inRange pos) paramPosRanges+ in if isNothing elem+ then error "Invalid cursor position!" -- cursor doesn't stop at a parameter position.+ else Just (fun, fromJust (elemIndex (fromJust elem) paramPosRanges))+ inMatch _=Nothing++ inRange pos (startPos,endPos)=pos>=startPos && pos<=endPos++rmParamInClientMod pnt nth (m, fileName)+ = do (inscps, exps, mod, ts) <-parseSourceFile fileName+ let qualifier = hsQualifier pnt inscps+ pn = pNTtoPN pnt+ if qualifier == []+ then return ((fileName,unmodified), (ts,mod))+ else do (mod',((ts',m), _)) <- runStateT (rmNthArgInFunCall pn nth True mod)+ ((ts,unmodified),(-1000,0))+ return ((fileName,m), (ts',mod'))++-}
src/Language/Haskell/Refact/Refactoring/DupDef.hs view
@@ -32,8 +32,7 @@ absFileName <- canonicalizePath fileName runRefacSession settings opts (comp absFileName newName (row,col)) -comp :: FilePath -> String -> SimpPos- -> RefactGhc [ApplyRefacResult]+comp :: FilePath -> String -> SimpPos -> RefactGhc [ApplyRefacResult] comp fileName newName (row, col) = do if isVarId newName then@@ -50,7 +49,7 @@ Just pn -> do logm $ "DupDef.comp:about to applyRefac for:pn=" ++ SYB.showData SYB.Parser 0 pn- (refactoredMod@((_fp,_ismod),(_anns',_parsed')),(isDone,nn)) <- applyRefac (doDuplicating pn newName) (RSFile fileName)+ (refactoredMod,(isDone,nn)) <- applyRefac (doDuplicating pn newName) (RSFile fileName) logm $ "DupDef.com:isDone=" ++ show isDone case isDone of DupDefFailed -> error "The selected identifier is not a function/simple pattern name, or is not defined in this module "
src/Language/Haskell/Refact/Refactoring/MoveDef.hs view
@@ -584,14 +584,14 @@ -> 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)+ -- 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'+ -- logm $ "moveDecl1:after rmDecl:t'" ++ SYB.showData SYB.Parser 0 t' let sigs = map wrapSig mliftedSigs r <- addDecl t' defName (sigs++mliftedDecls,Nothing) @@ -641,7 +641,17 @@ addParamsToParent _pn [] t = return t addParamsToParent pn params t = do logm $ "addParamsToParent:(pn,params)" ++ (showGhc (pn,params))- addActualParamsToRhs pn params t+ nm <- getRefactNameMap+ applyTP (full_buTP (idTP `adhocTP` (inExp nm))) t+ where+ inExp nm (e@(GHC.L l (GHC.HsVar n)) :: GHC.LHsExpr GHC.RdrName) = do+ 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
src/Language/Haskell/Refact/Utils/MonadFunctions.hs view
@@ -185,7 +185,7 @@ -- RefactGhc state. modifyRefactAnns :: (Anns -> Anns) -> RefactGhc () modifyRefactAnns f = do- logm $ "modifyRefactAnns:setting rsStreamModified"+ -- logm $ "modifyRefactAnns:setting rsStreamModified" st <- get mrm <- gets rsModule let rm = gfromJust "modifyRefactAnns" mrm
src/Language/Haskell/Refact/Utils/TypeUtils.hs view
@@ -75,7 +75,7 @@ -- * Program transformation -- ** Adding- ,addDecl, addItemsToImport, addHiding+ ,addDecl, addItemsToImport, addItemsToExport, addHiding ,addParamsToDecls, addActualParamsToRhs, addImportDecl, duplicateDecl -- ** Removing ,rmDecl, rmTypeSig, rmTypeSigs -- , commentOutTypeSig, rmParams@@ -985,14 +985,14 @@ where workerHsDecls :: forall t. HasDecls t => t -> RefactGhc t workerHsDecls parent' = do- logm $ "addDecl.appendDecl:(pn')=" ++ showGhc pn'+ -- logm $ "addDecl.appendDecl:(pn')=" ++ showGhc pn' liftT $ setDeclSpacing newDeclSig 2 0 nameMap <- getRefactNameMap decls <- liftT $ hsDecls parent' let (before,after) = break (definesDeclRdr nameMap pn') decls - logm $ "addDecl.appendDecl:(before,after)=" ++ showGhc (before,after)+ -- logm $ "addDecl.appendDecl:(before,after)=" ++ showGhc (before,after) let (decls1,decls2) = case after of [] -> (before,[]) _ -> (before ++ [ghead "appendDecl14" after],@@ -1222,18 +1222,92 @@ -- --------------------------------------------------------------------- +addItemsToExport ::+ GHC.ParsedSource -- The module AST.+ -> Maybe PName -- The condtion identifier.+ -> Bool -- Create an explicit list or not+ -> Either [String] [GHC.LIE GHC.RdrName] -- The identifiers to add in either String or HsExportEntP format.+ -> RefactGhc GHC.ParsedSource -- The result.+addItemsToExport = assert False undefined+{-++-- | Add identifiers to the export list of a module. If the second argument is like: Just p, then do the adding only if p occurs+-- in the export list, and the new identifiers are added right after p in the export list. Otherwise the new identifiers are add+-- to the beginning of the export list. In the case that the export list is emport, then if the third argument is True, then create+-- an explict export list to contain only the new identifiers, otherwise do nothing.+{-+addItemsToExport::( )+ => HsModuleP -- The module AST.+ -> Maybe PName -- The condtion identifier.+ -> Bool -- Create an explicit list or not+ -> Either [String] [HsExportEntP] -- The identifiers to add in either String or HsExportEntP format.+ -> m HsModuleP -- The result.+-}++addItemsToExport::(MonadState (([PosToken],Bool), t1) m)+ => HsModuleP -- The module AST.+ -> Maybe PName -- The condtion identifier.+ -> Bool -- Create an explicit list or not+ -> Either [String] [HsExportEntP] -- The identifiers to add in either String or HsExportEntP format.+ -> m HsModuleP -- The result.+++addItemsToExport mod _ _ (Left []) = return mod+addItemsToExport mod _ _ (Right []) = return mod+addItemsToExport mod@(HsModule loc modName exps imps ds) (Just pn) _ ids+ = case exps of+ Just ents ->let (e1,e2) = break (findEntity pn) ents+ in if e2 /=[]+ then do ((toks,_),others)<-get+ let e = (ghead "addVarItemInExport" e2)+ es = case ids of+ (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is'+ (Right es') -> es'+ let (_,endPos) = getStartEndLoc toks e+ (t, (_,s)) = ghead "addVarItemInExport" $ getToks (endPos,endPos) toks+ newToken = mkToken t endPos (s++","++ showEntities (render.ppi) es)+ toks' = replaceToks toks endPos endPos [newToken]+ put ((toks',modified),others)+ return (HsModule loc modName (Just (e1++(e:es)++tail e2)) imps ds)+ else return mod+ Nothing -> return mod++addItemsToExport mod@(HsModule _ _ (Just ents) _ _) Nothing createExp ids+ = do ((toks,_),others)<-get+ let es = case ids of+ (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is'+ (Right es') -> es'+ (t, (pos,s))=fromJust $ find isOpenBracket toks -- s is the '('+ newToken = if ents /=[] then (t, (pos,(s++showEntities (render.ppi) es++",")))+ else (t, (pos,(s++showEntities (render.ppi) es)))+ pos'= simpPos pos+ toks' = replaceToks toks pos' pos' [newToken]+ put ((toks',modified),others)+ return mod {hsModExports=Just (es++ ents)}++addItemsToExport mod@(HsModule _ (SN modName (SrcLoc _ c row col)) Nothing _ _) Nothing createExp ids+ =case createExp of+ True ->do ((toks,_),others)<-get+ let es = case ids of+ (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is'+ (Right es') -> es'+ pos = (row,col)+ newToken = mkToken Varid pos (modNameToStr modName++ "("+ ++ showEntities (render.ppi) es++")")+ toks' = replaceToks toks pos pos [newToken]+ put ((toks', modified), others)+ return mod {hsModExports=Just es}+ False ->return mod++-}+-- ---------------------------------------------------------------------+ addActualParamsToRhs :: (SYB.Data t) => GHC.Name -> [GHC.RdrName] -> t -> RefactGhc t addActualParamsToRhs pn paramPNames rhs = do logm $ "addActualParamsToRhs:entered:(pn,paramPNames)=" ++ showGhc (pn,paramPNames) nameMap <- getRefactNameMap let- -- |Limit the action to actual RHS elements- grhs :: (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) -> RefactGhc (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName))- grhs (GHC.GRHSs g lb) = do- g' <- SYB.everywhereMStaged SYB.Renamer (SYB.mkM worker) g- return (GHC.GRHSs g' lb)- worker :: (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.LHsExpr GHC.RdrName) worker oldExp@(GHC.L l2 (GHC.HsVar pname)) | eqRdrNamePure nameMap (GHC.L l2 pname) pn@@ -1260,7 +1334,7 @@ addSimpleAnnT expr' (DP (0,0)) [] return expr' - r <- applyTP (stop_tdTP (failTP `adhocTP` grhs)) rhs+ r <- applyTP (full_buTP (idTP `adhocTP` worker)) rhs return r {-@@ -1520,8 +1594,8 @@ doRmDeclList parent = do isDone <- getDone- logm $ "doRmDeclList:isDone=" ++ show isDone- logm $ "doRmDeclList:parent=" ++ SYB.showData SYB.Parser 0 parent+ -- logm $ "doRmDeclList:isDone=" ++ show isDone+ -- logm $ "doRmDeclList:parent=" ++ SYB.showData SYB.Parser 0 parent if isDone then return parent else do@@ -1535,7 +1609,7 @@ setStateStorage (StorageDeclRdr decl) decls' <- doRmDecl decls1 decls2 parent' <- liftT $ replaceDecls parent decls'- logDataWithAnns "doRmDeclList:(parent')" (parent')+ -- logDataWithAnns "doRmDeclList:(parent')" (parent') return parent' else do return parent@@ -1999,16 +2073,6 @@ let newNameStr = mkNewName (nameToString pn) (nub (f `union` d `union` ds)) 1 newName <- mkNewGhcName Nothing newNameStr renamePN pn newName False tt---- ------------------------------------------------------------------------- | Show a list of entities, the parameter f is a function that--- specifies how to format an entity.-showEntities:: (t->String) -> [t] ->String-showEntities _ [] = ""-showEntities f [pn] = f pn-showEntities f (pn:pns) =f pn ++ "," ++ showEntities f pns- -- ---------------------------------------------------------------------
src/Language/Haskell/Refact/Utils/Utils.hs view
@@ -44,17 +44,16 @@ import Language.Haskell.Refact.Utils.Monad import Language.Haskell.Refact.Utils.MonadFunctions import Language.Haskell.Refact.Utils.Types-import Language.Haskell.Refact.Utils.Variables import System.Directory import System.FilePath.Posix-import qualified Data.Generics as SYB import qualified Digraph as GHC import qualified DynFlags as GHC import qualified GHC as GHC-import qualified Outputable as GHC+-- import qualified Outputable as GHC -import qualified GHC.SYB.Utils as SYB+-- import qualified GHC.SYB.Utils as SYB+-- import qualified Data.Generics as SYB import qualified Data.Map as Map import qualified Data.Set as Set@@ -80,7 +79,9 @@ -- | Parse a single source file into a GHC session parseSourceFileGhc :: FilePath -> RefactGhc () parseSourceFileGhc targetFile = do+ logm $ "parseSourceFileGhc:targetFile=" ++ show targetFile setTargetSession targetFile+ logm $ "parseSourceFileGhc:after setTargetSession" graph <- GHC.getModuleGraph cgraph <- canonicalizeGraph graph cfileName <- liftIO $ canonicalizePath targetFile@@ -92,19 +93,35 @@ -- --------------------------------------------------------------------- setTargetSession :: FilePath -> RefactGhc ()-setTargetSession targetFile = RefactGhc $ GM.runGmlT' [Left targetFile] setDynFlags (return ())+-- setTargetSession targetFile = RefactGhc $ GM.runGmlT' [Left targetFile] setDynFlags (return ())+setTargetSession targetFile = RefactGhc $ GM.runGmlT' [Left targetFile] return (return ()) setDynFlags :: GHC.DynFlags -> GHC.Ghc GHC.DynFlags setDynFlags df = return (GHC.gopt_set df GHC.Opt_KeepRawTokenStream)+-- setDynFlags df = return df -- --------------------------------------------------------------------- +-- |For GHC 7.10.2, setting 'GHC.Opt_KeepRawTokenStream' prevents the pragmas at+-- the top of a source file from being read if there is a comment mixed in them+-- anywhere. To work around this, we need to inject that setting into the cached+-- dynflags in the 'GHC.ModSummary' before parsing it for refactoring, otherwise+-- all comments will be discarded.+-- See https://ghc.haskell.org/trac/ghc/ticket/10942+tweakModSummaryDynFlags :: GHC.ModSummary -> GHC.ModSummary+tweakModSummaryDynFlags ms =+ let df = GHC.ms_hspp_opts ms+ in ms { GHC.ms_hspp_opts = GHC.gopt_set df GHC.Opt_KeepRawTokenStream }++-- ---------------------------------------------------------------------+ -- | In the existing GHC session, put the requested TypeCheckedModule -- into the RefactGhc monad loadFromModSummary :: GHC.ModSummary -> RefactGhc () loadFromModSummary modSum = do logm $ "loadFromModSummary:modSum=" ++ show modSum- p <- GHC.parseModule modSum+ let modSumWithRaw = tweakModSummaryDynFlags modSum+ p <- GHC.parseModule modSumWithRaw t <- GHC.typecheckModule p -- dflags <- GHC.getDynFlags
test/MoveDefSpec.hs view
@@ -232,6 +232,16 @@ (show res) `shouldBe` "Just \"The identifier(s): (sq, test/testdata/LiftToToplevel/WhereIn2.hs:11:18) will cause name clash/capture or ambiguity occurrence problem after lifting, please do renaming first!\"" + -- ---------------------------------++ it "liftToTopLevel Collapse1 8 6" $ do+ r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Collapse1.hs" (8,6)+ -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/Collapse1.hs" (8,6)+ r' <- mapM makeRelativeToCurrentDirectory r+ (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/Collapse1.hs\"]"+ diff <- compareFiles "./test/testdata/LiftToToplevel/Collapse1.expected.hs"+ "./test/testdata/LiftToToplevel/Collapse1.refactored.hs"+ diff `shouldBe` [] {- original tests
test/RenamingSpec.hs view
@@ -598,5 +598,18 @@ (show r') `shouldBe` "[\"Renaming/RenameInExportedType2.hs\"]" -} + -- -----------------------------------------------------------------++ it "renames in ghc-mod with CPP" $ do+ pendingWith "get to the bottom of this"+ {-+ let cts = cdAndDo "/home/alanz/tmp/hackage/ghc-mod-5.4.0.0"+ r <- cts $ rename defaultTestSettings testOptions "Language/Haskell/GhcMod/Target.hs" "putNewSession2" (81,6)+ -- cdAndDo "/home/alanz/tmp/hackage/ghc-mod-5.4.0.0" $ rename logTestSettings testOptions "Language/Haskell/GhcMod/Target.hs" "putNewSession2" (81,6)++ r' <- ct $ mapM makeRelativeToCurrentDirectory r+ (show r') `shouldBe` "[\"Renaming/RenameInExportedType2.hs\"]"+ -}+ -- --------------------------------------------------------------------- -- Helper functions
test/UtilsSpec.hs view
@@ -84,6 +84,13 @@ (showGhc parsed) `shouldBe` "module BCpp where\nbob :: Int -> Int -> Int\nbob x y = x + y" -- ---------------------------------+ it "loads a file having a top comment and LANGUAGE CPP pragma" $ do+ t <- ct $ parsedFileGhc "./BCppTC.hs"++ let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t+ (showGhc parsed) `shouldBe` "module BCppTC where\nbob :: Int -> Int -> Int\nbob x y = x + y"++ -- --------------------------------- it "refactors a file having the LANGUAGE CPP pragma" $ do r <- ct $ roundTrip defaultTestSettings testOptions "BCpp.hs"
+ test/testdata/BCppTC.hs view
@@ -0,0 +1,17 @@+{-++A normal comment, to check if we can still pick up the CPP directive after it.++-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+-- Check that we can parse a file which requires CPP+module BCppTC where++bob :: Int -> Int -> Int+#if __GLASGOW_HASKELL__ > 704+bob x y = x + y+#else+bob x y = x + y * 2+#endif+
+ test/testdata/LiftToToplevel/Collapse1.expected.hs view
@@ -0,0 +1,16 @@+module LiftToTop3evel.Collapse1 where++collapse' _ _ [] = []+collapse' left space (t:ts) = new : collapse' right space rest+ where+ (_, leftInner) = left+ rightInner = leftInner + symbolSize t+ right = (rightInner, (rightOuter rightInner rights))+ (rights, rest) = span space ts+ new = (t, Bounds left right)++rightOuter rightInner rights = rightInner + symbolSize rights++data Bounds = Bounds (Int,Int) (Int,Int)+symbolSize t = 4+
+ test/testdata/LiftToToplevel/Collapse1.hs view
@@ -0,0 +1,15 @@+module LiftToTop3evel.Collapse1 where++collapse' _ _ [] = []+collapse' left space (t:ts) = new : collapse' right space rest+ where+ (_, leftInner) = left+ rightInner = leftInner + symbolSize t+ rightOuter = rightInner + symbolSize rights+ right = (rightInner, rightOuter)+ (rights, rest) = span space ts+ new = (t, Bounds left right)++data Bounds = Bounds (Int,Int) (Int,Int)+symbolSize t = 4+