Don't warn about unused bindings with parents in .hs-boot files; trac #3449

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

diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 6927280..ad7709a 100644 (file)
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -23,7 +23,7 @@ module RnEnv (
        addLocalFixities,
        bindLocatedLocalsFV, bindLocatedLocalsRn,
        bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV,
-       bindTyVarsRn, extendTyVarEnvFVRn,
+       bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
 
        checkDupRdrNames, checkDupAndShadowedRdrNames,
         checkDupNames, checkDupAndShadowedNames, 
@@ -51,7 +51,7 @@ import NameEnv
 import UniqFM
 import DataCon         ( dataConFieldLabels )
 import OccName
-import Module          ( Module, ModuleName )
+import Module          ( ModuleName )
 import PrelNames       ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, 
                          consDataConKey, forall_tv_RDR )
 import Unique
@@ -82,8 +82,8 @@ thenM = (>>=)
 %*********************************************************
 
 \begin{code}
-newTopSrcBinder :: Module -> Located RdrName -> RnM Name
-newTopSrcBinder this_mod (L loc rdr_name)
+newTopSrcBinder :: Located RdrName -> RnM Name
+newTopSrcBinder (L loc rdr_name)
   | Just name <- isExact_maybe rdr_name
   =    -- This is here to catch 
        --   (a) Exact-name binders created by Template Haskell
@@ -95,13 +95,15 @@ newTopSrcBinder this_mod (L loc rdr_name)
        --      data T = (,) Int Int
        -- unless we are in GHC.Tup
     ASSERT2( isExternalName name,  ppr name )
-    do { unless (this_mod == nameModule name)
+    do { this_mod <- getModule
+        ; unless (this_mod == nameModule name)
                 (addErrAt loc (badOrigBinding rdr_name))
        ; return name }
 
 
   | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-  = do { unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
+  = do { this_mod <- getModule
+        ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
                 (addErrAt loc (badOrigBinding rdr_name))
        -- When reading External Core we get Orig names as binders, 
        -- but they should agree with the module gotten from the monad
@@ -137,7 +139,8 @@ newTopSrcBinder this_mod (L loc rdr_name)
                ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } 
          else  
                -- Normal case
-            newGlobalBinder this_mod (rdrNameOcc rdr_name) loc }
+             do { this_mod <- getModule
+                ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } }
 \end{code}
 
 %*********************************************************
@@ -836,7 +839,7 @@ bindLocalName name enclosed_scope
 bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
 bindLocalNamesFV names enclosed_scope
   = do { (result, fvs) <- bindLocalNames names enclosed_scope
-       ; return (result, delListFromNameSet fvs names) }
+       ; return (result, delFVs names fvs) }
 
 
 -------------------------------------
@@ -847,9 +850,17 @@ bindLocatedLocalsFV :: [Located RdrName]
 bindLocatedLocalsFV rdr_names enclosed_scope
   = bindLocatedLocalsRn rdr_names      $ \ names ->
     enclosed_scope names               `thenM` \ (thing, fvs) ->
-    return (thing, delListFromNameSet fvs names)
+    return (thing, delFVs names fvs)
 
 -------------------------------------
+bindTyVarsFV ::  [LHsTyVarBndr RdrName]
+             -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
+             -> RnM (a, FreeVars)
+bindTyVarsFV tyvars thing_inside
+  = bindTyVarsRn tyvars $ \ tyvars' ->
+    do { (res, fvs) <- thing_inside tyvars'
+       ; return (res, delFVs (map hsLTyVarName tyvars') fvs) }
+
 bindTyVarsRn ::  [LHsTyVarBndr RdrName]
              -> ([LHsTyVarBndr Name] -> RnM a)
              -> RnM a
@@ -1032,7 +1043,18 @@ warnUnusedModules mods
 
 warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
 warnUnusedImports gres  = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres)
-warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds   (warnUnusedGREs gres)
+warnUnusedTopBinds gres
+    = ifOptM Opt_WarnUnusedBinds
+    $ do isBoot <- tcIsHsBoot
+         let noParent gre = case gre_par gre of
+                            NoParent -> True
+                            ParentIs _ -> False
+             -- Don't warn about unused bindings with parents in
+             -- .hs-boot files, as you are sometimes required to give
+             -- unused bindings (trac #3449).
+             gres' = if isBoot then filter noParent gres
+                               else                 gres
+         warnUnusedGREs gres'
 
 warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> FreeVars -> RnM ()
 warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds