Add a WARNING pragma

compiler/basicTypes/BasicTypes.lhs

@@ -19,7 +19,7 @@ module BasicTypes(
 
 	Arity, 
 	
-	DeprecTxt,
+	WarningTxt(..),
 
 	Fixity(..), FixityDirection(..),
 	defaultFixity, maxPrecedence, 
@@ -95,7 +95,14 @@ initialVersion = 1
 
 
 \begin{code}
-type DeprecTxt = FastString	-- reason/explanation for deprecation
+-- reason/explanation from a WARNING or DEPRECATED pragma
+data WarningTxt = WarningTxt FastString
+                | DeprecatedTxt FastString
+    deriving Eq
+
+instance Outputable WarningTxt where
+    ppr (WarningTxt    w) =                        doubleQuotes (ftext w)
+    ppr (DeprecatedTxt d) = text "Deprecated:" <+> doubleQuotes (ftext d)
 \end{code}
 
 %************************************************************************

compiler/deSugar/Desugar.lhs

@@ -64,7 +64,7 @@ deSugar hsc_env
 		    	    tcg_fix_env      = fix_env,
 		    	    tcg_inst_env     = inst_env,
 		    	    tcg_fam_inst_env = fam_inst_env,
-	    	    	    tcg_deprecs      = deprecs,
+	    	    	    tcg_warns      = warns,
 			    tcg_binds        = binds,
 			    tcg_fords        = fords,
 			    tcg_rules        = rules,
@@ -129,7 +129,7 @@ deSugar hsc_env
 		mg_dir_imps  	= imp_mods imports,
 	        mg_rdr_env   	= rdr_env,
 		mg_fix_env   	= fix_env,
-		mg_deprecs   	= deprecs,
+		mg_warns   	= warns,
 		mg_types     	= type_env,
 		mg_insts     	= insts,
 		mg_fam_insts 	= fam_insts,

compiler/hsSyn/HsDecls.lhs

@@ -27,7 +27,7 @@ module HsDecls (
 	ConDecl(..), ResType(..), ConDeclField(..), LConDecl,	
 	HsConDeclDetails, hsConDeclArgTys,
 	DocDecl(..), LDocDecl, docDeclDoc,
-	DeprecDecl(..),  LDeprecDecl,
+	WarnDecl(..),  LWarnDecl,
 	HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups,
 	tcdName, tyClDeclNames, tyClDeclTyVars,
 	isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
@@ -79,7 +79,7 @@ data HsDecl id
   | SigD	(Sig id)
   | DefD	(DefaultDecl id)
   | ForD        (ForeignDecl id)
-  | DeprecD	(DeprecDecl id)
+  | WarningD	(WarnDecl id)
   | RuleD	(RuleDecl id)
   | SpliceD	(SpliceDecl id)
   | DocD	(DocDecl id)
@@ -113,7 +113,7 @@ data HsGroup id
 
 	hs_defds  :: [LDefaultDecl id],
 	hs_fords  :: [LForeignDecl id],
-	hs_depds  :: [LDeprecDecl id],
+	hs_warnds :: [LWarnDecl id],
 	hs_ruleds :: [LRuleDecl id],
 
 	hs_docs   :: [LDocDecl id]
@@ -125,7 +125,7 @@ emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }
 
 emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
 		       hs_fixds = [], hs_defds = [], hs_fords = [], 
-		       hs_depds = [], hs_ruleds = [],
+		       hs_warnds = [], hs_ruleds = [],
 		       hs_valds = error "emptyGroup hs_valds: Can't happen",
                        hs_docs = [] }
 
@@ -139,7 +139,7 @@ appendGroups
 	hs_fixds  = fixds1, 
 	hs_defds  = defds1,
 	hs_fords  = fords1, 
-	hs_depds  = depds1,
+	hs_warnds = warnds1,
 	hs_ruleds = rulds1,
   hs_docs   = docs1 }
     HsGroup { 
@@ -150,7 +150,7 @@ appendGroups
 	hs_fixds  = fixds2, 
 	hs_defds  = defds2,
 	hs_fords  = fords2, 
-	hs_depds  = depds2,
+	hs_warnds = warnds2,
 	hs_ruleds = rulds2,
   hs_docs   = docs2 }
   = 
@@ -162,7 +162,7 @@ appendGroups
 	hs_fixds  = fixds1 ++ fixds2, 
 	hs_defds  = defds1 ++ defds2,
 	hs_fords  = fords1 ++ fords2, 
