HaRe 0.7.1.4 → 0.7.1.5
raw patch · 9 files changed
+238/−285 lines, 9 files
Files
- ChangeLog +2/−0
- HaRe.cabal +2/−16
- src/Language/Haskell/Refact/MoveDef.hs +127/−155
- src/Language/Haskell/Refact/Utils/DualTree.hs +2/−0
- src/Language/Haskell/Refact/Utils/Layout.hs +17/−6
- src/Language/Haskell/Refact/Utils/LocUtils.hs +12/−61
- src/Language/Haskell/Refact/Utils/MonadFunctions.hs +14/−0
- src/Language/Haskell/Refact/Utils/TokenUtils.hs +15/−0
- src/Language/Haskell/Refact/Utils/TypeUtils.hs +47/−47
ChangeLog view
@@ -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
HaRe.cabal view
@@ -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
src/Language/Haskell/Refact/MoveDef.hs view
@@ -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)=<<hsFDsFromInside match- inMatch _ =mzero - inPat (pat@(Dec (HsPatBind loc p rhs ds)):: HsDeclP)- |findPN pn rhs- =(return.snd)=<<hsFDsFromInside pat- inPat _=mzero--}--- -- --------------------------------------------------------------------- @@ -1519,25 +1512,13 @@ -- return clashed names return (filter (\x->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
src/Language/Haskell/Refact/Utils/DualTree.hs view
@@ -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 ----------------
src/Language/Haskell/Refact/Utils/Layout.hs view
@@ -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) -- ---------------------------------------------------------------------
src/Language/Haskell/Refact/Utils/LocUtils.hs view
@@ -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 -- ---------------------------------------------------------------------
src/Language/Haskell/Refact/Utils/MonadFunctions.hs view
@@ -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
src/Language/Haskell/Refact/Utils/TokenUtils.hs view
@@ -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 -- ---------------------------------------------------------------------
src/Language/Haskell/Refact/Utils/TypeUtils.hs view
@@ -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