diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -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. diff --git a/HaRe.cabal b/HaRe.cabal --- a/HaRe.cabal +++ b/HaRe.cabal @@ -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 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 @@ -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') diff --git a/src/Language/Haskell/Refact/Utils/GhcUtils.hs b/src/Language/Haskell/Refact/Utils/GhcUtils.hs --- a/src/Language/Haskell/Refact/Utils/GhcUtils.hs +++ b/src/Language/Haskell/Refact/Utils/GhcUtils.hs @@ -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 m () fixity = const (guard $ stage 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 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 @@ -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