-	hs_depds  = depds1 ++ depds2,
+	hs_warnds = warnds1 ++ warnds2,
 	hs_ruleds = rulds1 ++ rulds2,
   hs_docs   = docs1  ++ docs2 }
 \end{code}
@@ -177,7 +177,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where
     ppr (ForD fd)               = ppr fd
     ppr (SigD sd)               = ppr sd
     ppr (RuleD rd)              = ppr rd
-    ppr (DeprecD dd)            = ppr dd
+    ppr (WarningD wd)           = ppr wd
     ppr (SpliceD dd)            = ppr dd
     ppr (DocD doc)              = ppr doc
 
@@ -187,7 +187,7 @@ instance OutputableBndr name => Outputable (HsGroup name) where
 		   hs_instds = inst_decls,
                    hs_derivds = deriv_decls,
 		   hs_fixds  = fix_decls,
-		   hs_depds  = deprec_decls,
+		   hs_warnds = deprec_decls,
 		   hs_fords  = foreign_decls,
 		   hs_defds  = default_decls,
 		   hs_ruleds = rule_decls })
@@ -994,11 +994,11 @@ docDeclDoc (DocGroup _ d) = d
 We use exported entities for things to deprecate.
 
 \begin{code}
-type LDeprecDecl name = Located (DeprecDecl name)
+type LWarnDecl name = Located (WarnDecl name)
 
-data DeprecDecl name = Deprecation name DeprecTxt
+data WarnDecl name = Warning name WarningTxt
 
-instance OutputableBndr name => Outputable (DeprecDecl name) where
-    ppr (Deprecation thing txt)
+instance OutputableBndr name => Outputable (WarnDecl name) where
+    ppr (Warning thing txt)
       = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
 \end{code}

compiler/hsSyn/HsSyn.lhs

@@ -35,7 +35,7 @@ import HsImpExp
 import HsLit
 import HsPat
 import HsTypes
-import BasicTypes	( Fixity, DeprecTxt )
+import BasicTypes	( Fixity, WarningTxt )
 import HsUtils
 import HsDoc
 
@@ -61,7 +61,7 @@ data HsModule name
 				-- info to TyDecls/etc; so this list is
 				-- often empty, downstream.
 	[LHsDecl name]		-- Type, class, value, and interface signature decls
-	(Maybe DeprecTxt)	-- reason/explanation for deprecation of this module
+	(Maybe WarningTxt)	-- reason/explanation for warning/deprecation of this module
 	(HaddockModInfo name)   -- Haddock module info
 	(Maybe (HsDoc name))    -- Haddock module description
 

compiler/iface/BinIface.hs

@@ -373,7 +373,7 @@ instance Binary ModIface where
 		 mi_exports   = exports,
 		 mi_exp_hash  = exp_hash,
 		 mi_fixities  = fixities,
-		 mi_deprecs   = deprecs,
+		 mi_warns     = warns,
 		 mi_decls     = decls,
 		 mi_insts     = insts,
 		 mi_fam_insts = fam_insts,
@@ -392,7 +392,7 @@ instance Binary ModIface where
 	put_ bh exports
 	put_ bh exp_hash
 	put_ bh fixities
-	lazyPut bh deprecs
+	lazyPut bh warns
         put_ bh decls
 	put_ bh insts
 	put_ bh fam_insts
