Permalink
Browse files

Make sure renames in client modules are properly qualified

  • Loading branch information...
1 parent 752655a commit 950c5aa5d08913500f54e3321872af59236ee524 Alan Zimmerman committed Mar 3, 2014
View
@@ -349,3 +349,9 @@ testing/addCon/Case2.hs.temp.hs
/test/testdata/Renaming/IdIn5.hs.renamed_out
/test/testdata/Renaming/IdIn5.hs.tokens
/test/tags
+/test/testdata/Renaming/QualClient.hs.AST_out
+/test/testdata/Renaming/QualClient.hs.renamed_out
+/test/testdata/Renaming/QualClient.hs.tokens
+/test/testdata/Renaming/QualServer.hs.AST_out
+/test/testdata/Renaming/QualServer.hs.renamed_out
+/test/testdata/Renaming/QualServer.hs.tokens
View
@@ -32,6 +32,7 @@
** TODO manage RefactGhc to separate Hare exceptions from GHC ones
see http://parenz.wordpress.com/2013/07/23/on-custom-error-handlers-for-ghc-api/
** TODO elisp: cancel option is not implemented
+** TODO renaming getPid in hroq mnesia removes HM. qualification in client file
** TODO from the source files
:PROPERTIES:
:ID: 2930a92b-9989-427f-b02e-e47ca11a84de
@@ -130,6 +130,8 @@ module Language.Haskell.Refact.Utils.TypeUtils
, getDeclAndToks, getSigAndToks
, getToksForDecl, removeToksOffset -- ++AZ++ remove this after debuggging
, getParsedForRenamedLPat
+ , getParsedForRenamedName
+ , getParsedForRenamedLocated
-- , allPNT
-- , allPNTLens
, newNameTok
@@ -1505,6 +1507,53 @@ getParsedForRenamedLPat parsed lpatParam@(GHC.L l _pat) = r
-- ---------------------------------------------------------------------
+-- | Given a RenamedSource Located name, return the equivalent
+-- ParsedSource part.
+-- NOTE: returns pristine ParsedSource, since HaRe does not change it
+getParsedForRenamedLocated :: ({- SYB.Typeable a, SYB.Data a, -} SYB.Typeable b {- , SYB.Data b -})
+ => GHC.Located a -> RefactGhc (GHC.Located b)
+getParsedForRenamedLocated n@(GHC.L l _n) = do
+ parsed <- getRefactParsed
+ let
+ mres = res parsed
+ r = case mres of
+ Just rr -> rr
+ Nothing -> error $ "HaRe error: could not find Parsed Location for"
+ ++ (showGhc l)
+
+ res t = somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lname) t
+
+ lname :: (GHC.Located b) -> (Maybe (GHC.Located b))
+ lname p@(GHC.L lp _)
+ | lp == l ||
+ stripForestLineFromGhc lp == stripForestLineFromGhc l = Just p
+ lname _ = Nothing
+
+ return r
+
+
+-- | Given a RenamedSource Located name, return the equivalent
+-- ParsedSource part.
+-- NOTE: returns pristine ParsedSource, since HaRe does not change it
+getParsedForRenamedName :: GHC.ParsedSource -> GHC.Located GHC.Name -> GHC.Located GHC.RdrName
+getParsedForRenamedName parsed n@(GHC.L l _n) = r
+ where
+ mres = res parsed
+ r = case mres of
+ Just rr -> rr
+ Nothing -> error $ "HaRe error: could not find Parsed LPat for"
+ ++ (SYB.showData SYB.Renamer 0 n)
+
+ res t = somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lname) t
+
+ lname :: (GHC.Located GHC.RdrName) -> (Maybe (GHC.Located GHC.RdrName))
+ lname p@(GHC.L lp _)
+ | lp == l ||
+ stripForestLineFromGhc lp == stripForestLineFromGhc l = Just p
+ lname _ = Nothing
+
+-- ---------------------------------------------------------------------
+
getDeclaredTypes :: GHC.LTyClDecl GHC.Name -> [GHC.Name]
getDeclaredTypes (GHC.L _ (GHC.ForeignType (GHC.L _ n) _)) = [n]
getDeclaredTypes (GHC.L _ (GHC.TyFamily _ (GHC.L _ n) _bs _)) = [n]
@@ -5052,7 +5101,7 @@ renamePN::(SYB.Data t)
renamePN oldPN newName updateTokens useQual t = do
-- = error $ "renamePN: sspan=" ++ (showGhc sspan) -- ++AZ++
-- logm $ "renamePN': (oldPN,newName)=" ++ (showGhc (oldPN,newName))
- logm $ "renamePN': t=" ++ (SYB.showData SYB.Renamer 0 t)
+ logm $ "renamePN: t=" ++ (SYB.showData SYB.Renamer 0 t)
-- Note: bottom-up traversal
let isRenamed = somethingStaged SYB.Renamer Nothing
(Nothing `SYB.mkQ` isRenamedSource `SYB.extQ` isRenamedGroup) t
@@ -5127,40 +5176,65 @@ renamePNworker oldPN newName updateTokens useQual t = do
= do
logm $ "renamePNworker:rename at :" ++ (show l) ++ (showSrcSpanF l)
drawTokenTree "before worker" -- ++AZ++ debug
- worker useQual l
+ worker useQual l Nothing
return (GHC.L l newName)
rename x = return x
renameVar :: (GHC.Located (GHC.HsExpr GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name))
- renameVar (GHC.L l (GHC.HsVar n))
+ renameVar v@(GHC.L l (GHC.HsVar n))
| (GHC.nameUnique n == GHC.nameUnique oldPN)
= do
logm $ "renamePNworker:renameVar at :" ++ (showGhc l)
- worker useQual l
+
+ -- Get the original qualification, if any
+ rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LHsExpr GHC.RdrName))
+ let (GHC.L _ (GHC.HsVar mqn)) = rn
+ let mrnq = GHC.isQual_maybe mqn
+ logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq))
+
+ worker useQual l mrnq
return (GHC.L l (GHC.HsVar newName))
renameVar x = return x
-- HsTyVar {Name: Renaming.D1.Tree}))
renameTyVar :: (GHC.Located (GHC.HsType GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsType GHC.Name))
- renameTyVar (GHC.L l (GHC.HsTyVar n))
+ renameTyVar v@(GHC.L l (GHC.HsTyVar n))
| (GHC.nameUnique n == GHC.nameUnique oldPN)
= do
logm $ "renamePNworker:renameTyVar at :" ++ (showGhc l)
- worker useQual l
+
+ -- Get the original qualification, if any
+ rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LHsType GHC.RdrName))
+ let (GHC.L _ (GHC.HsTyVar mqn)) = rn
+ let mrnq = GHC.isQual_maybe mqn
+ logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq))
+
+ worker useQual l mrnq
return (GHC.L l (GHC.HsTyVar newName))
renameTyVar x = return x
renameHsTyVarBndr :: (GHC.LHsTyVarBndr GHC.Name) -> RefactGhc (GHC.LHsTyVarBndr GHC.Name)
#if __GLASGOW_HASKELL__ > 704
- renameHsTyVarBndr (GHC.L l (GHC.UserTyVar n))
+ renameHsTyVarBndr v@(GHC.L l (GHC.UserTyVar n))
#else
- renameHsTyVarBndr (GHC.L l (GHC.UserTyVar n typ))
+ renameHsTyVarBndr v@(GHC.L l (GHC.UserTyVar n typ))
#endif
| (GHC.nameUnique n == GHC.nameUnique oldPN)
= do
logm $ "renamePNworker:renameHsTyVarBndr at :" ++ (showGhc l)
- worker useQual l
+
+ -- Get the original qualification, if any
+ rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LHsTyVarBndr GHC.RdrName))
+#if __GLASGOW_HASKELL__ > 704
+ let (GHC.L _ (GHC.UserTyVar mqn)) = rn
+#else
+ let (GHC.L _ (GHC.UserTyVar mqn _)) = rn
+#endif
+ let mrnq = GHC.isQual_maybe mqn
+ logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq))
+
+ worker useQual l mrnq
#if __GLASGOW_HASKELL__ > 704
return (GHC.L l (GHC.UserTyVar newName))
#else
@@ -5173,16 +5247,23 @@ renamePNworker oldPN newName updateTokens useQual t = do
| (GHC.nameUnique n == GHC.nameUnique oldPN)
= do
logm $ "renamePNworker:renameLIE at :" ++ (showGhc l)
- worker useQual l
+ worker useQual l Nothing
return (GHC.L l (GHC.IEVar newName))
renameLIE x = return x
renameLPat :: (GHC.LPat GHC.Name) -> RefactGhc (GHC.LPat GHC.Name)
- renameLPat (GHC.L l (GHC.VarPat n))
+ renameLPat v@(GHC.L l (GHC.VarPat n))
| (GHC.nameUnique n == GHC.nameUnique oldPN)
= do
logm $ "renamePNworker:renameLPat at :" ++ (showGhc l)
- worker False l
+
+ -- Get the original qualification, if any
+ rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LPat GHC.RdrName))
+ let (GHC.L _ (GHC.VarPat mqn)) = rn
+ let mrnq = GHC.isQual_maybe mqn
+ logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq))
+
+ worker False l mrnq
return (GHC.L l (GHC.VarPat newName))
renameLPat x = return x
@@ -5195,10 +5276,10 @@ renamePNworker oldPN newName updateTokens useQual t = do
-- (b) rename each of 'tail matches'
-- (head is renamed in (a) )
-- logm $ "renamePNWorker.renameFunBind"
- worker False ln
+ worker False ln Nothing
-- Now do (b)
logm $ "renamePNWorker.renameFunBind.renameFunBind:starting matches"
- let w (GHC.L lm _match) = worker False lm'
+ let w (GHC.L lm _match) = worker False lm' Nothing
where
((GHC.L lm' _),_) = newNameTok False lm oldPN
mapM_ w $ tail matches
@@ -5219,11 +5300,17 @@ renamePNworker oldPN newName updateTokens useQual t = do
renameTypeSig x = return x
-- The param l is only useful for the start of the token pos
- worker :: Bool -> GHC.SrcSpan -> RefactGhc ()
- worker useQual' l
+ worker :: Bool -> GHC.SrcSpan -> Maybe (GHC.ModuleName, GHC.OccName) -> RefactGhc ()
+ worker useQual' l mmo
= do if updateTokens
- then do
- replaceToken l (markToken $ newNameTok useQual' l newName)
+ then do
+ newTok <- case mmo of
+ Nothing -> return $ newNameTok useQual' l newName
+ Just (modu,_) -> do
+ newName' <- mkNewGhcName (Just $ GHC.mkModule GHC.mainPackageId modu) (GHC.occNameString $ GHC.getOccName newName)
+ return $ newNameTok True l newName'
+ -- replaceToken l (markToken $ newNameTok useQual' l newName)
+ replaceToken l (markToken $ newTok)
return ()
else return ()
View
@@ -437,6 +437,24 @@ spec = do
-- ---------------------------------
+ it "renames in QualServer QualClient" $ do
+ r <- rename (testSettingsMainfile "./test/testdata/Renaming/QualClient.hs") testCradle "./test/testdata/Renaming/QualServer.hs" "foo1" (11,1)
+ -- rename (logTestSettingsMainfile "./test/testdata/Renaming/QualClient.hs") testCradle "./test/testdata/Renaming/QualServer.hs" "foo1" (11,1)
+
+ r `shouldBe` ["./test/testdata/Renaming/QualServer.hs",
+ "./test/testdata/Renaming/QualClient.hs"
+ ]
+
+ diffD <- compareFiles "./test/testdata/Renaming/QualServer.expected.hs"
+ "./test/testdata/Renaming/QualServer.refactored.hs"
+ diffD `shouldBe` []
+
+ diffC <- compareFiles "./test/testdata/Renaming/QualClient.expected.hs"
+ "./test/testdata/Renaming/QualClient.refactored.hs"
+ diffC `shouldBe` []
+
+ -- ---------------------------------
+
{-
it "rename gives noRebindableInfo MoveDef" $ do
-- rename logTestSettings testCradle "./src/Language/Haskell/Refact/MoveDef.hs" "t2" (1105,20)
@@ -2617,7 +2617,7 @@ spec = do
(showGhc n) `shouldBe` "Data.List.sum"
(showToks $ [newNameTok False l nn]) `shouldBe` "[(((4,24),(4,29)),ITvarid \"mySum\",\"mySum\")]"
(GHC.showRichTokenStream $ toks) `shouldBe` "module ScopeAndQual where\n\n import qualified Data.List as L\n import Prelude hiding (sum)\n\n main :: IO ()\n main = putStrLn (show $ L.sum [1,2,3])\n\n sum a b = a + b\n\n sumSquares xs = L.sum $ map (\\x -> x*x) xs\n\n mySumSq = sumSquares\n "
- (renderLines $ linesFromState s) `shouldBe` "module ScopeAndQual where\n\nimport qualified Data.List as L\nimport Prelude hiding (mySum)\n\nmain :: IO ()\nmain = putStrLn (show $ LocToName.mySum [1,2,3])\n\nsum a b = a + b\n\nsumSquares xs = LocToName.mySum $ map (\\x -> x*x) xs\n\nmySumSq = sumSquares\n"
+ (renderLines $ linesFromState s) `shouldBe` "module ScopeAndQual where\n\nimport qualified Data.List as L\nimport Prelude hiding (mySum)\n\nmain :: IO ()\nmain = putStrLn (show $ L.mySum [1,2,3])\n\nsum a b = a + b\n\nsumSquares xs = L.mySum $ map (\\x -> x*x) xs\n\nmySumSq = sumSquares\n"
(unspace $ showGhc nb) `shouldBe` unspace "(ScopeAndQual.main :: GHC.Types.IO ()\n ScopeAndQual.main\n = System.IO.putStrLn\n (GHC.Show.show GHC.Base.$ LocToName.mySum [1, 2, 3])\n ScopeAndQual.sum a b = a GHC.Num.+ b\n ScopeAndQual.sumSquares xs\n = LocToName.mySum GHC.Base.$ GHC.Base.map (\\ x -> x GHC.Num.* x) xs\n ScopeAndQual.mySumSq = ScopeAndQual.sumSquares,\n [import qualified Data.List as L,\n import Prelude hiding ( LocToName.mySum )],\n Nothing,\n Nothing)"
@@ -0,0 +1,10 @@
+module Renaming.QualClient where
+
+{- foo is imported qualified as in QualClient. Renaming should
+ preserve the qualification there
+-}
+
+import qualified Renaming.QualServer as QS
+
+baz :: String
+baz = QS.foo1 : "hello"
@@ -0,0 +1,10 @@
+module Renaming.QualClient where
+
+{- foo is imported qualified as in QualClient. Renaming should
+ preserve the qualification there
+-}
+
+import qualified Renaming.QualServer as QS
+
+baz :: String
+baz = QS.foo : "hello"
@@ -0,0 +1,12 @@
+module Renaming.QualServer
+ (
+ foo1
+ ) where
+
+{- foo is imported qualified as in QualClient. Renaming should
+ preserve the qualification there
+-}
+
+
+foo1 :: Char
+foo1 = 'a'
@@ -0,0 +1,12 @@
+module Renaming.QualServer
+ (
+ foo
+ ) where
+
+{- foo is imported qualified as in QualClient. Renaming should
+ preserve the qualification there
+-}
+
+
+foo :: Char
+foo = 'a'

0 comments on commit 950c5aa

Please sign in to comment.