Support re-export deprecations (re #4879)wip/T4879

This is basically the patch originally implemented by Ian Lynagh
forward-ported to GHC 7.10/11

17 files changed, 197 insertions, 99 deletions

diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs
index 495e96ded8..c51c6eea1c 100644
--- a/compiler/basicTypes/Avail.hs
+++ b/compiler/basicTypes/Avail.hs
@@ -8,24 +8,54 @@ module Avail (
     availsToNameSet,
     availsToNameEnv,
     availName, availNames,
-    stableAvailCmp
+    stableAvailCmp,
+
+    NameWarn(..),
+    nameWarnName,
+    availNameWarns,
   ) where
 
 import Name
 import NameEnv
 import NameSet
 
+import BasicTypes
 import Binary
 import Outputable
 import Util
 
 -- -----------------------------------------------------------------------------
+-- The NameWarn type
+
+data NameWarn = NameWarn Name (Maybe WarningTxt)
+
+nameWarnName :: NameWarn -> Name
+nameWarnName (NameWarn n _) = n
+
+-- XXX?
+instance Eq NameWarn where
+    x == y = nameWarnName x == nameWarnName y
+
+instance Outputable NameWarn where
+    ppr (NameWarn n m) = ppr n <> braces wd
+        where wd = case m of
+                   Nothing -> text "no warning"
+                   Just w -> text "warning:" <+> ppr w
+
+instance Binary NameWarn where
+    put_ h (NameWarn n w) = do put_ h n
+                               put_ h w
+    get h = do n <- get h
+               w <- get h
+               return (NameWarn n w)
+
+-- -----------------------------------------------------------------------------
 -- The AvailInfo type
 
 -- | Records what things are "available", i.e. in scope
-data AvailInfo = Avail Name      -- ^ An ordinary identifier in scope
-               | AvailTC Name
-                         [Name]  -- ^ A type or class in scope. Parameters:
+data AvailInfo = Avail NameWarn  -- ^ An ordinary identifier in scope
+               | AvailTC NameWarn
+                     [NameWarn]  -- ^ A type or class in scope. Parameters:
                                  --
                                  --  1) The name of the type or class
                                  --  2) The available pieces of type or class.
@@ -44,10 +74,14 @@ type Avails = [AvailInfo]
 
 -- | Compare lexicographically
 stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
-stableAvailCmp (Avail n1)     (Avail n2)     = n1 `stableNameCmp` n2
+stableAvailCmp (Avail n1)     (Avail n2)     = nameWarnName n1 `stableNameCmp`
+                                               nameWarnName n2
 stableAvailCmp (Avail {})     (AvailTC {})   = LT
-stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp`
-                                               (cmpList stableNameCmp ns ms)
+stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (nameWarnName n `stableNameCmp`
+                                                nameWarnName m) `thenCmp`
+                                               (cmpList stableNameCmp
+                                                        (map nameWarnName ns)
+                                                        (map nameWarnName ms))
 stableAvailCmp (AvailTC {})   (Avail {})     = GT
 
 
@@ -66,13 +100,19 @@ availsToNameEnv avails = foldr add emptyNameEnv avails
 -- | Just the main name made available, i.e. not the available pieces
 -- of type or class brought into scope by the 'GenAvailInfo'
 availName :: AvailInfo -> Name
-availName (Avail n)     = n
-availName (AvailTC n _) = n
+availName = nameWarnName . availNameWarn
+
+availNameWarn :: AvailInfo -> NameWarn
+availNameWarn (Avail nw)     = nw
+availNameWarn (AvailTC nw _) = nw
 
 -- | All names made available by the availability information
 availNames :: AvailInfo -> [Name]
-availNames (Avail n)      = [n]
-availNames (AvailTC _ ns) = ns
+availNames = map nameWarnName . availNameWarns
+
+availNameWarns :: AvailInfo -> [NameWarn]
+availNameWarns (Avail nw)      = [nw]
+availNameWarns (AvailTC _ nws) = nws
 
 -- -----------------------------------------------------------------------------
 -- Printing
@@ -100,4 +140,3 @@ instance Binary AvailInfo where
               _ -> do ab <- get bh
                       ac <- get bh
                       return (AvailTC ab ac)
-
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs
index 9e52844b6b..6adb66966f 100644
--- a/compiler/basicTypes/BasicTypes.hs
+++ b/compiler/basicTypes/BasicTypes.hs
@@ -268,7 +268,7 @@ initialVersion = 1
 -- For SourceText usage, see note [Pragma source text]
 data WarningTxt = WarningTxt (Located SourceText) [Located FastString]
                 | DeprecatedTxt (Located SourceText) [Located FastString]
-    deriving (Eq, Data, Typeable)
+    deriving (Eq, Ord, Data, Typeable)
 
 instance Outputable WarningTxt where
     ppr (WarningTxt    _ ws) = doubleQuotes (vcat (map (ftext . unLoc) ws))
diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs
index 094347a4fa..9f9c8d8a9c 100644
--- a/compiler/basicTypes/RdrName.hs
+++ b/compiler/basicTypes/RdrName.hs
@@ -62,6 +62,7 @@ module RdrName (
 
 #include "HsVersions.h"
 
+import BasicTypes
 import Module
 import Name
 import Avail
@@ -509,22 +510,25 @@ That's why plusParent picks the "best" case.
 -- | make a 'GlobalRdrEnv' where all the elements point to the same
 -- Provenance (useful for "hiding" imports, or imports with
 -- no details).
-gresFromAvails :: Provenance -> [AvailInfo] -> [GlobalRdrElt]
+gresFromAvails :: (Maybe WarningTxt -> Provenance) -> [AvailInfo]
+               -> [GlobalRdrElt]
 gresFromAvails prov avails
   = concatMap (gresFromAvail (const prov)) avails
 
-gresFromAvail :: (Name -> Provenance) -> AvailInfo -> [GlobalRdrElt]
+gresFromAvail :: (Name -> Maybe WarningTxt -> Provenance) -> AvailInfo
+              -> [GlobalRdrElt]
 gresFromAvail prov_fn avail
   = [ GRE {gre_name = n,
            gre_par = mkParent n avail,
-           gre_prov = prov_fn n}
-    | n <- availNames avail ]
-  where
+           gre_prov = prov_fn n mw}
+    | NameWarn n mw <- availNameWarns avail ]
 
 mkParent :: Name -> AvailInfo -> Parent
 mkParent _ (Avail _)                 = NoParent
-mkParent n (AvailTC m _) | n == m    = NoParent
-                         | otherwise = ParentIs m
+mkParent n (AvailTC m _) | n == mn   = NoParent
+                         | otherwise = ParentIs mn
+  where
+    mn = nameWarnName m
 
 emptyGlobalRdrEnv :: GlobalRdrEnv
 emptyGlobalRdrEnv = emptyOccEnv
@@ -741,7 +745,7 @@ shadow_name env name
            (Just old_mod, Just new_mod) | new_mod == old_mod -> Nothing
            (Just old_mod, _) -> Just (old_gre { gre_prov = Imported [fake_imp_spec] })
               where
-                 fake_imp_spec = ImpSpec id_spec ImpAll  -- Urgh!
+                 fake_imp_spec = ImpSpec id_spec ImpAll Nothing -- Urgh!
                  old_mod_name = moduleName old_mod
                  id_spec = ImpDeclSpec { is_mod = old_mod_name
                                        , is_as = old_mod_name
@@ -815,7 +819,8 @@ data Provenance
                         -- INVARIANT: the list of 'ImportSpec' is non-empty
 
 data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec,
-                            is_item :: ImpItemSpec }
+                            is_item :: ImpItemSpec,
+                            is_warning :: Maybe WarningTxt }
                 deriving( Eq, Ord )
 
 -- | Describes a particular import declaration and is
@@ -860,8 +865,8 @@ qualSpecOK :: ModuleName -> ImportSpec -> Bool
 qualSpecOK mod is = mod == is_as (is_decl is)
 
 importSpecLoc :: ImportSpec -> SrcSpan
-importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl
-importSpecLoc (ImpSpec _    item)   = is_iloc item
+importSpecLoc (ImpSpec decl ImpAll _) = is_dloc decl
+importSpecLoc (ImpSpec _    item _)   = is_iloc item
 
 importSpecModule :: ImportSpec -> ModuleName
 importSpecModule is = is_mod (is_decl is)
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
index f01a9d8174..a5f97dea35 100644
--- a/compiler/deSugar/DsMonad.hs
+++ b/compiler/deSugar/DsMonad.hs
@@ -258,7 +258,7 @@ loadModule doc mod
            Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
        } }
   where
-    prov     = Imported [ImpSpec { is_decl = imp_spec, is_item = ImpAll }]
+    prov mw  = Imported [ImpSpec { is_decl = imp_spec, is_item = ImpAll, is_warning = mw }]
     imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,
                              is_dloc = wiredInSrcSpan, is_as = name }
     name = moduleName mod
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 9f78a2b8b2..a49b6d4521 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -1668,7 +1668,7 @@ data WarnDecls name = Warnings { wd_src :: SourceText
 type LWarnDecl name = Located (WarnDecl name)
 
 data WarnDecl name = Warning [Located name] WarningTxt
-  deriving (Data, Typeable)
+  deriving (Eq, Data, Typeable)
 
 instance OutputableBndr name => Outputable (WarnDecls name) where
     ppr (Warnings _ decls) = ppr decls
diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs
index 42b374abfc..45ee8acaf6 100644
--- a/compiler/hsSyn/HsImpExp.hs
+++ b/compiler/hsSyn/HsImpExp.hs
@@ -13,6 +13,7 @@ module HsImpExp where
 import Module           ( ModuleName )
 import HsDoc            ( HsDocString )
 import OccName          ( HasOccName(..), isTcOcc, isSymOcc )
+import HsDecls          ( WarnDecl )
 import BasicTypes       ( SourceText )
 
 import Outputable
@@ -169,6 +170,7 @@ data IE name
   | IEGroup             Int HsDocString  -- ^ Doc section heading
   | IEDoc               HsDocString      -- ^ Some documentation
   | IEDocNamed          String           -- ^ Reference to named doc
+  | IEWarning           (WarnDecl name)
   deriving (Eq, Data, Typeable)
 
 ieName :: IE name -> name
@@ -187,6 +189,7 @@ ieNames (IEModuleContents _    ) = []
 ieNames (IEGroup          _ _  ) = []
 ieNames (IEDoc            _    ) = []
 ieNames (IEDocNamed       _    ) = []
+ieNames (IEWarning {}          ) = []
 
 pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc
 pprImpExp name = type_pref <+> pprPrefixOcc name
@@ -207,3 +210,4 @@ instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where
     ppr (IEGroup n _)           = text ("<IEGroup: " ++ (show n) ++ ">")
     ppr (IEDoc doc)             = ppr doc
     ppr (IEDocNamed string)     = text ("<IEDocNamed: " ++ string ++ ">")
+    ppr (IEWarning w)           = text "<IEWarning:" <+> ppr w <+> char '>'
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index e7cc3adc19..7b89147f2c 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -1102,8 +1102,8 @@ mkIfaceExports exports
     sort_subs (Avail n) = Avail n
     sort_subs (AvailTC n []) = AvailTC n []
     sort_subs (AvailTC n (m:ms))
-       | n==m      = AvailTC n (m:sortBy stableNameCmp ms)
-       | otherwise = AvailTC n (sortBy stableNameCmp (m:ms))
+       | n==m      = AvailTC n (m:sortBy (stableNameCmp `on` nameWarnName) ms)
+       | otherwise = AvailTC n (sortBy (stableNameCmp `on` nameWarnName) (m:ms))
        -- Maintain the AvailTC Invariant
 
 {-
diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs
index 82081bf1a3..37e272e70e 100644
--- a/compiler/main/DynamicLoading.hs
+++ b/compiler/main/DynamicLoading.hs
@@ -213,7 +213,7 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
                     -- Try and find the required name in the exports
                     let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name
                                                 , is_qual = False, is_dloc = noSrcSpan }
-                        provenance = Imported [ImpSpec decl_spec ImpAll]
+                        provenance mw = Imported [ImpSpec decl_spec ImpAll mw]
                         env = mkGlobalRdrEnv (gresFromAvails provenance (mi_exports iface))
                     case lookupGRE_RdrName rdr_name env of
                         [gre] -> return (Just (gre_name gre))
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 3b28635028..82c5b2296a 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -1752,17 +1752,21 @@ tyThingsTyVars tts =
 -- | The Names that a TyThing should bring into scope.  Used to build
 -- the GlobalRdrEnv for the InteractiveContext.
 tyThingAvailInfo :: TyThing -> AvailInfo
-tyThingAvailInfo (ATyCon t)
-   = case tyConClass_maybe t of
-        Just c  -> AvailTC n (n : map getName (classMethods c)
-                  ++ map getName (classATs c))
-             where n = getName c
-        Nothing -> AvailTC n (n : map getName dcs ++
-                                   concatMap dataConFieldLabels dcs)
-             where n = getName t
-                   dcs = tyConDataCons t
-tyThingAvailInfo t
-   = Avail (getName t)
+tyThingAvailInfo t = case t of
+     ATyCon t ->
+         let (n, ns) = case tyConClass_maybe t of
+                       Just c  -> (n, n : map getName (classMethods c)
+                                       ++ map getName (classATs c))
+                           where n = getName c
+
+                       Nothing -> (n, n : map getName dcs ++
+                                          concatMap dataConFieldLabels dcs)
+                           where n = getName t
+                                 dcs = tyConDataCons t
+         in AvailTC (mkNameWarn n) (map mkNameWarn ns)
+     _ -> Avail (mkNameWarn $ getName t)
+   where
+     mkNameWarn name = NameWarn name Nothing
 
 {-
 ************************************************************************
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 70c61f2215..f921f26d8b 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -855,7 +855,7 @@ availsToGlobalRdrEnv mod_name avails
   where
       -- We're building a GlobalRdrEnv as if the user imported
       -- all the specified modules into the global interactive module
-    imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
+    imp_prov mw = Imported [ImpSpec { is_decl = decl, is_item = ImpAll, is_warning = mw }]
     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
                          is_qual = False,
                          is_dloc = srcLocSpan interactiveSrcLoc }
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index e3760906dd..2ba131dd79 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -582,6 +582,7 @@ export  :: { OrdList (LIE RdrName) }
                                              [mj AnnModule $1] }
         |  'pattern' qcon            {% amsu (sLL $1 $> (IEVar $2))
                                              [mj AnnPattern $1] }
+        |  '{-# DEPRECATED' deprecations '#-}' { (mapOL (fmap IEWarning) $2) }
 
 export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }
         : {- empty -}             { sL0 ([],ImpExpAbs) }
diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs
index 2303a8edd3..94c8328e55 100644
--- a/compiler/prelude/PrelInfo.hs
+++ b/compiler/prelude/PrelInfo.hs
@@ -119,10 +119,12 @@ wired-in Ids.
 
 ghcPrimExports :: [IfaceExport]
 ghcPrimExports
- = map (Avail . idName) ghcPrimIds ++
-   map (Avail . idName . primOpId) allThePrimOps ++
-   [ AvailTC n [n]
-   | tc <- funTyCon : primTyCons, let n = tyConName tc  ]
+    = map (Avail . mkNameWarn . idName) ghcPrimIds ++
+      map (Avail . mkNameWarn . idName . primOpId) allThePrimOps ++
+      [ AvailTC (mkNameWarn n) [mkNameWarn n]
+      | tc <- funTyCon : primTyCons, let n = tyConName tc  ]
+  where
+    mkNameWarn n = NameWarn n Nothing
 
 {-
 ************************************************************************
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index f7a450414d..bd3073a5e5 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -905,10 +905,12 @@ addUsedRdrNames rdrs
                    (\s -> foldr Set.insert s rdrs) }
 
 warnIfDeprecated :: GlobalRdrElt -> RnM ()
-warnIfDeprecated gre@(GRE { gre_name = name, gre_prov = Imported (imp_spec : _) })
+warnIfDeprecated gre@(GRE { gre_name = name, gre_prov = Imported imp_specs@(imp_spec : _) })
   = do { dflags <- getDynFlags
        ; when (wopt Opt_WarnWarningsDeprecations dflags) $
          do { iface <- loadInterfaceForName doc name
+            ; unless (any isNothing $ map is_warning imp_specs) $
+                mapM_ (addWarn . mk_msg . fromJust . is_warning) imp_specs
             ; case lookupImpDeprec iface gre of
                 Just txt -> addWarn (mk_msg txt)
                 Nothing  -> return () } }
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 102deb0b4e..0fed3933d6 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -44,7 +44,7 @@ import ListSetOps
 import Control.Monad
 import Data.Map         ( Map )
 import qualified Data.Map as Map
-import Data.List        ( partition, (\\), find )
+import Data.List        ( partition, find )
 import qualified Data.Set as Set
 import System.FilePath  ((</>))
 import System.IO
@@ -555,12 +555,12 @@ getLocalNonValBinders fixity_env
       -- declaration, not just the name
     new_simple :: Located RdrName -> RnM AvailInfo
     new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name
-                            ; return (Avail nm) }
+                            ; return (mkAvail nm) }
 
     new_tc tc_decl              -- NOT for type/data instances
         = do { let bndrs = hsLTyClDeclBinders tc_decl
              ; names@(main_name : _) <- mapM newTopSrcBinder bndrs
-             ; return (AvailTC main_name names) }
+             ; return (mkAvailTC main_name names) }
 
     new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
     new_assoc (L _ (TyFamInstD {})) = return []
@@ -583,9 +583,14 @@ getLocalNonValBinders fixity_env
     new_di mb_cls ti_decl
         = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl)
              ; sub_names <- mapM newTopSrcBinder (hsDataFamInstBinders ti_decl)
-             ; return (AvailTC (unLoc main_name) sub_names) }
+             ; return (mkAvailTC (unLoc main_name) sub_names) }
                         -- main_name is not bound here!
 
+    -- XXX
+    mkNameWarn n = NameWarn n Nothing
+    mkAvail n = Avail (mkNameWarn n)
+    mkAvailTC n ns = AvailTC (mkNameWarn n) (map mkNameWarn ns)
+
 {-
 Note [Looking up family names in family instances]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -647,7 +652,7 @@ filterImports
 filterImports iface decl_spec Nothing
   = return (Nothing, gresFromAvails prov (concatMap mi_exports iface))
   where
-    prov = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll }]
+    prov mw = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll, is_warning = mw }]
 
 
 filterImports ifaces decl_spec (Just (want_hiding, L l import_items))
@@ -662,7 +667,7 @@ filterImports ifaces decl_spec (Just (want_hiding, L l import_items))
             names  = availsToNameSet (map snd items2)
             keep n = not (n `elemNameSet` names)
             pruned_avails = filterAvails keep all_avails
-            hiding_prov = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll }]
+            hiding_prov mw = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll, is_warning = mw }]
 
             gres | want_hiding = gresFromAvails hiding_prov pruned_avails
                  | otherwise   = concatMap (gresFromIE decl_spec) items2
@@ -682,11 +687,15 @@ filterImports ifaces decl_spec (Just (want_hiding, L l import_items))
         -- 'combine' is only called for associated types which appear twice
         -- in the all_avails. In the example, we combine
         --    T(T,T1,T2,T3) and C(C,T)  to give   (T, T(T,T1,T2,T3), Just C)
+        combine :: (Name, AvailInfo, Maybe Name)
+                -> (Name, AvailInfo, Maybe Name)
+                -> (Name, AvailInfo, Maybe Name)
         combine (name1, a1@(AvailTC p1 _), mp1)
                 (name2, a2@(AvailTC p2 _), mp2)
           = ASSERT( name1 == name2 && isNothing mp1 && isNothing mp2 )
-            if p1 == name1 then (name1, a1, Just p2)
-                           else (name1, a2, Just p1)
+            -- XXX?
+            if nameWarnName p1 == name1 then (name1, a1, Just (nameWarnName p2))
+                           else (name1, a2, Just (nameWarnName p1))
         combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y)
 
     lookup_name :: RdrName -> IELookupM (Name, AvailInfo, Maybe Name)
@@ -749,11 +758,12 @@ filterImports ifaces decl_spec (Just (want_hiding, L l import_items))
               -- non-associated ty/cls
               Nothing     -> return ([(IEThingAll (L l name), avail)], warns)
               -- associated ty
-              Just parent -> return ([(IEThingAll (L l name),
-                                       AvailTC name2 (subs \\ [name])),
-                                      (IEThingAll (L l name),
-                                       AvailTC parent [name])],
-                                     warns)
+              Just parent -> let subs' = filter ((name /=) . nameWarnName) subs
+                             in return ([(IEThingAll (L l name),
+                                          AvailTC name2 subs'),
+                                         (IEThingAll (L l name),
+                                          mkAvailTC parent [name])],
+                                        warns)
 
         IEThingAbs (L l tc)
             | want_hiding   -- hiding ( C )
@@ -776,9 +786,9 @@ filterImports ifaces decl_spec (Just (want_hiding, L l import_items))
            let subnames = case ns of   -- The tc is first in ns,
                             [] -> []   -- if it is there at all
                                        -- See the AvailTC Invariant in Avail.hs
-                            (n1:ns1) | n1 == name -> ns1
+                            (n1:ns1) | nameWarnName n1 == name -> ns1
                                      | otherwise  -> ns
-               mb_children = lookupChildren subnames rdr_ns
+               mb_children = lookupChildren (map nameWarnName subnames) rdr_ns
 
            children <- if any isNothing mb_children
                        then failLookupWith BadImport
@@ -787,13 +797,13 @@ filterImports ifaces decl_spec (Just (want_hiding, L l import_items))
            case mb_parent of
              -- non-associated ty/cls
              Nothing     -> return ([(IEThingWith (L l name) children,
-                                      AvailTC name (name:map unLoc children))],
+                                      mkAvailTC name (name:map unLoc children))],
                                     [])
              -- associated ty
              Just parent -> return ([(IEThingWith (L l name) children,
-                                      AvailTC name (map unLoc children)),
+                                      mkAvailTC name (map unLoc children)),
                                      (IEThingWith (L l name) children,
-                                      AvailTC parent [name])],
+                                      mkAvailTC parent [name])],
                                     [])
 
         _other -> failLookupWith IllegalImport
@@ -804,12 +814,17 @@ filterImports ifaces decl_spec (Just (want_hiding, L l import_items))
         mkIEThingAbs l (n, av, Nothing    ) = (IEThingAbs (L l n),
                                                trimAvail av n)
         mkIEThingAbs l (n, _,  Just parent) = (IEThingAbs (L l n),
-                                               AvailTC parent [n])
+                                               mkAvailTC parent [n])
 
         handle_bad_import m = catchIELookup m $ \err -> case err of
           BadImport | want_hiding -> return ([], [BadImportW])
           _                       -> failLookupWith err
 
+
+        -- XXX
+        mkNameWarn n = NameWarn n Nothing
+        mkAvailTC n ns = AvailTC (mkNameWarn n) (map mkNameWarn ns)
+
 type IELookupM = MaybeErr IELookupError
 
 data IELookupWarning
@@ -845,11 +860,12 @@ catIELookupM ms = [ a | Succeeded a <- ms ]
 greExportAvail :: GlobalRdrElt -> AvailInfo
 greExportAvail gre
   = case gre_par gre of
-      ParentIs p                  -> AvailTC p [me]
-      NoParent   | isTyConName me -> AvailTC me [me]
-                 | otherwise      -> Avail   me
+      ParentIs p                  -> AvailTC (NameWarn p Nothing) [me]
+      NoParent | isTyConName me'  -> AvailTC me [me]
+               | otherwise        -> Avail   me
   where
-    me = gre_name gre
+    me' = gre_name gre
+    me = NameWarn me' Nothing -- XXX Wrong?
 
 plusAvail :: AvailInfo -> AvailInfo -> AvailInfo
 plusAvail a1 a2
@@ -868,7 +884,8 @@ plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
 
 trimAvail :: AvailInfo -> Name -> AvailInfo
 trimAvail (Avail n)      _ = Avail n
-trimAvail (AvailTC n ns) m = ASSERT( m `elem` ns) AvailTC n [m]
+-- XXX Wrong?:
+trimAvail (AvailTC n ns) m = ASSERT( m `elem` map nameWarnName ns) AvailTC n [NameWarn m Nothing]
 
 -- | filters 'AvailInfo's by the given predicate
 filterAvails  :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]
@@ -878,10 +895,10 @@ filterAvails keep avails = foldr (filterAvail keep) [] avails
 filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo]
 filterAvail keep ie rest =
   case ie of
-    Avail n | keep n    -> ie : rest
-            | otherwise -> rest
+    Avail n | keep (nameWarnName n) -> ie : rest
+            | otherwise             -> rest
     AvailTC tc ns ->
-        let left = filter keep ns in
+        let left = filter (keep . nameWarnName) ns in
         if null left then rest else AvailTC tc left : rest
 
 -- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's.
@@ -892,9 +909,9 @@ gresFromIE decl_spec (L loc ie, avail)
     is_explicit = case ie of
                     IEThingAll (L _ name) -> \n -> n == name
                     _                     -> \_ -> True
-    prov_fn name = Imported [imp_spec]
+    prov_fn name mw = Imported [imp_spec]
         where
-          imp_spec  = ImpSpec { is_decl = decl_spec, is_item = item_spec }
+          imp_spec  = ImpSpec { is_decl = decl_spec, is_item = item_spec, is_warning = mw }
           item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc }
 
 mkChildEnv :: [GlobalRdrElt] -> NameEnv [Name]
@@ -985,11 +1002,12 @@ type ExportAccum        -- The type of the accumulating parameter of
                         -- the main worker function in rnExports
      = ([LIE Name],             -- Export items with Names
         ExportOccMap,           -- Tracks exported occurrence names
-        [AvailInfo])            -- The accumulated exported stuff
+        [AvailInfo],            -- The accumulated exported stuff
                                 --   Not nub'd!
+        Map Name WarningTxt)    -- Warnings attached to exports
 
 emptyExportAccum :: ExportAccum
-emptyExportAccum = ([], emptyOccEnv, [])
+emptyExportAccum = ([], emptyOccEnv, [], Map.empty)
 
 type ExportOccMap = OccEnv (Name, IE RdrName)
         -- Tracks what a particular exported OccName
@@ -1060,8 +1078,11 @@ exports_from_avail Nothing rdr_env _imports _this_mod
    return (Nothing, avails)
 
 exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
-  = do (ie_names, _, exports) <- foldlM do_litem emptyExportAccum rdr_items
-       return (Just ie_names, exports)
+  = do (ie_names, _, exports, warnMap) <- foldlM do_litem emptyExportAccum rdr_items
+       -- XXX TODO: Ought to check that everything in the warnMap is
+       -- actually exported
+
+       return (Just ie_names, addAvailInfoWarnings warnMap exports)
   where
     do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum
     do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)
@@ -1074,7 +1095,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
                          (qual_name, _, _, _) <- xs ]
 
     exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum
-    exports_from_item acc@(ie_names, occs, exports)
+    exports_from_item acc@(ie_names, occs, exports, warnMap)
                       (L loc (IEModuleContents (L lm mod)))
         | let earlier_mods = [ mod
                              | (L _ (IEModuleContents (L _ mod))) <- ie_names ]
@@ -1112,12 +1133,17 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
              ; traceRn (vcat [ text "export mod" <+> ppr mod
                              , ppr new_exports ])
              ; return (L loc (IEModuleContents (L lm mod)) : ie_names,
-                       occs', new_exports ++ exports) }
+                       occs', new_exports ++ exports, warnMap) }
 
-    exports_from_item acc@(lie_names, occs, exports) (L loc ie)
+    exports_from_item (lie_names, occs, exports, warnMap)
+                      (L _ (IEWarning (Warning (L _ rdr:_) w)))
+        = do n <- lookupGlobalOccRn rdr -- XXX only handles head of warnings
+             return (lie_names, occs, exports, Map.insert n w warnMap)
+
+    exports_from_item acc@(lie_names, occs, exports, warnMap) (L loc ie)
         | isDoc ie
         = do new_ie <- lookup_doc_ie ie
-             return (L loc new_ie : lie_names, occs, exports)
+             return (L loc new_ie : lie_names, occs, exports, warnMap)
 
         | otherwise
         = do (new_ie, avail) <- lookup_ie ie
@@ -1127,7 +1153,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
 
              occs' <- check_occs ie occs (availNames avail)
 
-             return (L loc new_ie : lie_names, occs', avail : exports)
+             return (L loc new_ie : lie_names, occs', avail : exports, warnMap)
 
     -------------
     lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo)
@@ -1153,24 +1179,28 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
                        -- only import T abstractly, or T is a synonym.
                        addErr (exportItemErr ie)
 
-             return (IEThingAll (L l name), AvailTC name (name:kids))
+             return (IEThingAll (L l name), mkAvailTC name (name:kids))
 
     lookup_ie ie@(IEThingWith (L l rdr) sub_rdrs)
         = do name <- lookupGlobalOccRn rdr
              if isUnboundName name
-                then return (IEThingWith (L l name) [], AvailTC name [name])
+                then return (IEThingWith (L l name) [], mkAvailTC name [name])
                 else do
              let mb_names = lookupChildren (findChildren kids_env name) sub_rdrs
              if any isNothing mb_names
                 then do addErr (exportItemErr ie)
-                        return (IEThingWith (L l name) [], AvailTC name [name])
+                        return (IEThingWith (L l name) [], mkAvailTC name [name])
                 else do let names = catMaybes mb_names
                         addUsedKids rdr (map unLoc names)
                         return (IEThingWith (L l name) names
-                               , AvailTC name (name:map unLoc names))
+                               , mkAvailTC name (name:map unLoc names))
 
     lookup_ie _ = panic "lookup_ie"    -- Other cases covered earlier
 
+    -- XXX
+    mkNameWarn n = NameWarn n Nothing
+    mkAvailTC n ns = AvailTC (mkNameWarn n) (map mkNameWarn ns)
+
     -------------
     lookup_doc_ie :: IE RdrName -> RnM (IE Name)
     lookup_doc_ie (IEGroup lev doc) = do rn_doc <- rnHsDoc doc
@@ -1195,6 +1225,13 @@ isDoc (IEDocNamed _) = True
 isDoc (IEGroup _ _)  = True
 isDoc _ = False
 
+addAvailInfoWarnings :: Map Name WarningTxt -> [AvailInfo] -> [AvailInfo]
+addAvailInfoWarnings m = map f
+    where f (Avail n) = Avail (g n)
+          f (AvailTC n ns) = AvailTC (g n) (map g ns)
+
+          g (NameWarn n _) = NameWarn n (Map.lookup n m)
+
 -------------------------------
 isModuleExported :: Bool -> ModuleName -> GlobalRdrElt -> Bool
 -- True if the thing is in scope *both* unqualified, *and* with qualifier M
@@ -1409,7 +1446,7 @@ findImportUsage imports rdr_env rdrs
         used_avails = Map.lookup (srcSpanEnd loc) import_usage `orElse` []
                       -- srcSpanEnd: see Note [The ImportMap]
         used_names   = availsToNameSet used_avails
-        used_parents = mkNameSet [n | AvailTC n _ <- used_avails]
+        used_parents = mkNameSet [n | AvailTC (NameWarn n _) _ <- used_avails]
 
         unused_imps   -- Not trivial; see eg Trac #7454
           = case imps of
@@ -1568,20 +1605,22 @@ printMinimalImports imports_w_usage
     -- we want to say "T(..)", but if we're importing only a subset we want
     -- to say "T(A,B,C)".  So we have to find out what the module exports.
     to_ie _ (Avail n)
-       = [IEVar (noLoc n)]
+       = [IEVar (noLoc (nameWarnName n))]
     to_ie _ (AvailTC n [m])
-       | n==m = [IEThingAbs (noLoc n)]
+       | n==m = [IEThingAbs (noLoc (nameWarnName n))]
     to_ie ifaces (AvailTC n ns)
       = case [xs | iface <- ifaces
                  , AvailTC x xs <- mi_exports iface
                  , x == n
                  , x `elem` xs    -- Note [Partial export]
                  ] of
-           [xs] | all_used xs -> [IEThingAll (noLoc n)]
-                | otherwise   -> [IEThingWith (noLoc n)
-                                              (map noLoc (filter (/= n) ns))]
-           _other             -> map (IEVar . noLoc)  ns
+           [xs] | all_used xs -> [IEThingAll (noLoc n')]
+                | otherwise   -> [IEThingWith (noLoc n')
+                                              (map noLoc (filter (/= n') ns'))]
+           _other             -> map (IEVar . noLoc)  ns'
         where
+          n' = nameWarnName n
+          ns' = map nameWarnName ns
           all_used avail_occs = all (`elem` ns) avail_occs
 
 {-
@@ -1664,7 +1703,7 @@ badImportItemErr is_boot decl_spec ie avails
      Nothing  -> badImportItemErrStd is_boot decl_spec ie
   where
     checkIfDataCon (AvailTC _ ns) =
-      case find (\n -> importedFS == nameOccNameFS n) ns of
+      case find (\n -> importedFS == nameOccNameFS n) (map nameWarnName ns) of
         Just n  -> isDataConName n
         Nothing -> False
     checkIfDataCon _ = False
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index ac86fc3227..e44b23f751 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -128,7 +128,8 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
                        -- Not pattern-synonym binders, because we did
                        -- them in step (B)
          all_bndrs   = extendNameSetList tc_bndrs val_binders ;
-         val_avails  = map Avail val_binders  } ;
+         val_avails  = map mkAvail val_binders ;
+         mkAvail n = Avail (NameWarn n Nothing) } ;
    traceRn (text "rnSrcDecls" <+> ppr val_avails) ;
    (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
    setEnvs (tcg_env, tcl_env) $ do {
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 3d980e2327..384028f372 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -462,7 +462,8 @@ renameDeriv is_boot inst_infos bagBinds
         ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
         ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
         ; let bndrs = collectHsValBinders rn_aux_lhs
-        ; envs <- extendGlobalRdrEnvRn (map Avail bndrs) emptyFsEnv ;
+        ; let mkAvail n = Avail (NameWarn n Nothing)
+        ; envs <- extendGlobalRdrEnvRn (map mkAvail bndrs) emptyFsEnv ;
         ; setEnvs envs $
     do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs) False) rn_aux_lhs
         ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 16d0ef617c..46c15306f7 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -168,7 +168,7 @@ tcRnSignature dflags hsc_src
            | otherwise -> do
             { sig_iface <- initIfaceTcRn $ loadSysInterface (text "sig-of") sof
             ; let { gr = mkGlobalRdrEnv
-                              (gresFromAvails LocalDef (mi_exports sig_iface))
+                              (gresFromAvails (const LocalDef) (mi_exports sig_iface))
                   ; avails = calculateAvails dflags
                                     sig_iface False{- safe -} False{- boot -} }
             ; return (tcg_env