HaRe 0.7.1.6 → 0.7.1.7
raw patch · 5 files changed
+78/−55 lines, 5 files
Files
- ChangeLog +3/−0
- HaRe.cabal +1/−1
- src/Language/Haskell/Refact/MoveDef.hs +53/−41
- src/Language/Haskell/Refact/Utils/GhcUtils.hs +13/−11
- src/Language/Haskell/Refact/Utils/TypeUtils.hs +8/−2
ChangeLog view
@@ -1,3 +1,6 @@+2014-03-22 v0.7.1.7+ * Correctly determine what parameters to add when lifting a decl+ * Do not demote a decl if it is used in more than one match 2014-03-19 v0.7.1.6 * Do not treat single-line layout as a group, hence preserving layout of adjacent let expressions when renaming.
HaRe.cabal view
@@ -1,5 +1,5 @@ Name: HaRe-Version: 0.7.1.6+Version: 0.7.1.7 Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer: Alan Zimmerman Stability: Alpha
src/Language/Haskell/Refact/MoveDef.hs view
@@ -143,6 +143,8 @@ renamed <- getRefactRenamed parsed <- getRefactParsed + -- TODO: make the next one an API call, that also gets the+ -- parsed source let (Just (modName,_)) = getModuleName parsed let maybePn = locToName (row, col) renamed case maybePn of@@ -220,7 +222,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@@ -262,7 +264,7 @@ -- TODO: what about declarations between this -- one and the top level that are used in this one? - logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns))+ -- logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns)) -- original : pns<-pnsNeedRenaming inscps mod parent liftedDecls declaredPns pns <- pnsNeedRenaming renamed parent liftedDecls declaredPns @@ -314,7 +316,7 @@ -> RefactGhc t -- ^ The updated syntax element (and tokens in monad) moveDecl1 t defName ns mliftedDecls sigNames topLevel = do -- logm $ "moveDecl1:t=" ++ (SYB.showData SYB.Renamer 0 t) -- ++AZ++- logm $ "moveDecl1:mliftedDecls=" ++ (showGhc mliftedDecls)+ -- logm $ "moveDecl1:mliftedDecls=" ++ (showGhc mliftedDecls) -- drawTokenTree "moveDecl1 on entry" -- TODO: work with all of ns, not just the first@@ -324,12 +326,12 @@ Nothing -> definingDeclsNames' [n] t Just liftedDecls -> liftedDecls - logm $ "moveDecl1: (ns,funBinding)=" ++ (showGhc (ns,funBinding)) -- ++AZ+++ -- 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)+ -- logm $ "moveDecl1:funToks=" ++ (showToks funToks) -- drawTokenTree "moveDecl1:after getting toks" -- ++AZ++ 'in' present --- drawTokenTreeDetailed "moveDecl1:after getting toks" -- ++AZ++ @@ -354,8 +356,8 @@ sigsRemoved let maybeToksSig = concat maybeToksSigMulti - logm $ "moveDecl1:maybeToksSig=" ++ (show maybeToksSig) -- ++AZ++- logm $ "moveDecl1:(defName,topLevel)" ++ (showGhc (defName,topLevel)) -- ++AZ+++ -- logm $ "moveDecl1:maybeToksSig=" ++ (show maybeToksSig) -- ++AZ+++ -- logm $ "moveDecl1:(defName,topLevel)" ++ (showGhc (defName,topLevel)) -- ++AZ++ -- drawTokenTree "moveDecl1 about to addDecl" r <- addDecl t' defName (ghead "moveDecl1 2" funBinding,sigsRemoved,Just (maybeToksSig ++ funToks)) topLevel@@ -722,8 +724,8 @@ liftedDecls=definingDeclsNames [n] parent True True declaredPns=nub $ concatMap definedPNs liftedDecls -- logm $ "MoveDef.worker: (dest)=" ++ (SYB.showData SYB.Renamer 0 dest)- logm $ "MoveDef.worker: (ds)=" ++ (showGhc (ds))- logm $ "MoveDef.worker: parent=" ++ (showGhc parent)+ -- logm $ "MoveDef.worker: (ds)=" ++ (showGhc (ds))+ -- logm $ "MoveDef.worker: parent=" ++ (showGhc parent) (_, dd) <- hsFreeAndDeclaredPNs dest -- pns<-pnsNeedRenaming inscps dest parent liftedDecls declaredPns pns<-pnsNeedRenaming dest parent liftedDecls declaredPns@@ -766,9 +768,9 @@ liftedDecls=definingDeclsNames [n] decl True True declaredPns=nub $ concatMap definedPNs liftedDecls -- logm $ "MoveDef.worker1: (dest)=" ++ (SYB.showData SYB.Renamer 0 dest)- logm $ "MoveDef.worker1: (ds)=" ++ (showGhc (ds))- logm $ "MoveDef.worker1: decl=" ++ (showGhc decl)- logm $ "MoveDef.worker1: dd=" ++ (showGhc dd)+ -- logm $ "MoveDef.worker1: (ds)=" ++ (showGhc (ds))+ -- logm $ "MoveDef.worker1: decl=" ++ (showGhc decl)+ -- logm $ "MoveDef.worker1: dd=" ++ (showGhc dd) pns <- pnsNeedRenaming dest decl liftedDecls declaredPns logm $ "MoveDef.worker1: pns=" ++ (showGhc pns)@@ -801,16 +803,16 @@ addParamsToParentAndLiftedDecl :: (HsValBinds t,GHC.Outputable t) =>- GHC.Name -- name of decl being lifted+ GHC.Name -- ^name of decl being lifted -> [GHC.Name] -- ^Declared names in parent- -> t -- parent- -> [GHC.LHsBind GHC.Name] -- decls being lifted+ -> 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 (lf,_) <- hsFreeAndDeclaredPNs liftedDecls - logm $ "addParamsToParentAndLiftedDecl:parent=" ++ (showGhc parent)+ -- logm $ "addParamsToParentAndLiftedDecl:parent=" ++ (showGhc parent) -- parameters to be added to pn because of lifting let newParams=((nub lf) \\ (nub ef)) \\ dd@@ -823,16 +825,16 @@ 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'')+ -- 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"+ -- logm $ "addParamsToParentAndLiftedDecl: parent done" -- drawTokenTree "addParamsToParentAndLiftedDecl: parent params done" liftedDecls' <- addParamsToDecls [liftedDecls''] pn newParams True- logm $ "addParamsToParentAndLiftedDecl: liftedDecls done"+ -- logm $ "addParamsToParentAndLiftedDecl: liftedDecls done" -- drawTokenTree "addParamsToParentAndLiftedDecl: liftedDecls done" return (parent', liftedDecls',True)@@ -930,15 +932,6 @@ -- error ("doDemoting:ren=" ++ (showGhc ren)) showLinesDebug "doDemoting done" return ()-{-- =runStateT (applyTP ((once_tdTP (failTP `adhocTP` demoteInMod- `adhocTP` demoteInMatch- `adhocTP` demoteInPat- `adhocTP` demoteInLet- `adhocTP` demoteInAlt- `adhocTP` demoteInStmt)) `choiceTP` failure) mod)- ((toks,unmodified),(-1000,0))--} where --1. demote from top level -- demoteInMod (mod@(HsModule loc name exps imps ds):: HsModuleP)@@ -1027,13 +1020,13 @@ +-- |Demote the declaration of 'pn' in the context of 't'. doDemoting' :: (HsValBinds t, UsedByRhs t) => t -> GHC.Name -> RefactGhc t doDemoting' t pn = let origDecls = hsBinds t demotedDecls'= definingDeclsNames [pn] origDecls True False declaredPns = nub $ concatMap definedPNs demotedDecls' in if not (usedByRhs t declaredPns)- -- if True -- ++AZ++ temporary then do -- drawTokenTree "" -- ++AZ++ debug let demotedDecls = definingDeclsNames [pn] (hsBinds t) True True@@ -1049,10 +1042,13 @@ -- uselist = concatMap (\r -> if (emptyList r) then [] else ["Used"]) $ map (\b -> uses declaredPns [b]) otherBinds xx = map (\b -> (b,uses declaredPns [b])) otherBinds uselist = concatMap (\(b,r) -> if (emptyList r) then [] else [b]) xx+ useCount = sum $ concatMap snd xx logm $ "doDemoting': uses xx=" ++ (showGhc xx) logm $ "doDemoting': uses uselist=" ++ (showGhc uselist)+ logm $ "doDemoting': uses useCount=" ++ (show useCount) - case length uselist of+ -- case length uselist of+ case useCount of 0 ->do error "\n Nowhere to demote this function!\n" 1 -> --This function is only used by one friend function do@@ -1077,9 +1073,9 @@ -- end TODO logm $ "MoveDef:declaredPns=" ++ (showGhc declaredPns) -- ++AZ++- logm $ "MoveDef:demotedSigToks=" ++ (show demotedSigToks) -- ++AZ+++ -- logm $ "MoveDef:demotedSigToks=" ++ (show demotedSigToks) -- ++AZ++ - logm $ "MoveDef:sig and decl toks[" ++ (GHC.showRichTokenStream (demotedSigToks ++ demotedToks)) ++ "]" -- ++AZ+++ -- logm $ "MoveDef:sig and decl toks[" ++ (GHC.showRichTokenStream (demotedSigToks ++ demotedToks)) ++ "]" -- ++AZ++ --get those variables declared at where the demotedDecls will be demoted to -- let dl = map (flip declaredNamesInTargetPlace ds) declaredPns@@ -1105,20 +1101,36 @@ return (replaceBinds t' ds'') _ ->error "\nThis function/pattern binding is used by more than one friend bindings\n"- -- _ ->error $ "\nThis function/pattern binding is used by more than one friend bindings:\n" ++ (showGhc yy)- -- _ ->error $ "\nThis function/pattern binding is used by more than one friend bindings\n" ++ (showGhc (uselist,declaredPns,otherBinds)) -- ++AZ++ else error "This function can not be demoted as it is used in current level!\n"- -- else error ("doDemoting': demotedDecls=" ++ (showGhc demotedDecls)) -- ++AZ++- -- else error ("doDemoting': declaredPns=" ++ (showGhc declaredPns)) -- ++AZ++- -- else error ("doDemoting': (origDecls,demotedDecls',declaredPns,(usedByRhs t declaredPns))=" ++ (showGhc (origDecls,demotedDecls',declaredPns,(usedByRhs t declaredPns)))) -- ++AZ++ where ---find how many matches/pattern bindings use 'pn'-------- -- uses :: (SYB.Data t) => [GHC.Name] -> [t] -> [Int]- -- uses :: (SYB.Data t) => [GHC.Name] -> t -> [Int]+ uses :: [GHC.Name] -> [GHC.LHsBind GHC.Name] -> [Int] uses pns t2+ = concatMap used t2+ where++ used :: GHC.LHsBind GHC.Name -> [Int]+ used (GHC.L _ (GHC.FunBind _n _ (GHC.MatchGroup matches _) _ _ _))+ = concatMap (usedInMatch pns) matches++ used (GHC.L _ (GHC.PatBind pat rhs _ _ _))+ -- was | hsPNs p `intersect` pns ==[] && any (flip findPN pat) pns+ | (not $ findPNs pns pat) && findPNs pns rhs+ = [1::Int]+ used _ = []++ usedInMatch pns (GHC.L _ (GHC.Match pats _ rhs))+ -- was | isNothing (find (==pname) pns) && any (flip findPN match) pns+ | (not $ findPNs pns pats) && findPNs pns rhs+ = [1::Int]+ usedInMatch _ _ = []+++ uses' :: [GHC.Name] -> [GHC.LHsBind GHC.Name] -> [Int]+ uses' pns t2 = concat $ SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` usedInMatch `SYB.extQ` usedInPat) t2@@ -1316,7 +1328,7 @@ return (GHC.Match pats mt rhs'') else do -- moveDecl pns match False decls True -- return (HsMatch loc1 name pats rhs (ds++demotedDecls)) -- no parameter folding - logm $ "MoveDef.foldParams about to addDecl:dtoks=" ++ (show dtoks)+ -- logm $ "MoveDef.foldParams about to addDecl:dtoks=" ++ (show dtoks) -- drawTokenTree "" -- ++AZ++ debug rhs' <- addDecl rhs Nothing (demotedDecls,dsig,dtoks) False return (GHC.Match pats mt rhs')
src/Language/Haskell/Refact/Utils/GhcUtils.hs view
@@ -26,19 +26,24 @@ , everywhereStaged' , onelayerStaged , listifyStaged+ -- ** SYB Utility , checkItemRenamer+ -- * Strafunski StrategyLib versions , full_tdTUGhc , stop_tdTUGhc+ , stop_tdTPGhc , allTUGhc' , once_tdTPGhc , once_buTPGhc , oneTPGhc , allTUGhc+ -- ** Strafunski utility , checkItemStage' , checkItemRenamer'+ -- * Scrap Your Zipper versions , zeverywhereStaged , zopenStaged@@ -243,10 +248,14 @@ -- | Top-down type-unifying traversal that is cut of below nodes -- where the argument strategy succeeds. stop_tdTUGhc :: (MonadPlus m, Monoid a) => TU a m -> TU a m--- stop_tdTUGhc s = ifTU checkItemRenamer' (const s) (s `choiceTU` (allTUGhc' (stop_tdTUGhc s))) stop_tdTUGhc s = (s `choiceTU` (allTUGhc' (stop_tdTUGhc s))) +-- | Top-down type-preserving traversal that is cut of below nodes+-- where the argument strategy succeeds.+stop_tdTPGhc :: MonadPlus m => TP m -> TP m+stop_tdTPGhc s = s `choiceTP` (allTPGhc (stop_tdTPGhc s)) + allTUGhc' :: (MonadPlus m, Monoid a) => TU a m -> TU a m allTUGhc' = allTUGhc mappend mempty @@ -262,9 +271,11 @@ -- Succeed for one child; don't care about the other children oneTPGhc :: MonadPlus m => TP m -> TP m--- oneTPGhc s = ifTP checkItemRenamer' (const s) (oneTP s) oneTPGhc s = ifTP checkItemRenamer' (const failTP) (oneTP s) +-- Succeed for all children+allTPGhc :: MonadPlus m => TP m -> TP m+allTPGhc s = ifTP checkItemRenamer' (const failTP) (oneTP s) ------------------------------------------ @@ -278,15 +289,6 @@ where nameSet = const (guard $ stage `elem` [SYB.Parser,SYB.TypeChecker]) :: GHC.NameSet -> m () postTcType = const (guard $ stage<SYB.TypeChecker) :: GHC.PostTcType -> m () fixity = const (guard $ stage<SYB.Renamer) :: GHC.Fixity -> m ()--{---- | Check the Typeable1 items-checkItemStage2' :: forall m. (MonadPlus m) => SYB.Stage -> TU () m-checkItemStage2' stage x = failTU `adhocTU` hsWithBndrs- where- hsWithBndrs :: (Data t) => GHC.HsWithBndrs t -> m ()- hsWithBndrs = const (guard $ stage < SYB.Renamer)--} checkItemRenamer' :: (MonadPlus m) => TU () m checkItemRenamer' = checkItemStage' SYB.Renamer
src/Language/Haskell/Refact/Utils/TypeUtils.hs view
@@ -836,7 +836,7 @@ hsFreeAndDeclaredPNs :: (SYB.Data t, GHC.Outputable t) => t -> RefactGhc ([GHC.Name],[GHC.Name]) hsFreeAndDeclaredPNs t = do- logm $ "hsFreeAndDeclaredPNs:t=" ++ (showGhc t)+ -- logm $ "hsFreeAndDeclaredPNs:t=" ++ (showGhc t) (FN f,DN d) <- hsFreeAndDeclaredGhc t return (f,d) @@ -4580,19 +4580,25 @@ Bool -> GHC.Name -> [GHC.Name] -> t -> RefactGhc t addActualParamsToRhs modifyToks pn paramPNames rhs = do -- logm $ "addActualParamsToRhs:rhs=" ++ (SYB.showData SYB.Renamer 0 $ rhs)- r <- everywhereMStaged SYB.Renamer (SYB.mkM grhs) rhs++ -- = applyTP (stop_tdTP (failTP `adhocTP` worker))++ r <- applyTP (stop_tdTPGhc (failTP `adhocTP` grhs)) rhs+ -- r <- everywhereMStaged SYB.Renamer (SYB.mkM grhs) rhs return r where -- |Limit the action to actual RHS elements grhs :: (GHC.GRHSs GHC.Name) -> RefactGhc (GHC.GRHSs GHC.Name) grhs (GHC.GRHSs g lb) = do+ -- logm $ "addActualParamsToRhs.grhs:g=" ++ (SYB.showData SYB.Renamer 0 g) g' <- everywhereMStaged SYB.Renamer (SYB.mkM worker) g return (GHC.GRHSs g' lb) worker :: (GHC.Located (GHC.HsExpr GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name)) worker oldExp@(GHC.L l2 (GHC.HsVar pname)) | pname == pn = do+ -- logm $ "addActualParamsToRhs:oldExp=" ++ (SYB.showData SYB.Renamer 0 oldExp) let newExp' = foldl addParamToExp oldExp paramPNames let newExp = (GHC.L l2 (GHC.HsPar newExp')) -- TODO: updateToks must add a space at the end of the