@@ -413,7 +413,7 @@ instance Binary ModIface where
 	exports	  <- {-# SCC "bin_exports" #-} get bh
 	exp_hash  <- get bh
 	fixities  <- {-# SCC "bin_fixities" #-} get bh
-	deprecs   <- {-# SCC "bin_deprecs" #-} lazyGet bh
+	warns     <- {-# SCC "bin_warns" #-} lazyGet bh
         decls 	  <- {-# SCC "bin_tycldecls" #-} get bh
 	insts     <- {-# SCC "bin_insts" #-} get bh
 	fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
@@ -433,7 +433,7 @@ instance Binary ModIface where
 		 mi_exports   = exports,
 		 mi_exp_hash  = exp_hash,
 		 mi_fixities  = fixities,
-		 mi_deprecs   = deprecs,
+		 mi_warns     = warns,
 		 mi_decls     = decls,
 		 mi_globals   = Nothing,
 		 mi_insts     = insts,
@@ -443,7 +443,7 @@ instance Binary ModIface where
                  mi_vect_info = vect_info,
 		 mi_hpc       = hpc_info,
 			-- And build the cached values
-		 mi_dep_fn    = mkIfaceDepCache deprecs,
+		 mi_warn_fn   = mkIfaceWarnCache warns,
 		 mi_fix_fn    = mkIfaceFixCache fixities,
 		 mi_hash_fn   = mkIfaceHashCache decls })
 
@@ -515,23 +515,39 @@ instance Binary Usage where
             return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
                             usg_exports = exps, usg_entities = ents }
 
-instance Binary Deprecations where
-    put_ bh NoDeprecs     = putByte bh 0
-    put_ bh (DeprecAll t) = do
-	    putByte bh 1
-	    put_ bh t
-    put_ bh (DeprecSome ts) = do
-	    putByte bh 2
-	    put_ bh ts
+instance Binary Warnings where
+    put_ bh NoWarnings     = putByte bh 0
+    put_ bh (WarnAll t) = do
+            putByte bh 1
+            put_ bh t
+    put_ bh (WarnSome ts) = do
+            putByte bh 2
+            put_ bh ts
 
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> return NoDeprecs
-	      1 -> do aa <- get bh
-		      return (DeprecAll aa)
-	      _ -> do aa <- get bh
-		      return (DeprecSome aa)
+            h <- getByte bh
+            case h of
+              0 -> return NoWarnings
+              1 -> do aa <- get bh
+                      return (WarnAll aa)
+              _ -> do aa <- get bh
+                      return (WarnSome aa)
+
+instance Binary WarningTxt where
+    put_ bh (WarningTxt w) = do
+            putByte bh 0
+            put_ bh w
+    put_ bh (DeprecatedTxt d) = do
+            putByte bh 1
+            put_ bh d
+
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do w <- get bh
+                      return (WarningTxt w)
+              _ -> do d <- get bh
+                      return (DeprecatedTxt d)
 
 -------------------------------------------------------------------------
 --		Types from: BasicTypes

compiler/iface/LoadIface.lhs

@@ -636,7 +636,7 @@ pprModIface iface
 	, vcat (map ppr (mi_fam_insts iface))
 	, vcat (map ppr (mi_rules iface))
         , pprVectInfo (mi_vect_info iface)
-	, pprDeprecs (mi_deprecs iface)
+	, ppr (mi_warns iface)
  	]
   where
     pp_boot | mi_boot iface = ptext (sLit "[boot]")
@@ -709,12 +709,15 @@ pprVectInfo (IfaceVectInfo { ifaceVectInfoVar        = vars
   , ptext (sLit "vectorised reused tycons:") <+> hsep (map ppr tyconsReuse)
   ]
 
-pprDeprecs :: Deprecations -> SDoc
-pprDeprecs NoDeprecs	    = empty
-pprDeprecs (DeprecAll txt)  = ptext (sLit "Deprecate all") <+> doubleQuotes (ftext txt)
-pprDeprecs (DeprecSome prs) = ptext (sLit "Deprecate") <+> vcat (map pprDeprec prs)
-			    where
-			      pprDeprec (name, txt) = ppr name <+> doubleQuotes (ftext txt)
+instance Outputable Warnings where
+    ppr = pprWarns
+
+pprWarns :: Warnings -> SDoc
+pprWarns NoWarnings	    = empty
+pprWarns (WarnAll txt)  = ptext (sLit "Warn all") <+> ppr txt
+pprWarns (WarnSome prs) = ptext (sLit "Warnings")
+                        <+> vcat (map pprWarning prs)
+    where pprWarning (name, txt) = ppr name <+> ppr txt
 \end{code}
 
 

compiler/iface/MkIface.lhs

@@ -126,11 +126,11 @@ mkIface hsc_env maybe_old_fingerprint mod_details
                       mg_dir_imps  = dir_imp_mods,
 		      mg_rdr_env   = rdr_env,
 		      mg_fix_env   = fix_env,
-		      mg_deprecs   = deprecs,
+		      mg_warns   = warns,
 	              mg_hpc_info  = hpc_info }
         = mkIface_ hsc_env maybe_old_fingerprint
                    this_mod is_boot used_names deps rdr_env 
-                   fix_env deprecs hpc_info dir_imp_mods mod_details
+                   fix_env warns hpc_info dir_imp_mods mod_details
 	
 -- | make an interface from the results of typechecking only.  Useful
 -- for non-optimising compilation, or where we aren't generating any
@@ -147,7 +147,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details
                       tcg_imports = imports,
                       tcg_rdr_env = rdr_env,
                       tcg_fix_env = fix_env,
-                      tcg_deprecs = deprecs,
+                      tcg_warns = warns,
                       tcg_hpc = other_hpc_info
                     }
   = do
@@ -156,7 +156,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details
           let hpc_info = emptyHpcInfo other_hpc_info
           mkIface_ hsc_env maybe_old_fingerprint
                    this_mod (isHsBoot hsc_src) used_names deps rdr_env 
-                   fix_env deprecs hpc_info (imp_mods imports) mod_details
+                   fix_env warns hpc_info (imp_mods imports) mod_details
         
 
 mkUsedNames :: TcGblEnv -> IO NameSet
@@ -208,12 +208,12 @@ mkDependencies
 
 mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
          -> NameSet -> Dependencies -> GlobalRdrEnv
-         -> NameEnv FixItem -> Deprecations -> HpcInfo
+         -> NameEnv FixItem -> Warnings -> HpcInfo
          -> ImportedMods
          -> ModDetails
          -> IO (ModIface, Bool)
 mkIface_ hsc_env maybe_old_fingerprint 
-         this_mod is_boot used_names deps rdr_env fix_env src_deprecs hpc_info
+         this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info
          dir_imp_mods
 	 ModDetails{  md_insts 	   = insts, 
 		      md_fam_insts = fam_insts,
@@ -240,7 +240,7 @@ mkIface_ hsc_env maybe_old_fingerprint
 				-- Sigh: see Note [Root-main Id] in TcRnDriver
 
 		; fixities    = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
-		; deprecs     = src_deprecs
+		; warns     = src_warns
 		; iface_rules = map (coreRuleToIfaceRule this_mod) rules
 		; iface_insts = map instanceToIfaceInst insts
 		; iface_fam_insts = map famInstToIfaceFamInst fam_insts
@@ -262,7 +262,7 @@ mkIface_ hsc_env maybe_old_fingerprint
                         mi_vect_info = iface_vect_info,
 
 			mi_fixities = fixities,
-			mi_deprecs  = deprecs,
+			mi_warns  = warns,
 			mi_globals  = Just rdr_env,
 
 			-- Left out deliberately: filled in by addVersionInfo
@@ -278,7 +278,7 @@ mkIface_ hsc_env maybe_old_fingerprint
 			mi_hpc       = isHpcUsed hpc_info,
 
 			-- And build the cached values
-			mi_dep_fn = mkIfaceDepCache deprecs,
+			mi_warn_fn = mkIfaceWarnCache warns,
 			mi_fix_fn = mkIfaceFixCache fixities }
 		}
 
