Permalink
Browse files

WIP. Working in hsVisiblePNs to use hsVisibleFDs

  • Loading branch information...
1 parent 78a1c3b commit 399886203da49b8ab6bd1905acd9046f8f01c0a7 Alan Zimmerman committed Feb 16, 2014
@@ -131,7 +131,7 @@ reallyDoDuplicating pn newName inscopes renamed = do
--f: names that might be shadowd by the new name,
--d: names that might clash with the new name
- let dv = hsVisibleNames ln declsr --dv: names may shadow new name
+ dv <- hsVisibleNames ln declsr --dv: names may shadow new name
let vars = nub (f `union` d `union` dv)
newNameGhc <- mkNewGhcName Nothing newName
@@ -380,7 +380,7 @@ pnsNeedRenaming dest parent _liftedDecls pns
= do
let (f,d) = hsFDsFromInside dest --f: free variable names that may be shadowed by pn
--d: declaread variables names that may clash with pn
- let vs = hsVisiblePNs pn parent --vs: declarad variables that may shadow pn
+ vs <- hsVisiblePNs pn parent --vs: declarad variables that may shadow pn
let -- inscpNames = map (\(x,_,_,_)->x) $ inScopeInfo inscps
vars = map pNtoName (nub (f `union` d `union` vs) \\ [pn]) -- `union` inscpNames
-- if elem (pNtoName pn) vars || isInScopeAndUnqualified (pNtoName pn) inscps && findEntity pn dest
@@ -1509,7 +1509,7 @@ foldParams pns ((GHC.Match pats mt rhs)::GHC.Match GHC.Name) _decls demotedDecls
getClashedNames oldNames newNames match
= do let (_f,d) = hsFDsFromInside match
-- ds' <- mapM (flip hsVisiblePNs match) oldNames
- let ds' = map (flip hsVisiblePNs match) oldNames
+ ds' <- mapM (flip hsVisiblePNs match) oldNames
-- return clashed names
return (filter (\x->elem ({- pNtoName -} x) newNames) --Attention: nub
( nub (d `union` (nub.concat) ds')))
@@ -355,7 +355,7 @@ renameTopLevelVarName oldPN newName newNameGhc modName renamed existChecking exp
isInScopeUnqual <- isInScopeAndUnqualifiedGhc newName (Just newNameGhc)
logm $ "renameTopLevelVarName:after isInScopeUnqual"
logm $ "renameTopLevelVarName:oldPN=" ++ showGhc oldPN
- let ds = hsVisibleNames oldPN renamed
+ ds <- hsVisibleNames oldPN renamed
logm $ "renameTopLevelVarName:ds computed=" ++ (show ds)
-- '\\[pNtoName oldPN]' handles the case in which the new name is same as the old name
if existChecking && elem newName ((nub (ds `union` f)) \\[nameToString oldPN])
@@ -492,7 +492,7 @@ renameInClientMod oldPN newName newNameGhc targetModule@(_,modSummary) = do
logm $ "renameInClientMod.worker"
renamed <- getRefactRenamed
isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName' Nothing
- let vs = hsVisibleNames oldPN' renamed --Does this check names other than variable names?
+ vs <- hsVisibleNames oldPN' renamed --Does this check names other than variable names?
if elem newName' ((nub vs) \\ [nameToString oldPN']) || isInScopeUnqualNew
then void $ renamePN oldPN' newNameGhc' True True renamed --rename to qualified Name
else void $ renamePN oldPN' newNameGhc' True False renamed -- do not qualify
@@ -988,18 +988,17 @@ getDeclaredVars bs = concatMap vars bs
-- | Same as `hsVisiblePNs' except that the returned identifiers are
-- in String format.
hsVisibleNames:: (FindEntity t1, SYB.Data t1, SYB.Data t2,HsValBinds t2)
- => t1 -> t2 -> [String]
-hsVisibleNames e t = res
- where
- d = hsVisiblePNs e t
- res = ((nub . map showGhc) d)
+ => t1 -> t2 -> RefactGhc [String]
+hsVisibleNames e t = do
+ d <- hsVisiblePNs e t
+ return ((nub . map showGhc) d)
-- | Given syntax phrases e and t, if e occurs in t, then return those
-- variables which are declared in t and accessible to e, otherwise
-- return [].
-hsVisiblePNs :: (FindEntity e, SYB.Data e, SYB.Data t,HsValBinds t)
+hsVisiblePNsOld :: (FindEntity e, SYB.Data e, SYB.Data t,HsValBinds t)
=> e -> t -> [GHC.Name]
-hsVisiblePNs e t = res
+hsVisiblePNsOld e t = res
where
{- -}
r = (applyTU (full_tdTUGhc (constTU [] `adhocTU` top
@@ -1133,31 +1132,61 @@ hsVisiblePNs e t =applyTU (full_tdTU (constTU [] `adhocTU` mod
------------------------------------------------------------------------
+-- | Given syntax phrases e and t, if e occurs in t, then return those
+-- variables which are declared in t and accessible to e, otherwise
+-- return [].
+hsVisiblePNs :: (FindEntity e, SYB.Data e, SYB.Data t,HsValBinds t)
+ => e -> t -> RefactGhc [GHC.Name]
+hsVisiblePNs e t = do
+ (_fn,DN dn) <- hsVisibleFDs e t
+ return dn
+
+------------------------------------------------------------------------
+
-- | Given syntax phrases e and t, if e occurs in t, then return those
-- free and declared variables which are visible from e in t.
hsVisibleFDs :: (FindEntity e, SYB.Data e, SYB.Data t,HsValBinds t)
=> e -> t -> RefactGhc (FreeNames,DeclaredNames)
hsVisibleFDs e t = do
- parsed <- getRefactParsed
- hsVisibleFDs'' parsed e t
-
-hsVisibleFDs'' :: (FindEntity e, SYB.Data e, SYB.Data t,HsValBinds t)
- => GHC.ParsedSource -> e -> t -> RefactGhc (FreeNames,DeclaredNames)
-hsVisibleFDs'' parsed e t = do
res
where
+ -- TODO: this is effectively a recursive descent approach, where
+ -- each syntax element processor knows exactly what it needs
+ -- in terms of sub-elements. Hence as an optimisation,
+ -- consider calling the relevent element directly, instead
+ -- of looping back into the main function.
res = (const err -- emptyFD
+ `SYB.extQ` renamed
+ `SYB.extQ` valbinds
`SYB.extQ` hsbind
`SYB.extQ` lmatch
`SYB.extQ` grhss
`SYB.extQ` lgrhs
`SYB.extQ` lexpr
+ `SYB.extQ` tycldecls
) t
+ renamed :: GHC.RenamedSource -> RefactGhc (FreeNames,DeclaredNames)
+ renamed (g,_i,_ex,_d)
+ | findEntity e g = do
+ dfds <- hsVisibleFDs e $ GHC.hs_valds g
+ tfds <- hsVisibleFDs e $ GHC.hs_tyclds g
+ ifds <- hsVisibleFDs e $ GHC.hs_instds g
+ return $ dfds <> tfds <> ifds
+ renamed _ = return emptyFD
+
+ valbinds :: (GHC.HsValBindsLR GHC.Name GHC.Name) -> RefactGhc (FreeNames,DeclaredNames)
+ valbinds vb@(GHC.ValBindsIn bindsBag sigs)
+ | findEntity e vb = do
+ fdsb <- mapM (hsVisibleFDs e) $ hsBinds bindsBag
+ fdss <- mapM (hsVisibleFDs e) sigs
+ return $ mconcat fdss <> mconcat fdsb
+ valbinds _ = return emptyFD
+
hsbind :: (GHC.LHsBind GHC.Name) -> RefactGhc (FreeNames,DeclaredNames)
hsbind ((GHC.L _ (GHC.FunBind _n _ (GHC.MatchGroup matches _) _ _ _)))
| findEntity e matches = do
- fds <- mapM (hsVisibleFDs'' parsed e) matches
+ fds <- mapM (hsVisibleFDs e) matches
return $ mconcat fds
hsbind _ = return emptyFD
@@ -1166,15 +1195,15 @@ hsVisibleFDs'' parsed e t = do
| findEntity e pats = return emptyFD -- TODO: extend this
| findEntity e rhs = do
( pf,pd) <- hsFreeAndDeclaredGhc pats
- ( rf,rd) <- hsVisibleFDs'' parsed e rhs
+ ( rf,rd) <- hsVisibleFDs e rhs
return (pf <> rf,pd <> rd)
-- | findEntity e rhs = error $ "hsVisibleFDs:lmatch.rhs:" ++ show (rf,pd,rd)
lmatch _ =return emptyFD
grhss :: (GHC.GRHSs GHC.Name) -> RefactGhc (FreeNames,DeclaredNames)
grhss (GHC.GRHSs guardedRhss lstmts)
| findEntity e guardedRhss = do
- fds <- mapM (hsVisibleFDs'' parsed e) guardedRhss
+ fds <- mapM (hsVisibleFDs e) guardedRhss
return $ mconcat fds
| findEntity e guardedRhss = error $ "hsVisibleFDs.grhss:guar"
-- | findEntity e lstmts = hsVisibleFDs e lstmts
@@ -1183,14 +1212,22 @@ hsVisibleFDs'' parsed e t = do
lgrhs :: GHC.LGRHS GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lgrhs (GHC.L _ (GHC.GRHS stmts ex))
- | findEntity e stmts = hsVisibleFDs'' parsed e stmts
- | findEntity e ex = hsVisibleFDs'' parsed e ex
+ | findEntity e stmts = hsVisibleFDs e stmts
+ | findEntity e ex = hsVisibleFDs e ex
lgrhs _ = error $ "hsVisibleFDs.lgrhs:emptyFD"
lexpr :: GHC.LHsExpr GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
- lexpr (GHC.L _ e) = return emptyFD
+ lexpr (GHC.L _ _ex) = return emptyFD
-- lexpr = error $ "hsVisibleFDs.lexpr undefined"
+
+ tycldecls :: [[GHC.LTyClDecl GHC.Name]] -> RefactGhc (FreeNames,DeclaredNames)
+ tycldecls tcds
+ | findEntity e tcds = do
+ fds <- mapM (hsVisibleFDs e) tcds
+ return $ mconcat fds
+ tycldecls _ = return emptyFD
+
err = error $ "hsVisibleFDs:no match for:" ++ (SYB.showData SYB.Renamer 0 t)
-- ---------------------------------------------------------------------
@@ -2376,6 +2413,41 @@ instance HsValBinds [GHC.SyntaxExpr GHC.Name] where
-- ---------------------------------------------------------------------
+instance HsValBinds (GHC.LSig GHC.Name) where
+ hsValBinds _ = emptyValBinds
+ replaceValBinds old _new = error $ "replaceValBinds (GHC.LSig GHC.Name) undefined for:" ++ (showGhc old)
+ hsTyDecls _ = []
+
+-- ---------------------------------------------------------------------
+
+instance HsValBinds [[GHC.LTyClDecl GHC.Name]] where
+ hsValBinds _ = emptyValBinds
+ replaceValBinds old _new = error $ "replaceValBinds [[GHC.LTyClDecl GHC.Name]] undefined for:" ++ (showGhc old)
+ hsTyDecls _ = []
+
+-- ---------------------------------------------------------------------
+
+instance HsValBinds [GHC.LTyClDecl GHC.Name] where
+ hsValBinds _ = emptyValBinds
+ replaceValBinds old _new = error $ "replaceValBinds [GHC.LTyClDecl GHC.Name] undefined for:" ++ (showGhc old)
+ hsTyDecls _ = []
+
+-- ---------------------------------------------------------------------
+
+instance HsValBinds (GHC.LTyClDecl GHC.Name) where
+ hsValBinds _ = error $ "hsValBinds (GHC.LTyClDecl GHC.Name) must pull out tcdMeths"
+ replaceValBinds old _new = error $ "replaceValBinds (GHC.LTyClDecl GHC.Name) undefined for:" ++ (showGhc old)
+ hsTyDecls _ = []
+
+-- ---------------------------------------------------------------------
+
+instance HsValBinds [GHC.LInstDecl GHC.Name] where
+ hsValBinds _ = emptyValBinds
+ replaceValBinds old _new = error $ "replaceValBinds [GHC.LInstDecl GHC.Name] undefined for:" ++ (showGhc old)
+ hsTyDecls _ = []
+
+-- ---------------------------------------------------------------------
+
@@ -4487,7 +4559,7 @@ autoRenameLocalVar modifyToks pn t = do
where
worker tt =do (f,d) <- hsFDNamesFromInside tt
- let ds = hsVisibleNames pn (hsValBinds tt)
+ ds <- hsVisibleNames pn (hsValBinds tt)
let newNameStr=mkNewName (nameToString pn) (nub (f `union` d `union` ds)) 1
newName <- mkNewGhcName Nothing newNameStr
if modifyToks
View
@@ -865,7 +865,7 @@ check_dup_names names
-- let [decl] = definingDeclsNames [tup] (hsBinds renamed) False False
let
comp = do
- let r = hsVisiblePNs tl1 tup
+ r <- hsVisiblePNs tl1 tup
return r
((res),_s) <- runRefactGhc comp $ initialState { rsModule = initRefactModule t toks }
@@ -887,7 +887,7 @@ check_dup_names names
-- (SYB.showData SYB.Renamer 0 decl) `shouldBe` ""
let
comp = do
- let r = hsVisiblePNs tl1 decl
+ r <- hsVisiblePNs tl1 decl
return r
((res),_s) <- runRefactGhc comp $ initialState { rsModule = initRefactModule t toks }
@@ -906,7 +906,7 @@ check_dup_names names
(showGhc rhs) `shouldBe` "let ll = 34 in ll GHC.Num.+ z"
let
comp = do
- let r = hsVisiblePNs tl1 rhs
+ r <- hsVisiblePNs tl1 rhs
return r
((res),_s) <- runRefactGhc comp $ initialState { rsModule = initRefactModule t toks }
@@ -923,12 +923,13 @@ check_dup_names names
comp = do
renamed <- getRefactRenamed
let Just tl1 = locToName (41,11) renamed -- :: (Maybe (GHC.Located (GHC.HsExpr GHC.Name)))
- let r = hsVisiblePNs tl1 renamed
+ r <- hsVisiblePNs tl1 renamed
-- let r = hsVisiblePNsGhc tl1 renamed
let fvs = map (\b -> (showGhc b,getFreeVars [b])) (hsBinds renamed)
let dvs = getDeclaredVars $ hsBinds renamed
return (tl1,r,fvs,dvs)
- ((tl,res,_f,d),_s) <- runRefactGhc comp $ initialState { rsModule = initRefactModule t toks }
+ -- ((tl,res,_f,d),_s) <- runRefactGhc comp $ initialState { rsModule = initRefactModule t toks }
+ ((tl,res,_f,d),_s) <- runRefactGhc comp $ initialLogOnState { rsModule = initRefactModule t toks }
(showGhc tl) `shouldBe` "modu"
-- (showGhc f) `shouldBe` ""
@@ -18,12 +18,12 @@ import Test.Hspec
-- import Language.Haskell.Refact.Renaming
import Language.Haskell.Refact.Utils
-- import Language.Haskell.Refact.Utils.GhcBugWorkArounds
-import Language.Haskell.Refact.Utils.GhcVersionSpecific
+-- import Language.Haskell.Refact.Utils.GhcVersionSpecific
import Language.Haskell.Refact.Utils.LocUtils
import Language.Haskell.Refact.Utils.Monad
import Language.Haskell.Refact.Utils.MonadFunctions
import Language.Haskell.Refact.Utils.TypeSyn
-import Language.Haskell.Refact.Utils.TypeUtils
+-- import Language.Haskell.Refact.Utils.TypeUtils
-- import System.Directory
-- ---------------------------------------------------------------------

0 comments on commit 3998862

Please sign in to comment.