diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -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 diff --git a/HaRe.cabal b/HaRe.cabal --- a/HaRe.cabal +++ b/HaRe.cabal @@ -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 diff --git a/src/Language/Haskell/Refact/API.hs b/src/Language/Haskell/Refact/API.hs --- a/src/Language/Haskell/Refact/API.hs +++ b/src/Language/Haskell/Refact/API.hs @@ -155,7 +155,7 @@ -- * Program transformation -- *** Adding - ,addDecl, addItemsToImport, addHiding + ,addDecl, addItemsToImport, addItemsToExport, addHiding ,addParamsToDecls, addActualParamsToRhs, addImportDecl, duplicateDecl -- , moveDecl -- *** Removing ,rmDecl, rmTypeSig, rmTypeSigs diff --git a/src/Language/Haskell/Refact/Refactoring/AddRmParam.hs b/src/Language/Haskell/Refact/Refactoring/AddRmParam.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Refactoring/AddRmParam.hs @@ -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 =< 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')) + +-} diff --git a/src/Language/Haskell/Refact/Refactoring/DupDef.hs b/src/Language/Haskell/Refact/Refactoring/DupDef.hs --- a/src/Language/Haskell/Refact/Refactoring/DupDef.hs +++ b/src/Language/Haskell/Refact/Refactoring/DupDef.hs @@ -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 " diff --git a/src/Language/Haskell/Refact/Refactoring/MoveDef.hs b/src/Language/Haskell/Refact/Refactoring/MoveDef.hs --- a/src/Language/Haskell/Refact/Refactoring/MoveDef.hs +++ b/src/Language/Haskell/Refact/Refactoring/MoveDef.hs @@ -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 diff --git a/src/Language/Haskell/Refact/Utils/MonadFunctions.hs b/src/Language/Haskell/Refact/Utils/MonadFunctions.hs --- a/src/Language/Haskell/Refact/Utils/MonadFunctions.hs +++ b/src/Language/Haskell/Refact/Utils/MonadFunctions.hs @@ -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 diff --git a/src/Language/Haskell/Refact/Utils/TypeUtils.hs b/src/Language/Haskell/Refact/Utils/TypeUtils.hs --- a/src/Language/Haskell/Refact/Utils/TypeUtils.hs +++ b/src/Language/Haskell/Refact/Utils/TypeUtils.hs @@ -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 - -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/Utils.hs b/src/Language/Haskell/Refact/Utils/Utils.hs --- a/src/Language/Haskell/Refact/Utils/Utils.hs +++ b/src/Language/Haskell/Refact/Utils/Utils.hs @@ -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 diff --git a/test/MoveDefSpec.hs b/test/MoveDefSpec.hs --- a/test/MoveDefSpec.hs +++ b/test/MoveDefSpec.hs @@ -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 diff --git a/test/RenamingSpec.hs b/test/RenamingSpec.hs --- a/test/RenamingSpec.hs +++ b/test/RenamingSpec.hs @@ -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 diff --git a/test/UtilsSpec.hs b/test/UtilsSpec.hs --- a/test/UtilsSpec.hs +++ b/test/UtilsSpec.hs @@ -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" diff --git a/test/testdata/BCppTC.hs b/test/testdata/BCppTC.hs new file mode 100644 --- /dev/null +++ b/test/testdata/BCppTC.hs @@ -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 + diff --git a/test/testdata/LiftToToplevel/Collapse1.expected.hs b/test/testdata/LiftToToplevel/Collapse1.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/Collapse1.expected.hs @@ -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 + diff --git a/test/testdata/LiftToToplevel/Collapse1.hs b/test/testdata/LiftToToplevel/Collapse1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/Collapse1.hs @@ -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 +