Refactor part of the renamer to fix Trac #3901

[ghc-hetmet.git] / compiler / rename / RnEnv.lhs

diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index c81d701..c3b5592 100644 (file)
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -26,8 +26,8 @@ module RnEnv (
        bindTyVarsRn, extendTyVarEnvFVRn,
 
        checkDupRdrNames, checkDupAndShadowedRdrNames,
-        checkDupAndShadowedNames, 
-       mapFvRn, mapFvRnCPS,
+        checkDupNames, checkDupAndShadowedNames, 
+       addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
        warnUnusedMatches, warnUnusedModules, warnUnusedImports, 
        warnUnusedTopBinds, warnUnusedLocalBinds,
        dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg
@@ -284,12 +284,12 @@ lookupSubBndr parent doc rdr_name
   | otherwise  -- Find all the things the rdr-name maps to
   = do {       -- and pick the one with the right parent name
        ; env <- getGlobalRdrEnv
-        ; let gres = (lookupGlobalRdrEnv env (rdrNameOcc rdr_name))
+        ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
        ; case pick parent gres  of
                -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName!
                --     The latter does pickGREs, but we want to allow 'x'
                --     even if only 'M.x' is in scope
-           [gre] -> do { addUsedRdrName gre rdr_name
+           [gre] -> do { addUsedRdrNames (used_rdr_names gre)
                         ; return (gre_name gre) }
            []    -> do { addErr (unknownSubordinateErr doc rdr_name)
                        ; traceRn (text "RnEnv.lookup_sub_bndr" <+> (ppr rdr_name $$ ppr gres))
@@ -306,6 +306,15 @@ lookupSubBndr parent doc rdr_name
     right_parent p (GRE { gre_par = ParentIs p' }) = p==p' 
     right_parent _ _                               = False
 
+    -- Note [Usage for sub-bndrs]
+    used_rdr_names gre
+      | isQual rdr_name = [rdr_name]
+      | otherwise       = case gre_prov gre of
+                            LocalDef -> [rdr_name]
+                           Imported is -> map mk_qual_rdr is
+    mk_qual_rdr imp_spec = mkRdrQual (is_as (is_decl imp_spec)) rdr_occ
+    rdr_occ = rdrNameOcc rdr_name    
+
 newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
 newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
 
@@ -320,12 +329,25 @@ lookupFamInstDeclBndr tyclGroupEnv (L loc rdr_name)
         (gre:_) -> return $ gre_name gre
           -- if there is more than one, an error will be raised elsewhere
         []      -> lookupOccRn rdr_name
+\end{code}
 
+Note [Usage for sub-bndrs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+If you have this
+   import qualified M( C( f ) ) 
+   intance M.C T where
+     f x = x
+then is the qualified import M.f used?  Obviously yes.
+But the RdrName used in the instance decl is unqualified.  In effect,
+we fill in the qualification by looking for f's whose class is M.C
+But when adding to the UsedRdrNames we must make that qualification
+explicit, otherwise we get "Redundant import of M.C".
 
 --------------------------------------------------
 --             Occurrences
 --------------------------------------------------
 
+\begin{code}
 getLookupOccRn :: RnM (Name -> Maybe Name)
 getLookupOccRn
   = getLocalRdrEnv                     `thenM` \ local_env ->
@@ -629,7 +651,6 @@ type MiniFixityEnv = FastStringEnv (Located Fixity)
 --------------------------------
 -- Used for nested fixity decls to bind names along with their fixities.
 -- the fixities are given as a UFM from an OccName's FastString to a fixity decl
--- Also check for unused binders
 bindLocalNamesFV_WithFixities :: [Name]
                              -> MiniFixityEnv
                              -> RnM (a, FreeVars) -> RnM (a, FreeVars)
@@ -968,11 +989,19 @@ checkShadowedOccs (global_env,local_env) loc_occs
 
 \begin{code}
 -- A useful utility
+addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
+addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside
+                               ; return (res, fvs1 `plusFV` fvs2) }
+
 mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
 mapFvRn f xs = do stuff <- mapM f xs
                   case unzip stuff of
                       (ys, fvs_s) -> return (ys, plusFVs fvs_s)
 
+mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
+mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)
+mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }
+
 -- because some of the rename functions are CPSed:
 -- maps the function across the list from left to right; 
 -- collects all the free vars into one set