@@ -522,7 +522,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
                       (map fst sorted_decls,
                        export_hash,
                        orphan_hash,
-                       mi_deprecs iface0)
+                       mi_warns iface0)
 
    -- The interface hash depends on:
    --    - the ABI hash, plus

compiler/main/DynFlags.hs

@@ -169,7 +169,7 @@ data DynFlag
    | Opt_WarnUnusedBinds
    | Opt_WarnUnusedImports
    | Opt_WarnUnusedMatches
-   | Opt_WarnDeprecations
+   | Opt_WarnWarningsDeprecations
    | Opt_WarnDeprecatedFlags
    | Opt_WarnDodgyImports
    | Opt_WarnOrphans
@@ -756,7 +756,7 @@ optLevelFlags
 
 standardWarnings :: [DynFlag]
 standardWarnings
-    = [ Opt_WarnDeprecations,
+    = [ Opt_WarnWarningsDeprecations,
         Opt_WarnDeprecatedFlags,
         Opt_WarnOverlappingPatterns,
         Opt_WarnMissingFields,
@@ -1407,7 +1407,7 @@ fFlags = [
   ( "warn-unused-binds",                Opt_WarnUnusedBinds, const Supported ),
   ( "warn-unused-imports",              Opt_WarnUnusedImports, const Supported ),
   ( "warn-unused-matches",              Opt_WarnUnusedMatches, const Supported ),
-  ( "warn-deprecations",                Opt_WarnDeprecations, const Supported ),
+  ( "warn-warnings-deprecations",       Opt_WarnWarningsDeprecations, const Supported ),
   ( "warn-deprecated-flags",            Opt_WarnDeprecatedFlags, const Supported ),
   ( "warn-orphans",                     Opt_WarnOrphans, const Supported ),
   ( "warn-tabs",                        Opt_WarnTabs, const Supported ),

compiler/main/GHC.hs

@@ -994,7 +994,7 @@ mkModGuts coreModule = ModGuts {
   mg_rules = [],
   mg_binds = cm_binds coreModule,
   mg_foreign = NoStubs,
-  mg_deprecs = NoDeprecs,
+  mg_warns = NoWarnings,
   mg_hpc_info = emptyHpcInfo False,
   mg_modBreaks = emptyModBreaks,
   mg_vect_info = noVectInfo,

compiler/main/HscTypes.lhs

@@ -32,8 +32,8 @@ module HscTypes (
 	icPrintUnqual, mkPrintUnqualified, extendInteractiveContext,
         substInteractiveContext,
 
-	ModIface(..), mkIfaceDepCache, mkIfaceHashCache, mkIfaceFixCache,
-	emptyIfaceDepCache,
+	ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,
+	emptyIfaceWarnCache,
 
 	FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
 
@@ -52,7 +52,7 @@ module HscTypes (
 	GenAvailInfo(..), AvailInfo, RdrAvailInfo, 
 	IfaceExport,
 
-	Deprecations(..), DeprecTxt, plusDeprecs,
+	Warnings(..), WarningTxt(..), plusWarns,
 
 	PackageInstEnv, PackageRuleBase,
 
@@ -101,7 +101,7 @@ import PrelNames	( gHC_PRIM )
 import Packages hiding ( Version(..) )
 import DynFlags		( DynFlags(..), isOneShot, HscTarget (..) )
 import DriverPhases	( HscSource(..), isHsBoot, hscSourceString, Phase )
-import BasicTypes	( IPName, Fixity, defaultFixity, DeprecTxt )
+import BasicTypes	( IPName, Fixity, defaultFixity, WarningTxt(..) )
 import OptimizationFuel	( OptFuelState )
 import IfaceSyn
 import FiniteMap	( FiniteMap )
@@ -445,8 +445,8 @@ data ModIface
         mi_fixities :: [(OccName,Fixity)],
 		-- NOT STRICT!  we read this field lazily from the interface file
 
-		-- Deprecations
-	mi_deprecs  :: Deprecations,
+		-- Warnings
+	mi_warns  :: Warnings,
 		-- NOT STRICT!  we read this field lazily from the interface file
 
 		-- Type, class and variable declarations
@@ -485,7 +485,7 @@ data ModIface
 		-- Cached environments for easy lookup
 		-- These are computed (lazily) from other fields
 		-- and are not put into the interface file
-	mi_dep_fn  :: Name -> Maybe DeprecTxt,	-- Cached lookup for mi_deprecs
+	mi_warn_fn  :: Name -> Maybe WarningTxt,	-- Cached lookup for mi_warns
 	mi_fix_fn  :: OccName -> Fixity,	-- Cached lookup for mi_fixities
 	mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint),
                         -- Cached lookup for mi_decls
@@ -546,7 +546,7 @@ data ModGuts
         mg_rules     :: ![CoreRule],	 -- Rules from this module
 	mg_binds     :: ![CoreBind],	 -- Bindings for this module
 	mg_foreign   :: !ForeignStubs,
-	mg_deprecs   :: !Deprecations,	 -- Deprecations declared in the module
+	mg_warns     :: !Warnings,	 -- Warnings declared in the module
 	mg_hpc_info  :: !HpcInfo,        -- info about coverage tick boxes
         mg_modBreaks :: !ModBreaks,
         mg_vect_info :: !VectInfo,        -- Pool of vectorised declarations
@@ -656,7 +656,7 @@ emptyModIface mod
 	       mi_exports  = [],
 	       mi_exp_hash = fingerprint0,
 	       mi_fixities = [],
-	       mi_deprecs  = NoDeprecs,
+	       mi_warns    = NoWarnings,
 	       mi_insts     = [],
 	       mi_fam_insts = [],
 	       mi_rules     = [],
@@ -664,7 +664,7 @@ emptyModIface mod
 	       mi_globals   = Nothing,
 	       mi_orphan_hash = fingerprint0,
                mi_vect_info = noIfaceVectInfo,
-	       mi_dep_fn    = emptyIfaceDepCache,
+	       mi_warn_fn    = emptyIfaceWarnCache,
 	       mi_fix_fn    = emptyIfaceFixCache,
 	       mi_hash_fn   = emptyIfaceHashCache,
 	       mi_hpc       = False
@@ -1004,11 +1004,11 @@ These types are defined here because they are mentioned in ModDetails,
 but they are mostly elaborated elsewhere
 
 \begin{code}
------------------- Deprecations -------------------------
-data Deprecations
-  = NoDeprecs
-  | DeprecAll DeprecTxt	        -- Whole module deprecated
-  | DeprecSome [(OccName,DeprecTxt)] -- Some specific things deprecated
+------------------ Warnings -------------------------
+data Warnings
+  = NoWarnings
+  | WarnAll WarningTxt	        -- Whole module deprecated
+  | WarnSome [(OccName,WarningTxt)] -- Some specific things deprecated
      -- Only an OccName is needed because
      --    (1) a deprecation always applies to a binding
      --        defined in the module in which the deprecation appears.
@@ -1031,20 +1031,20 @@ data Deprecations
      --        a Name to its fixity declaration.
   deriving( Eq )
 
-mkIfaceDepCache :: Deprecations -> Name -> Maybe DeprecTxt
-mkIfaceDepCache NoDeprecs     	  = \_ -> Nothing
-mkIfaceDepCache (DeprecAll t) 	  = \_ -> Just t
-mkIfaceDepCache (DeprecSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName
+mkIfaceWarnCache :: Warnings -> Name -> Maybe WarningTxt
+mkIfaceWarnCache NoWarnings  = \_ -> Nothing
+mkIfaceWarnCache (WarnAll t) = \_ -> Just t
+mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName
 
-emptyIfaceDepCache :: Name -> Maybe DeprecTxt
-emptyIfaceDepCache _ = Nothing
+emptyIfaceWarnCache :: Name -> Maybe WarningTxt
+emptyIfaceWarnCache _ = Nothing
 
-plusDeprecs :: Deprecations -> Deprecations -> Deprecations
-plusDeprecs d NoDeprecs = d
-plusDeprecs NoDeprecs d = d
-plusDeprecs _ (DeprecAll t) = DeprecAll t
-plusDeprecs (DeprecAll t) _ = DeprecAll t
-plusDeprecs (DeprecSome v1) (DeprecSome v2) = DeprecSome (v1 ++ v2)
+plusWarns :: Warnings -> Warnings -> Warnings
+plusWarns d NoWarnings = d
+plusWarns NoWarnings d = d
+plusWarns _ (WarnAll t) = WarnAll t
+plusWarns (WarnAll t) _ = WarnAll t
+plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2)
 \end{code}
 
 
@@ -1230,7 +1230,7 @@ data ExternalPackageState
 		--	* Fingerprint info
 		--	* Its exports
 		--	* Fixities
-		--	* Deprecations
+		--	* Warnings
 
 	eps_PTE :: !PackageTypeEnv,	   -- Domain = external-package modules
 

compiler/parser/Lexer.x

@@ -248,6 +248,8 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
 	$whitechar* (NO(T?)INLINE|no(t?)inline)
 					{ token (ITspec_inline_prag False) }
   "{-#" $whitechar* (SOURCE|source)	{ token ITsource_prag }
+  "{-#" $whitechar* (WARNING|warning)
+  					{ token ITwarning_prag }
   "{-#" $whitechar* (DEPRECATED|deprecated)
   					{ token ITdeprecated_prag }
   "{-#" $whitechar* (SCC|scc)		{ token ITscc_prag }
@@ -466,6 +468,7 @@ data Token
   | ITspec_inline_prag Bool	-- SPECIALISE INLINE (or NOINLINE)
   | ITsource_prag
   | ITrules_prag
+  | ITwarning_prag
   | ITdeprecated_prag
   | ITline_prag
   | ITscc_prag

compiler/parser/Parser.y.pp

@@ -28,7 +28,7 @@ module Parser ( parseModule, parseStmt, parseIdentifier, parseType,
 
 import HsSyn
 import RdrHsSyn
-import HscTypes		( IsBootInterface, DeprecTxt )
+import HscTypes		( IsBootInterface, WarningTxt(..) )
 import Lexer
 import RdrName
 import TysWiredIn	( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
@@ -262,6 +262,7 @@ incorrect.
  '{-# SCC'	   { L _ ITscc_prag }
  '{-# GENERATED'   { L _ ITgenerated_prag }
  '{-# DEPRECATED'  { L _ ITdeprecated_prag }
+ '{-# WARNING'  { L _ ITwarning_prag }
  '{-# UNPACK'      { L _ ITunpack_prag }
  '#-}'		   { L _ ITclose_prag }
 
@@ -375,7 +376,7 @@ identifier :: { Located RdrName }
 -- know what they are doing. :-)
 
 module 	:: { Located (HsModule RdrName) }
- 	: maybedocheader 'module' modid maybemoddeprec maybeexports 'where' body
+ 	: maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
 		{% fileSrcSpan >>= \ loc -> case $1 of { (info, doc) ->
 		   return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4
                           info doc) )}}
@@ -392,9 +393,10 @@ maybedocheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
 missing_module_keyword :: { () }
 	: {- empty -}				{% pushCurrentContext }
 
-maybemoddeprec :: { Maybe DeprecTxt }
-	: '{-# DEPRECATED' STRING '#-}' 	{ Just (getSTRING $2) }
-	|  {- empty -}				{ Nothing }
+maybemodwarning :: { Maybe WarningTxt }
+    : '{-# DEPRECATED' STRING '#-}' { Just (DeprecatedTxt (getSTRING $2)) }
+    | '{-# WARNING' STRING '#-}'    { Just (WarningTxt (getSTRING $2)) }
+    |  {- empty -}                  { Nothing }
 
 body 	:: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
 	:  '{'            top '}'		{ $2 }
@@ -416,7 +418,7 @@ cvtopdecls :: { [LHsDecl RdrName] }
 -- Module declaration & imports only
 
 header 	:: { Located (HsModule RdrName) }
- 	: maybedocheader 'module' modid maybemoddeprec maybeexports 'where' header_body
+ 	: maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body
 		{% fileSrcSpan >>= \ loc -> case $1 of { (info, doc) ->
 		   return (L loc (HsModule (Just $3) $5 $7 [] $4
                    info doc))}}
@@ -550,7 +552,8 @@ topdecl :: { OrdList (LHsDecl RdrName) }
         | stand_alone_deriving                  { unitOL (LL (DerivD (unLoc $1))) }
 	| 'default' '(' comma_types0 ')'	{ unitOL (LL $ DefD (DefaultDecl $3)) }
 	| 'foreign' fdecl			{ unitOL (LL (unLoc $2)) }
-	| '{-# DEPRECATED' deprecations '#-}'	{ $2 }
+    | '{-# DEPRECATED' deprecations '#-}' { $2 }
+    | '{-# WARNING' warnings '#-}'        { $2 }
 	| '{-# RULES' rules '#-}'		{ $2 }
       	| decl					{ unLoc $1 }
 
@@ -891,7 +894,19 @@ rule_var :: { RuleBndr RdrName }
        	| '(' varid '::' ctype ')'             	{ RuleBndrSig $2 $4 }
 
 -----------------------------------------------------------------------------
--- Deprecations (c.f. rules)
+-- Warnings and deprecations (c.f. rules)
+
+warnings :: { OrdList (LHsDecl RdrName) }
+	: warnings ';' warning		{ $1 `appOL` $3 }
+	| warnings ';' 			{ $1 }
+	| warning				{ $1 }
+	| {- empty -}				{ nilOL }
+
+-- SUP: TEMPORARY HACK, not checking for `module Foo'
+warning :: { OrdList (LHsDecl RdrName) }
+	: namelist STRING
+		{ toOL [ LL $ WarningD (Warning n (WarningTxt (getSTRING $2)))
+		       | n <- unLoc $1 ] }
 
 deprecations :: { OrdList (LHsDecl RdrName) }
 	: deprecations ';' deprecation		{ $1 `appOL` $3 }
@@ -901,8 +916,8 @@ deprecations :: { OrdList (LHsDecl RdrName) }
 
 -- SUP: TEMPORARY HACK, not checking for `module Foo'
 deprecation :: { OrdList (LHsDecl RdrName) }
-	: depreclist STRING
-		{ toOL [ LL $ DeprecD (Deprecation n (getSTRING $2)) 
+	: namelist STRING
+		{ toOL [ LL $ WarningD (Warning n (DeprecatedTxt (getSTRING $2)))
 		       | n <- unLoc $1 ] }
 
 
@@ -1316,7 +1331,7 @@ exp10 :: { LHsExpr RdrName }
 	| fexp					{ $1 }