diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,5 @@ +2014-03-17 v0.7.1.5 + * Adding parameters to lifted declarations now works as expected 2014-03-09 v0.7.1.4 * Load and process files using TH and/or QuasiQuotes * Make loading of multiple targets from a cabal file more robust diff --git a/HaRe.cabal b/HaRe.cabal --- a/HaRe.cabal +++ b/HaRe.cabal @@ -1,5 +1,5 @@ Name: HaRe -Version: 0.7.1.4 +Version: 0.7.1.5 Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer: Alan Zimmerman Stability: Alpha @@ -18,24 +18,10 @@ . Warning: This is alpha code. Always commit code to your version control system before refactoring. The developers make no - warranties, use at your own risk. May frighten children and dogs. + warranties, use at your own risk. . The renaming refactoring seems reasonably reliable. . - Current known defects: - . - * liftToTopLevel of a recursive function may introduce parameter - errors. e.g. lifting 'g' in the 'zmapQ' function from 'syz-0.2.0.0' - 'Data.Generics.Zipper' results in the following - . - > zmapQ f z = reverse $ downQ [] g z where - > g z' = query f z' : leftQ [] g z' - . - becomes - . - > zmapQ f z = reverse $ downQ [] (g f g)z - > - > g f z'g= query f z' : leftQ [] (g f g)g f g)z' Synopsis: the Haskell Refactorer. Category: Development, Refactoring diff --git a/src/Language/Haskell/Refact/MoveDef.hs b/src/Language/Haskell/Refact/MoveDef.hs --- a/src/Language/Haskell/Refact/MoveDef.hs +++ b/src/Language/Haskell/Refact/MoveDef.hs @@ -220,7 +220,7 @@ -> RefactGhc [ApplyRefacResult] liftToTopLevel' modName pn@(GHC.L _ n) = do renamed <- getRefactRenamed - -- logm $ "liftToTopLevel':renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++ + logm $ "liftToTopLevel':renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++ logm $ "liftToTopLevel':pn=" ++ (showGhc pn) if isLocalFunOrPatName n renamed then do @@ -238,62 +238,68 @@ 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 introduce. - step4. test whether there are any names need to be renamed. - -} + {-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 introduce. + step4. test whether there are any names need to be renamed. + -} liftToMod = do - renamed <- getRefactRenamed - let declsr = hsBinds renamed - let (before,parent,after) = divideDecls declsr pn - -- error ("liftToMod:(before,parent,after)=" ++ (showGhc (before,parent,after))) -- ++AZ++ - {- ++AZ++ : 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!" - -} - let liftedDecls = definingDeclsNames [n] parent True True - declaredPns = nub $ concatMap definedPNs liftedDecls + renamed <- getRefactRenamed + let declsr = hsBinds renamed + let (before,parent,after) = divideDecls declsr pn + -- error ("liftToMod:(before,parent,after)=" ++ (showGhc (before,parent,after))) -- ++AZ++ + {- ++AZ++ : 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!" + -} + let liftedDecls = definingDeclsNames [n] parent True True + declaredPns = nub $ concatMap definedPNs liftedDecls - -- TODO: what about declarations between this - -- one and the top level that are used in this one? + -- TODO: what about declarations between this + -- one and the top level that are used in this one? - logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns)) - -- original : pns<-pnsNeedRenaming inscps mod parent liftedDecls declaredPns - pns <- pnsNeedRenaming renamed parent liftedDecls declaredPns + logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns)) + -- original : pns<-pnsNeedRenaming inscps mod parent liftedDecls declaredPns + pns <- pnsNeedRenaming renamed parent liftedDecls declaredPns - -- (_,dd) <- hsFreeAndDeclaredPNs renamed - let dd = getDeclaredVars $ hsBinds renamed - logm $ "liftToMod:(ddd)=" ++ (showGhc dd) + -- (_,dd) <- hsFreeAndDeclaredPNs renamed + let dd = getDeclaredVars $ hsBinds renamed + logm $ "liftToMod:(ddd)=" ++ (showGhc dd) - drawTokenTree "liftToMod.a" + -- drawTokenTree "liftToMod.a" - if pns==[] - then do (parent',_liftedDecls',_paramAdded)<-addParamsToParentAndLiftedDecl n dd parent liftedDecls - -- let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls' - -- else liftedDecls' + if pns==[] + then do + -- TODO: change the order, first move the decls then add params, + -- else the liftedDecls get mangled while still in the parent + (parent',liftedDecls',_paramAdded) <- addParamsToParentAndLiftedDecl n dd parent liftedDecls + -- let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls' + -- else liftedDecls' - drawTokenTree "liftToMod.c" - logm $ "liftToMod:(declaredPns)=" ++ (showGhc declaredPns) + -- drawTokenTree "liftToMod.c" + -- logm $ "liftToMod:(declaredPns)=" ++ (showGhc declaredPns) + -- logm $ "liftToMod:(liftedDecls')=" ++ (showGhc liftedDecls') - -- error ("liftToMod:newBinds=" ++ (showGhc (replaceBinds declsr (before++parent'++after)))) -- ++AZ++ - void $ moveDecl1 (replaceBinds renamed (before++parent'++after)) - (Just (ghead "liftToMod" (definedPNs (ghead "liftToMod2" parent')))) - [GHC.unLoc pn] declaredPns True + -- error ("liftToMod:newBinds=" ++ (showGhc (replaceBinds declsr (before++parent'++after)))) -- ++AZ++ - drawTokenTree "liftToMod.b" + void $ moveDecl1 (replaceBinds renamed (before++parent'++after)) + (Just (ghead "liftToMod" (definedPNs (ghead "liftToMod2" parent')))) + [GHC.unLoc pn] (Just liftedDecls') declaredPns True - return declaredPns + -- drawTokenTree "liftToMod.b" - else askRenamingMsg pns "lifting" + return declaredPns + else askRenamingMsg pns "lifting" --- TODO: move this to TypeUtils, as moveDecl + +-- --------------------------------------------------------------------- + moveDecl1 :: (HsValBinds t) => t -- ^ The syntax element to update -> Maybe GHC.Name -- ^ If specified, add defn after this one @@ -301,62 +307,60 @@ -- TODO: make this next parameter a single value, not a list, -- after module complete -> [GHC.Name] -- ^ The first one is the decl to move + -> Maybe [GHC.LHsBind GHC.Name] -> [GHC.Name] -- ^ The signatures to remove. May be multiple if -- decl being moved has a patbind. -> Bool -- ^ True if moving to the top level -> RefactGhc t -- ^ The updated syntax element (and tokens in monad) -moveDecl1 t defName ns sigNames topLevel - = do - -- logm $ "moveDecl1:t=" ++ (SYB.showData SYB.Renamer 0 t) -- ++AZ++ - -- TODO: work with all of ns, not just the first - let n = ghead "moveDecl1" ns - -- let funBinding = definingDeclsNames [n] (hsBinds t) True True - let funBinding = definingDeclsNames' [n] t - - logm $ "moveDecl1: (ns,funBinding)=" ++ (showGhc (ns,funBinding)) -- ++AZ++ - - let Just sspan = getSrcSpan funBinding - -- drawTokenTree "before getting toks" -- ++AZ++ - funToks <- getToksForSpan sspan - logm $ "moveDecl1:funToks=" ++ (showToks funToks) - -- drawTokenTree "moveDecl1:after getting toks" -- ++AZ++ 'in' present - --- drawTokenTreeDetailed "moveDecl1:after getting toks" -- ++AZ++ +moveDecl1 t defName ns mliftedDecls sigNames topLevel = do + -- logm $ "moveDecl1:t=" ++ (SYB.showData SYB.Renamer 0 t) -- ++AZ++ + logm $ "moveDecl1:mliftedDecls=" ++ (showGhc mliftedDecls) + drawTokenTree "moveDecl1 on entry" - -- (t'',sigsRemoved) <- rmTypeSigs ns t - (t'',sigsRemoved) <- rmTypeSigs sigNames t - -- drawTokenTree "moveDecl1:after rmTypeSigs" -- ++AZ++ - -- drawTokenTreeDetailed "moveDecl1:after rmTypeSigs" -- ++AZ++ - -- logm $ "moveDecl1:t''=" ++ (SYB.showData SYB.Renamer 0 t'') -- ++AZ++ - (t',_declRemoved,_sigRemoved) <- rmDecl (ghead "moveDecl3.1" ns) False t'' - -- logm $ "moveDecl1:t'=" ++ (SYB.showData SYB.Renamer 0 t') -- ++AZ++ - -- drawTokenTree "moveDecl1:after rmDecl" -- ++AZ++ - -- drawTokenTreeDetailed "moveDecl1:after rmDecl" -- ++AZ++ 'in' missing + -- TODO: work with all of ns, not just the first + let n = ghead "moveDecl1" ns + -- let funBinding = definingDeclsNames [n] (hsBinds t) True True + let funBinding = case mliftedDecls of + Nothing -> definingDeclsNames' [n] t + Just liftedDecls -> liftedDecls - let getToksForMaybeSig (GHC.L ss _) = - do - sigToks <- getToksForSpan ss - return sigToks + logm $ "moveDecl1: (ns,funBinding)=" ++ (showGhc (ns,funBinding)) -- ++AZ++ - -- maybeToksSigMulti <- mapM getToksForMaybeSig sigsRemoved - maybeToksSigMulti <- mapM getToksForMaybeSig - $ sortBy (\(GHC.L s1 _) (GHC.L s2 _) -> compare (srcSpanToForestSpan s1) (srcSpanToForestSpan s2)) - sigsRemoved - let maybeToksSig = concat maybeToksSigMulti + let Just sspan = getSrcSpan funBinding + -- drawTokenTree "before getting toks" -- ++AZ++ + funToks <- getToksForSpan sspan + logm $ "moveDecl1:funToks=" ++ (showToks funToks) + -- drawTokenTree "moveDecl1:after getting toks" -- ++AZ++ 'in' present + --- drawTokenTreeDetailed "moveDecl1:after getting toks" -- ++AZ++ - logm $ "moveDecl1:maybeToksSig=" ++ (show maybeToksSig) -- ++AZ++ - logm $ "moveDecl1:(defName,topLevel)" ++ (showGhc (defName,topLevel)) -- ++AZ++ + -- (t'',sigsRemoved) <- rmTypeSigs ns t + (t'',sigsRemoved) <- rmTypeSigs sigNames t + -- drawTokenTree "moveDecl1:after rmTypeSigs" -- ++AZ++ + -- drawTokenTreeDetailed "moveDecl1:after rmTypeSigs" -- ++AZ++ + -- logm $ "moveDecl1:t''=" ++ (SYB.showData SYB.Renamer 0 t'') -- ++AZ++ + (t',_declRemoved,_sigRemoved) <- rmDecl (ghead "moveDecl3.1" ns) False t'' + -- logm $ "moveDecl1:t'=" ++ (SYB.showData SYB.Renamer 0 t') -- ++AZ++ + -- drawTokenTree "moveDecl1:after rmDecl" -- ++AZ++ + -- drawTokenTreeDetailed "moveDecl1:after rmDecl" -- ++AZ++ 'in' missing - addDecl t' defName (ghead "moveDecl1 2" funBinding,sigsRemoved,Just (maybeToksSig ++ funToks)) topLevel + let getToksForMaybeSig (GHC.L ss _) = + do + sigToks <- getToksForSpan ss + return sigToks + -- maybeToksSigMulti <- mapM getToksForMaybeSig sigsRemoved + maybeToksSigMulti <- mapM getToksForMaybeSig + $ sortBy (\(GHC.L s1 _) (GHC.L s2 _) -> compare (srcSpanToForestSpan s1) (srcSpanToForestSpan s2)) + sigsRemoved + let maybeToksSig = concat maybeToksSigMulti + logm $ "moveDecl1:maybeToksSig=" ++ (show maybeToksSig) -- ++AZ++ + logm $ "moveDecl1:(defName,topLevel)" ++ (showGhc (defName,topLevel)) -- ++AZ++ -{- ---get all the declarations define in the scope of t -allDeclsIn t = fromMaybe [] (applyTU (full_tdTU (constTU [] `adhocTU` decl)) t) - where decl (d::HsDeclP) - |isFunBind d || isPatBind d || isTypeSig d = Just [d] - decl _ = Just [] --} + drawTokenTree "moveDecl1 about to addDecl" + r <- addDecl t' defName (ghead "moveDecl1 2" funBinding,sigsRemoved,Just (maybeToksSig ++ funToks)) topLevel + drawTokenTree "moveDecl1 done" + return r askRenamingMsg :: [GHC.Name] -> String -> t @@ -398,9 +402,7 @@ addParamsToParent _pn [] t = return t addParamsToParent pn params t = do logm $ "addParamsToParent:(pn,params)" ++ (showGhc (pn,params)) - t' <- addActualParamsToRhs True pn params t - -- drawTokenTreeDetailed "addParamsToParent done" - return t' + addActualParamsToRhs True pn params t -- |Do refactoring in the client module. that is to hide the identifer @@ -728,14 +730,14 @@ logm $ "MoveDef.worker: pns=" ++ (showGhc pns) if pns==[] then do - (parent',_liftedDecls',_paramAdded)<-addParamsToParentAndLiftedDecl n dd + (parent',liftedDecls',_paramAdded)<-addParamsToParentAndLiftedDecl n dd parent liftedDecls -- let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls' -- else liftedDecls' --True means the new decl will be at the same level with its parant. - dest'<-moveDecl1 (replaceBinds dest (before++parent'++after)) + dest' <- moveDecl1 (replaceBinds dest (before++parent'++after)) (Just (ghead "worker" (definedPNs (ghead "worker" parent')))) - [n] declaredPns toToplevel -- False -- ++AZ++ TODO: should be True for toplevel move + [n] (Just liftedDecls') declaredPns toToplevel -- False -- ++AZ++ TODO: should be True for toplevel move return dest' --parent'<-doMoving declaredPns (ghead "worker" parent) True paramAdded parent' --return (before++parent'++liftedDecls''++after) @@ -772,7 +774,7 @@ logm $ "MoveDef.worker1: pns=" ++ (showGhc pns) if pns==[] then do - (dest',_liftedDecls',_paramAdded) + (parent',liftedDecls',_paramAdded) -- <- addParamsToParentAndLiftedDecl n dd decl liftedDecls <- addParamsToParentAndLiftedDecl n dd dest liftedDecls -- let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls' @@ -780,9 +782,9 @@ -- logm $ "MoveDef.worker1:liftedDecls''=" ++ (showGhc liftedDecls'') -- logm $ "MoveDef.worker1:dest'=" ++ (SYB.showData SYB.Renamer 0 dest') --True means the new decl will be at the same level with its parant. - dest''<-moveDecl1 dest' Nothing - [n] declaredPns toToplevel -- False -- ++AZ++ TODO: should be True for toplevel move - return dest'' + parent'' <- moveDecl1 parent' Nothing + [n] (Just liftedDecls') declaredPns toToplevel -- False -- ++AZ++ TODO: should be True for toplevel move + return parent'' --decl'<-doMoving declaredPns (ghead "worker" decl) True paramAdded decl' --return (before++decl'++liftedDecls''++after) else askRenamingMsg pns "lifting" @@ -799,10 +801,10 @@ addParamsToParentAndLiftedDecl :: (HsValBinds t,GHC.Outputable t) => - GHC.Name + GHC.Name -- name of decl being lifted -> [GHC.Name] -- ^Declared names in parent - -> t - -> [GHC.LHsBind GHC.Name] + -> t -- parent + -> [GHC.LHsBind GHC.Name] -- decls being lifted -> RefactGhc (t, [GHC.LHsBind GHC.Name], Bool) addParamsToParentAndLiftedDecl pn dd parent liftedDecls =do (ef,_) <- hsFreeAndDeclaredPNs parent @@ -810,20 +812,29 @@ logm $ "addParamsToParentAndLiftedDecl:parent=" ++ (showGhc parent) - let eff = getFreeVars $ hsBinds parent - let lff = getFreeVars liftedDecls - logm $ "addParamsToParentAndLiftedDecl:(ef,lf)=" ++ (showGhc (ef,lf)) - logm $ "addParamsToParentAndLiftedDecl:(eff,lff)=" ++ (showGhc (eff,lff)) - logm $ "addParamsToParentAndLiftedDecl:(dd)=" ++ (showGhc dd) + -- parameters to be added to pn because of lifting + let newParams=((nub lf) \\ (nub ef)) \\ dd - let newParams=((nub lf)\\ (nub ef)) \\ dd --parameters (in PName format) to be added to pn because of lifting - -- let newParams=((nub lff)\\ (nub eff)) \\ dd --parameters (in PName format) to be added to pn because of lifting logm $ "addParamsToParentAndLiftedDecl:(newParams,ef,lf,dd)=" ++ (showGhc (newParams,ef,lf,dd)) - if newParams/=[] + + if newParams /= [] then if (any isComplexPatBind liftedDecls) then error "This pattern binding cannot be lifted, as it uses some other local bindings!" - else do parent' <- addParamsToParent pn newParams parent - liftedDecls'<-addParamsToDecls liftedDecls pn newParams True + else do -- first remove the decls to be lifted, so they are not disturbed + (parent'',liftedDecls'',_msig) <- rmDecl pn False parent + drawTokenTree "addParamsToParentAndLiftedDecl: rmDecl done" + logm $ "addParamsToParentAndLiftedDecl:parent''=" ++ (SYB.showData SYB.Renamer 0 parent'') + logm $ "addParamsToParentAndLiftedDecl:parent''=" ++ (showGhc parent'') + + parent' <- addParamsToParent pn newParams parent'' + -- let parent' = parent + logm $ "addParamsToParentAndLiftedDecl: parent done" + drawTokenTree "addParamsToParentAndLiftedDecl: parent params done" + + liftedDecls' <- addParamsToDecls [liftedDecls''] pn newParams True + logm $ "addParamsToParentAndLiftedDecl: liftedDecls done" + drawTokenTree "addParamsToParentAndLiftedDecl: liftedDecls done" + return (parent', liftedDecls',True) else return (parent,liftedDecls,False) @@ -1188,7 +1199,7 @@ -- rhs' <- moveDecl pns rhs False decls False -- TODO: what wbout dtoks? -- error "dupInPat" -- ++AZ++ - rhs' <- moveDecl1 rhs Nothing pns pns False + rhs' <- moveDecl1 rhs Nothing pns Nothing pns False return (GHC.PatBind pat rhs' ty fvs ticks) -- dupInPat _ =mzero dupInPat x = return x @@ -1205,12 +1216,7 @@ => GHC.Name -> t -- -> RefactGhc [GHC.Name] -> RefactGhc [GHC.Name] -{- - declaredNamesInTargetPlace pn - = SYB.everythingStaged SYB.Renamer (++) [] - ([] `SYB.mkQ` inMatch - `SYB.extQ` inPat) --} + declaredNamesInTargetPlace pn' t' = do logm $ "declaredNamesInTargetPlace:pn=" ++ (showGhc pn') res <- applyTU (stop_tdTUGhc (failTU @@ -1240,20 +1246,7 @@ inPat _= return mzero -{- - inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP) - | findPN pn rhs - =(return.snd)=<elem ({- pNtoName -} x) newNames) --Attention: nub ( nub (d `union` (nub.concat) ds'))) - {- - getClashedNames oldNames newNames (match::HsMatchP) - = do (f,d)<-hsFDsFromInside match - ds'<-mapM (flip hsVisiblePNs match) oldNames - -- 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 :: [GHC.LPat GHC.Name] -> [[GHC.HsExpr GHC.Name]] -> [(GHC.Name,GHC.HsExpr GHC.Name)] mkSubst pats1 params = catMaybes (zipWith (\x y -> if (patToPNT x/=Nothing) && (length (nub $ map showGhc y)==1) then Just (gfromJust "mkSubst" $ patToPNT x,(ghead "mkSubst") y) else Nothing) pats1 params) - {- - = catMaybes (zipWith (\x y ->if (patToPN x/=defaultPN) && (length (nub y)==1) - then Just (patToPN x,(ghead "mkSubst") y) - else Nothing) pats params) - -} -- |substitute an old expression by new expression @@ -1553,30 +1534,21 @@ worker x=return x - -- | return True if pn is a local function/pattern name isLocalFunOrPatName :: SYB.Data t => GHC.Name -> t -> Bool isLocalFunOrPatName pn scope = isLocalPN pn && isFunOrPatName pn scope -{- --- |removeTypeSig removes the signature declaration for pn from the decl list. --- removeTypeSig :: GHC.Name->[HsDeclP]->[HsDeclP] -removeTypeSig pn decls = decls - -- ++ AZ++ TODO: make use of rmTypeSig pn decls from TypeUtils --} +-- --------------------------------------------------------------------- -- |Divide a declaration list into three parts (before, parent, after) -- according to the PNT, where 'parent' is the first decl containing -- the PNT, 'before' are those decls before 'parent' and 'after' are -- those decls after 'parent'. --- ++AZ++ : Not sure if this is meaningful with renamed source. - --- divideDecls::[HsDeclP]->PNT->([HsDeclP],[HsDeclP],[HsDeclP]) divideDecls :: - SYB.Data a => - [a] -> GHC.Located GHC.Name -> ([a], [a], [a]) + SYB.Data t => + [t] -> GHC.Located GHC.Name -> ([t], [t], [t]) divideDecls ds pnt -- = error "undefined divideDecls" = let (before,after)=break (\x->findPNT pnt x) ds diff --git a/src/Language/Haskell/Refact/Utils/DualTree.hs b/src/Language/Haskell/Refact/Utils/DualTree.hs --- a/src/Language/Haskell/Refact/Utils/DualTree.hs +++ b/src/Language/Haskell/Refact/Utils/DualTree.hs @@ -242,6 +242,8 @@ go ci ((Line r c _o _f _s str):ls') = do newPos r (c+ci) addString (GHC.showRichTokenStream str) + -- addString (GHC.showRichTokenStream $ reAlignMarked str) + -- addString (GHC.showRichTokenStream $ reAlignMarked str) go ci ls' -- State operations ---------------- diff --git a/src/Language/Haskell/Refact/Utils/Layout.hs b/src/Language/Haskell/Refact/Utils/Layout.hs --- a/src/Language/Haskell/Refact/Utils/Layout.hs +++ b/src/Language/Haskell/Refact/Utils/Layout.hs @@ -619,11 +619,19 @@ typeLayout = strip $ (makeLeafFromToks t1) ++ allocType typ typToks (s3,rhsToks,bindsToks) = splitToksForList rhs toks' - patLayout = allocList pats patsToks allocPat + -- patLayout = allocList pats patsToks allocPat + + -- Insert a SrcSpan over the parameters, if there are any + patLayout = case (strip $ allocList pats patsToks allocPat) of + [] -> [] + ps -> [makeGroup ps] + grhsLayout = allocGRHSs grhs (rhsToks++bindsToks) matchLayout = [makeGroup $ strip $ (makeLeafFromToks s2) - ++ patLayout ++ mtypLayout - ++ (makeLeafFromToks s3) ++ grhsLayout + ++ patLayout + ++ mtypLayout + ++ (makeLeafFromToks s3) + ++ grhsLayout ] r = (strip $ (makeLeafFromToks sb) ++ matchLayout @@ -1816,13 +1824,15 @@ -- --------------------------------------------------------------------- -allocList :: [GHC.Located b] -> [PosToken] +allocList :: + [GHC.Located b] + -> [PosToken] -> (GHC.Located b -> [PosToken] -> [LayoutTree]) -> [LayoutTree] allocList xs toksIn allocFunc = r where (s2,listToks,toks2') = splitToksForList xs toksIn - (layout,toks2) = ((makeLeafFromToks s2) ++ allocAll xs listToks,toks2') + (layout,toks2) = (allocAll xs listToks,toks2') allocAll xs' toks = res where @@ -1837,7 +1847,8 @@ layout' = (makeLeafFromToks s1) ++ [makeGroup (strip $ allocFunc x funcToks)] r1 = (acc ++ (strip layout'),toks') - r = strip $ layout ++ (makeLeafFromToks toks2) + -- r = strip $ (makeLeafFromToks s2) ++ layout ++ (makeLeafFromToks toks2) + r = strip $ (makeLeafFromToks s2) ++ [makeGroup $ strip $ layout] ++ (makeLeafFromToks toks2) -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/LocUtils.hs b/src/Language/Haskell/Refact/Utils/LocUtils.hs --- a/src/Language/Haskell/Refact/Utils/LocUtils.hs +++ b/src/Language/Haskell/Refact/Utils/LocUtils.hs @@ -50,10 +50,6 @@ {-, prettyprint ,deleteFromToks, prettyprintGuardsAlt, -} - {-, addFormalParams -} {- , adjustOffset, -- try to remove it - StartEndLoc, isArrow,-- swapInToks, - commentToks - -} , tokenise , basicTokenise , lexStringToRichTokens @@ -112,6 +108,7 @@ , isMarked , addOffsetToToks , matchTokenPos + , rmOffsetFromToks ) where @@ -507,46 +504,7 @@ -- error $ "getToks:startPos=" ++ (show startPos) ++ ",endPos=" ++ (show endPos) ++ ",toks21=" ++ (showToks toks21) -- ++AZ++ debug -- --------------------------------------------------------------------- -{- --- | Add tokens corresponding to the new parameters to the end of the --- syntax element provided -addFormalParams :: (SYB.Data t, SYB.Typeable t) => - t -> [GHC.Located (GHC.Pat GHC.Name)] -> RefactGhc () -addFormalParams t newParams - = do - let (startPos,endPos) = getStartEndLoc t - newToks <- liftIO $ basicTokenise (prettyprintPatList prettyprint True newParams) - -- error $ "addFormalParams:newToks=" ++ (showToks newToks) -- ++AZ++ - _ <- putToksAfterPos (startPos,endPos) PlaceAdjacent $ map markToken newToks - - return () --} --- --------------------------------------------------------------------- - -{- --- |Replace a list of tokens in the token stream by a new list of --- tokens, adjust the layout as well. To use this function make sure --- the start and end positions really exist in the token stream. --- QN: what happens if the start or end position does not exist? - --- TODO: ++AZ++ pretty sure this should be deprecated -replaceToks::[PosToken]->SimpPos->SimpPos->[PosToken]->[PosToken] -replaceToks toks startPos endPos newToks = - -- error $ "replaceToks: startPos=" ++ (show startPos) - (if length toks22 == 0 - then toks1 ++ newToks' - else let {-(pos::(Int,Int)) = tokenPos (ghead "replaceToks" toks22)-} -- JULIEN - -- oldOffset = {-getOffset toks pos -} lengthOfLastLine (toks1++toks21) --JULIEN - -- newOffset = {-getOffset (toks1++newToks'++ toks22) pos -} lengthOfLastLine (toks1++newToks) -- JULIEN - in toks1 ++ (newToks' ++ toks22)) -- adjustLayout toks22 oldOffset newOffset) ) - where - (toks1, _toks21, toks22) = splitToks (startPos, endPos) toks - newToks' = map markToken newToks --} - --- --------------------------------------------------------------------- - -- |Replace a single token in the token stream by a new token, without -- adjusting the layout. -- Note1: does not re-align, else other later replacements may fail. @@ -614,24 +572,6 @@ {- ----REFACTORING: GENERALISE THIS FUNCTION. -addFormalParams t newParams - = do ((toks,_),(v1, v2))<-get - let (startPos,endPos) = getStartEndLoc toks t - tToks = getToks (startPos, endPos) toks - (toks1, _) = let (toks1', toks2') = break (\t-> tokenPos t == endPos) toks - in (toks1' ++ [ghead "addFormalParams" toks2'], gtail "addFormalParams" toks2') - offset = lengthOfLastLine toks1 - newToks = tokenise (Pos 0 v1 1) offset False (prettyprintPatList True newParams ) - toks' = replaceToks toks startPos endPos (tToks++newToks) - put ((toks',modified), ((tokenRow (glast "addFormalParams" newToks) -10), v2)) - addLocInfo (newParams, newToks) --} - - - - -{- {- Delete an syntax phrase from the token stream, this function (instead of the following one) should be the interface function for deleting tokens. -} @@ -1503,6 +1443,17 @@ case l of GHC.RealSrcSpan ss -> GHC.srcSpanFile ss == tokenFileMark _ -> False + +-- --------------------------------------------------------------------- + +rmOffsetFromToks :: [PosToken] -> [PosToken] +rmOffsetFromToks [] = [] +rmOffsetFromToks toks = toks' + where + ro' = tokenRow $ head toks + co' = tokenCol $ head toks + -- (ro,co) = srcPosToSimpPos (tokenRow $ head toks, tokenCol $ head toks) + toks' = addOffsetToToks (-ro',-co') toks -- --------------------------------------------------------------------- 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 @@ -30,6 +30,7 @@ -- * TokenUtils API , replaceToken , putToksForSpan + , putDeclToksForSpan , getToksForSpan , getToksForSpanNoInv , getToksForSpanWithIntros @@ -227,6 +228,19 @@ let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True }) put $ st { rsModule = rsModule' } return newSpan + +-- |Replace the tokens for a given GHC.SrcSpan, return new GHC.SrcSpan +-- delimiting new tokens, and update the AST fragment to reflect it +putDeclToksForSpan :: (SYB.Data t) => GHC.SrcSpan -> GHC.Located t -> [PosToken] + -> RefactGhc (GHC.SrcSpan,GHC.Located t) +putDeclToksForSpan sspan t toks = do + logm $ "putDeclToksForSpan " ++ (showGhc sspan) ++ ":" ++ (showSrcSpanF sspan) ++ (show toks) + st <- get + let Just tm = rsModule st + let (tk',newSpan,t') = putDeclToksInCache (rsTokenCache tm) sspan toks t + let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True }) + put $ st { rsModule = rsModule' } + return (newSpan,t') -- |Replace the tokens for a given GHC.SrcSpan, return GHC.SrcSpan -- they are placed in diff --git a/src/Language/Haskell/Refact/Utils/TokenUtils.hs b/src/Language/Haskell/Refact/Utils/TokenUtils.hs --- a/src/Language/Haskell/Refact/Utils/TokenUtils.hs +++ b/src/Language/Haskell/Refact/Utils/TokenUtils.hs @@ -21,6 +21,7 @@ -- * Operations at 'TokenCache' level , putToksInCache + , putDeclToksInCache , replaceTokenInCache , removeToksFromCache , getTreeFromCache @@ -635,6 +636,20 @@ forest = getTreeFromCache sspan tk (forest',newSpan,oldTree) = updateTokensForSrcSpan forest sspan toks tk' = replaceTreeInCache sspan forest' tk + tk'' = stash tk' oldTree + +-- --------------------------------------------------------------------- + +putDeclToksInCache :: (SYB.Data t) => + TokenCache -> GHC.SrcSpan -> [PosToken] -> GHC.Located t + -> (TokenCache,GHC.SrcSpan,GHC.Located t) +putDeclToksInCache tk sspan toks t = (tk'',newSpan,t') + where + forest = getTreeFromCache sspan tk + (forest',newSpan,oldTree) = updateTokensForSrcSpan forest sspan toks + (t',forest'') = syncAST t newSpan forest' + + tk' = replaceTreeInCache sspan forest'' tk tk'' = stash tk' oldTree -- --------------------------------------------------------------------- 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 @@ -3679,6 +3679,7 @@ isTypeSigOf _ _ =False -} + -- | Return the list of identifiers (in PName format) defined by a function\/pattern binding. definedPNs::GHC.LHsBind GHC.Name -> [GHC.Name] definedPNs (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)) = [pname] @@ -4250,7 +4251,7 @@ -- include the signature too -> Bool -- ^ True means the declaration is a -- toplevel declaration. - -> RefactGhc t --[GHC.LHsBind GHC.Name] + -> RefactGhc t addDecl parent pn (decl, msig, declToks) topLevel = if isJust pn @@ -4483,16 +4484,15 @@ addParamsToDecls decls pn paramPNames modifyToks = do logm $ "addParamsToDecls (pn,paramPNames,modifyToks)=" ++ (showGhc (pn,paramPNames,modifyToks)) + -- logm $ "addParamsToDecls: decls=" ++ (SYB.showData SYB.Renamer 0 decls) if (paramPNames/=[]) then mapM addParamToDecl decls else return decls where addParamToDecl :: GHC.LHsBind GHC.Name -> RefactGhc (GHC.LHsBind GHC.Name) - -- addParamToDecl (TiDecorate.Dec (HsFunBind loc matches@((HsMatch _ fun pats rhs ds):ms))) addParamToDecl (GHC.L l1 (GHC.FunBind (GHC.L l2 pname) i (GHC.MatchGroup matches ptt) co fvs t)) | pname == pn = do matches' <- mapM addParamtoMatch matches - -- return (TiDecorate.Dec (HsFunBind loc matches')) return (GHC.L l1 (GHC.FunBind (GHC.L l2 pname) i (GHC.MatchGroup matches' ptt) co fvs t)) where -- addParamtoMatch (HsMatch loc fun pats rhs decls) @@ -4505,7 +4505,7 @@ logm $ "addParamtoMatch:l=" ++ (showGhc l) if emptyList pats then addFormalParams (Left l2) pats' - else addFormalParams (Right (ghead "addParamtoMatch" pats)) pats' + else addFormalParams (Right pats) pats' return pats' else return pats' @@ -4517,34 +4517,52 @@ | p == pn = do _rhs'<-addActualParamsToRhs modifyToks pn paramPNames rhs let pats' = map GHC.noLoc $ map pNtoPat paramPNames - _pats'' <- if modifyToks then do _ <- addFormalParams (Right pat) pats' + _pats'' <- if modifyToks then do _ <- addFormalParams (Right [pat]) pats' return pats' else return pats' -- return (TiDecorate.Dec (HsFunBind loc [HsMatch loc (patToPNT p) pats' rhs ds])) return (GHC.L l1 (GHC.PatBind pat rhs ty fvs t)) addParamToDecl x=return x + -- | Add tokens corresponding to the new parameters to the end of the -- syntax element provided -addFormalParams :: Either GHC.SrcSpan (GHC.LPat GHC.Name) -> [GHC.Located (GHC.Pat GHC.Name)] -> RefactGhc () +addFormalParams + :: Either GHC.SrcSpan [(GHC.LPat GHC.Name)] -- location: SrcSpan only + -- if no existing params, else list + -- of current params + -> [(GHC.LPat GHC.Name)] -- params to add + -> RefactGhc () addFormalParams place newParams = do + -- logm $ "addFormalParams:(place,newParams):" ++ (SYB.showData SYB.Renamer 0 (place,newParams)) -- newToks <- liftIO $ basicTokenise (prettyprintPatList prettyprint True newParams) let newStr = (prettyprintPatList prettyprint True newParams) case place of Left l@(GHC.RealSrcSpan ss) -> do - newToks <- liftIO $ tokenise (GHC.realSrcSpanStart ss) 0 False newStr + newToks' <- liftIO $ tokenise (GHC.realSrcSpanStart ss) 0 False newStr + let newToks = map markToken newToks' _ <- putToksAfterSpan l PlaceAdjacent newToks return () Left ss -> error $ "addFormalParams: expecting RealSrcSpan, got:" ++ (showGhc ss) - Right (GHC.L l _) -> do + Right pats -> do + let l = GHC.combineLocs (ghead "addFormalParams" pats) (glast "addFormalParams" pats) + -- logm $ "addFormalParams:(l,pats)=" ++ (SYB.showData SYB.Renamer 0 (l,pats)) toks <- getToksForSpan l - newToks <- liftIO $ tokenise (realSrcLocFromTok $ ghead "addFormalParams" toks) 0 False newStr - _ <- putToksForSpan l newToks - _ <- putToksAfterSpan l PlaceAdjacent toks + + let oldStr = GHC.showRichTokenStream $ rmOffsetFromToks toks + combinedToks <- liftIO $ tokenise (realSrcLocFromTok + $ ghead "addFormalParams" toks) + 0 False (newStr ++ " " ++ oldStr) + + _ <- putToksForSpan l combinedToks + return () + -- drawTokenTree "after addFormalParams" + -- drawTokenTreeDetailed "after addFormalParams" + -- --------------------------------------------------------------------- addActualParamsToRhs :: (SYB.Typeable t, SYB.Data t) => @@ -4553,7 +4571,6 @@ -- logm $ "addActualParamsToRhs:rhs=" ++ (SYB.showData SYB.Renamer 0 $ rhs) r <- everywhereMStaged SYB.Renamer (SYB.mkM grhs) rhs return r - -- = applyTP (stop_tdTP (failTP `adhocTP` worker)) where -- |Limit the action to actual RHS elements @@ -4852,9 +4869,9 @@ -- parameter is True) that defines the given identifier from the -- declaration list. rmDecl:: (SYB.Data t) - =>GHC.Name -- ^ The identifier whose definition is to be removed. - ->Bool -- ^ True means including the type signature. - ->t -- ^ The declaration list. + => GHC.Name -- ^ The identifier whose definition is to be removed. + -> Bool -- ^ True means including the type signature. + -> t -- ^ The declaration list. -> RefactGhc (t, GHC.LHsBind GHC.Name, @@ -4869,6 +4886,7 @@ setStateStorage StorageNone t2 <- everywhereMStaged' SYB.Renamer (SYB.mkM inLet) t -- top down -- drawTokenTreeDetailed "rmDecl.entry after inLet" -- ++AZ++ 'in' missing + drawTokenTree "rmDecl.entry after inLet" -- ++AZ++ 'in' missing t' <- everywhereMStaged' SYB.Renamer (SYB.mkM inDecls `SYB.extM` inGRHSs) t2 -- top down -- applyTP (once_tdTP (failTP `adhocTP` inDecls)) t @@ -4925,14 +4943,17 @@ -- drawTokenTreeDetailed "rmDecl.inLet tree" -- ++AZ++ missing -- toks <- getToksForSpanWithIntros l removeToksForPos (getStartEndLoc decl) + drawTokenTree "rmDecl.inLet after removeToksForPos" decl' <- syncDeclToLatestStash decl setStateStorage (StorageBind decl') + drawTokenTree "rmDecl.inLet after syncDeclToLatestStash" case length decls of 1 -> do -- Removing the last declaration logm $ "rmDecl.inLet:length decls = 1: expr=" ++ (SYB.showData SYB.Renamer 0 expr) -- putToksForSpan ss toks - void $ putToksForSpan ss $ dropWhile (\tok -> isEmpty tok || isIn tok) toks - return expr + (_,expr') <- putDeclToksForSpan ss expr $ dropWhile (\tok -> isEmpty tok || isIn tok) toks + drawTokenTree "rmDecl.inLet after putToksForSpan" + return expr' _ -> do logm $ "rmDecl.inLet:length decls /= 1" -- drawTokenTreeDetailed "rmDecl.inLet tree" @@ -5507,16 +5528,6 @@ inDecl _ = Nothing -- --------------------------------------------------------------------- - --- | Return True if the identifier occurs in the given syntax phrase. -findPNT::(SYB.Data t) => GHC.Located GHC.Name -> t -> Bool -findPNT (GHC.L _ pn) - = isJust.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) - where - worker (n::GHC.Name) - | GHC.nameUnique pn == GHC.nameUnique n = Just True - worker _ = Nothing - -- | Find all occurrences with location of the given name findAllNameOccurences :: (SYB.Data t) => GHC.Name -> t -> [(GHC.Located GHC.Name)] findAllNameOccurences name t @@ -5537,29 +5548,18 @@ | GHC.nameUnique n == GHC.nameUnique name = [(GHC.L l n)] workerExpr _ = [] +-- --------------------------------------------------------------------- +-- | Return True if the identifier occurs in the given syntax phrase. +findPNT::(SYB.Data t) => GHC.Located GHC.Name -> t -> Bool +findPNT (GHC.L _ pn) = findPN pn {- --- | Find all locations where names occur in the given syntax phrase -findAllNames:: (SYB.Data t) => t -> [(GHC.Located GHC.Name)] -findAllNames t - = res - where - res = SYB.everythingStaged SYB.Renamer (++) [] - ([] `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t - - worker (ln@(GHC.L _l _n) :: (GHC.Located GHC.Name)) - | True = [ln] - worker _ = [] - - workerBind (GHC.L l (GHC.VarPat n) :: (GHC.Located (GHC.Pat GHC.Name))) - | True = [(GHC.L l n)] - workerBind _ = [] - - workerExpr (GHC.L l (GHC.HsVar n) :: (GHC.Located (GHC.HsExpr GHC.Name))) - | True = [(GHC.L l n)] - workerExpr _ = [] + = isJust.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) + where + worker (n::GHC.Name) + | GHC.nameUnique pn == GHC.nameUnique n = Just True + worker _ = Nothing -} - -- | Return True if the identifier occurs in the given syntax phrase. findPN::(SYB.Data t)=> GHC.Name -> t -> Bool