diff options
Diffstat (limited to 'compiler')
40 files changed, 283 insertions, 182 deletions
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 6dbcbe4ce9..c046e74089 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -284,7 +284,7 @@ displayLintResults :: DynFlags -> CoreToDo -> IO () displayLintResults dflags pass warns errs binds | not (isEmptyBag errs) - = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle + = do { log_action dflags dflags Nothing Err.SevDump noSrcSpan defaultDumpStyle (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs , text "*** Offending Program ***" , pprCoreBindings binds @@ -294,7 +294,7 @@ displayLintResults dflags pass warns errs binds | not (isEmptyBag warns) , not opt_NoDebugOutput , showLintWarnings pass - = log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle + = log_action dflags dflags Nothing Err.SevDump noSrcSpan defaultDumpStyle (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag warns) | otherwise = return () @@ -324,7 +324,8 @@ lintInteractiveExpr what hsc_env expr dflags = hsc_dflags hsc_env display_lint_err err - = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle + = do { log_action dflags dflags Nothing Err.SevDump + noSrcSpan defaultDumpStyle (vcat [ lint_banner "errors" (text what) , err , text "*** Offending Program ***" diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index ef21f5c4d4..7acf258236 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -111,7 +111,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds modBreaks <- mkModBreaks hsc_env mod tickCount entries when (dopt Opt_D_dump_ticked dflags) $ - log_action dflags dflags SevDump noSrcSpan defaultDumpStyle + log_action dflags dflags Nothing SevDump noSrcSpan defaultDumpStyle (pprLHsBinds binds1) return (binds1, HpcInfo tickCount hashNo, Just modBreaks) diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 81aab36ea9..64244729c4 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -170,7 +170,7 @@ showTerm term = do -- XXX: this tries to disable logging of errors -- does this still do what it is intended to do -- with the changed error handling and logging? - let noop_log _ _ _ _ _ = return () + let noop_log _ _ _ _ _ _ = return () expr = "show " ++ showPpr dflags bname _ <- GHC.setSessionDynFlags dflags{log_action=noop_log} fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkRemoteRef val diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs index 2b471ee0ee..a434d242b7 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -235,7 +235,7 @@ withExtendedLinkEnv new_env action showLinkerState :: DynFlags -> IO () showLinkerState dflags = do pls <- readIORef v_PersistentLinkerState >>= readMVar - log_action dflags dflags SevDump noSrcSpan defaultDumpStyle + log_action dflags dflags Nothing SevDump noSrcSpan defaultDumpStyle (vcat [text "----- Linker state -----", text "Pkgs:" <+> ppr (pkgs_loaded pls), text "Objs:" <+> ppr (objs_loaded pls), @@ -374,7 +374,7 @@ classifyLdInput dflags f | isObjectFilename platform f = return (Just (Object f)) | isDynLibFilename platform f = return (Just (DLLPath f)) | otherwise = do - log_action dflags dflags SevInfo noSrcSpan defaultUserStyle + log_action dflags dflags Nothing SevInfo noSrcSpan defaultUserStyle (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) return Nothing where platform = targetPlatform dflags @@ -1397,7 +1397,8 @@ maybePutStr :: DynFlags -> String -> IO () maybePutStr dflags s = when (verbosity dflags > 1) $ do let act = log_action dflags - act dflags SevInteractive noSrcSpan defaultUserStyle (text s) + act dflags Nothing SevInteractive noSrcSpan defaultUserStyle + (text s) maybePutStrLn :: DynFlags -> String -> IO () maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n") diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index c0926fc22e..470fe3a255 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -80,7 +80,9 @@ readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do let printer :: SDoc -> IO () printer = case traceBinIFaceReading of - TraceBinIFaceReading -> \sd -> log_action dflags dflags SevOutput noSrcSpan defaultDumpStyle sd + TraceBinIFaceReading -> \sd -> + log_action dflags dflags Nothing SevOutput + noSrcSpan defaultDumpStyle sd QuietBinIFaceReading -> \_ -> return () wantedGot :: Outputable a => String -> a -> a -> IO () wantedGot what wanted got = diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index c044136b36..daf9f2ecbb 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -861,7 +861,8 @@ showIface hsc_env filename = do iface <- initTcRnIf 's' hsc_env () () $ readBinIface IgnoreHiWay TraceBinIFaceReading filename let dflags = hsc_dflags hsc_env - log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (pprModIface iface) + log_action dflags dflags Nothing SevDump noSrcSpan defaultDumpStyle + (pprModIface iface) pprModIface :: ModIface -> SDoc -- Show a ModIface diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs index 00a0801c47..083133c70f 100644 --- a/compiler/main/CodeOutput.hs +++ b/compiler/main/CodeOutput.hs @@ -67,7 +67,7 @@ codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream do_lint cmm = do { showPass dflags "CmmLint" ; case cmmLint dflags cmm of - Just err -> do { log_action dflags dflags SevDump noSrcSpan defaultDumpStyle err + Just err -> do { log_action dflags dflags Nothing SevDump noSrcSpan defaultDumpStyle err ; ghcExit dflags 1 } Nothing -> return () diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 3de94fd403..bbc190812e 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1594,7 +1594,7 @@ mkExtraObj dflags extn xs mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath mkExtraObjToLinkIntoBinary dflags = do when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do - log_action dflags dflags SevInfo noSrcSpan defaultUserStyle + log_action dflags dflags Nothing SevInfo noSrcSpan defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ text " Call hs_init_ghc() from your main() function to set these options.") @@ -1969,7 +1969,7 @@ linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO () linkDynLibCheck dflags o_files dep_packages = do when (haveRtsOptsFlags dflags) $ do - log_action dflags dflags SevInfo noSrcSpan defaultUserStyle + log_action dflags dflags Nothing SevInfo noSrcSpan defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ text " Call hs_init_ghc() from your main() function to set these options.") diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 52da3005bf..df95312edc 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -173,7 +173,7 @@ import FastString import Outputable import Foreign.C ( CInt(..) ) import System.IO.Unsafe ( unsafeDupablePerformIO ) -import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage ) +import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn ) import System.IO.Unsafe ( unsafePerformIO ) import Data.IORef @@ -1616,13 +1616,13 @@ interpreterDynamic dflags -------------------------------------------------------------------------- type FatalMessager = String -> IO () -type LogAction = DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () +type LogAction = DynFlags -> Maybe WarningFlag -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () defaultFatalMessager :: FatalMessager defaultFatalMessager = hPutStrLn stderr defaultLogAction :: LogAction -defaultLogAction dflags severity srcSpan style msg +defaultLogAction dflags flag severity srcSpan style msg = case severity of SevOutput -> printSDoc msg style SevDump -> printSDoc (msg $$ blankLine) style @@ -1630,7 +1630,7 @@ defaultLogAction dflags severity srcSpan style msg SevInfo -> printErrs msg style SevFatal -> printErrs msg style _ -> do hPutChar stderr '\n' - printErrs (mkLocMessage severity srcSpan msg) style + printErrs (mkLocMessageAnn flagMsg severity srcSpan msg) style -- careful (#2302): printErrs prints in UTF-8, -- whereas converting to string first and using -- hPutStr would just emit the low 8 bits of @@ -1638,6 +1638,9 @@ defaultLogAction dflags severity srcSpan style msg where printSDoc = defaultLogActionHPrintDoc dflags stdout printErrs = defaultLogActionHPrintDoc dflags stderr putStrSDoc = defaultLogActionHPutStrDoc dflags stdout + -- Pretty print the warning flag, if any (#10752) + flagMsg = (\wf -> '-':'W':flagSpecName wf) <$> (flag >>= \f -> + listToMaybe $ filter (\fs -> flagSpecFlag fs == f) wWarningFlags) defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () defaultLogActionHPrintDoc dflags h d sty diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index eafe4e802f..585cab5f22 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -23,7 +23,7 @@ module ErrUtils ( pprLocErrMsg, printBagOfErrors, -- ** Construction - emptyMessages, mkLocMessage, makeIntoWarning, + emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning, mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, warnIsErrorMsg, mkLongWarnMsg, @@ -110,7 +110,8 @@ data ErrMsg = ErrMsg { errMsgDoc :: ErrDoc, -- | This has the same text as errDocImportant . errMsgDoc. errMsgShortString :: String, - errMsgSeverity :: Severity + errMsgSeverity :: Severity, + errMsgFlag :: Maybe WarningFlag } -- The SrcSpan is used for sorting errors into line-number order @@ -160,15 +161,18 @@ pprMessageBag :: Bag MsgDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc +mkLocMessage = mkLocMessageAnn Nothing + +mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc -- Always print the location, even if it is unhelpful. Error messages -- are supposed to be in a standard format, and one without a location -- would look strange. Better to say explicitly "<no location info>". -mkLocMessage severity locn msg +mkLocMessageAnn ann severity locn msg = sdocWithDynFlags $ \dflags -> let locn' = if gopt Opt_ErrorSpans dflags then ppr locn else ppr (srcSpanStart locn) - in hang (locn' <> colon <+> sev_info) 4 msg + in hang (locn' <> colon <+> sev_info <> opt_ann) 4 msg where -- Add prefixes, like Foo.hs:34: warning: -- <the warning message> @@ -178,8 +182,13 @@ mkLocMessage severity locn msg SevFatal -> text "fatal:" _ -> empty -makeIntoWarning :: ErrMsg -> ErrMsg -makeIntoWarning err = err { errMsgSeverity = SevWarning } + -- Add optional information + opt_ann = text $ maybe "" (\i -> " ["++i++"]") ann + +makeIntoWarning :: Maybe WarningFlag -> ErrMsg -> ErrMsg +makeIntoWarning flag err += err { errMsgSeverity = SevWarning + , errMsgFlag = flag } -- ----------------------------------------------------------------------------- -- Collecting up messages for later ordering and printing. @@ -190,7 +199,8 @@ mk_err_msg dflags sev locn print_unqual doc , errMsgContext = print_unqual , errMsgDoc = doc , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc)) - , errMsgSeverity = sev } + , errMsgSeverity = sev + , errMsgFlag = Nothing } mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg mkErrDoc dflags = mk_err_msg dflags SevError @@ -226,10 +236,11 @@ errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () printBagOfErrors dflags bag_of_errors = sequence_ [ let style = mkErrStyle dflags unqual - in log_action dflags dflags sev s style (formatErrDoc dflags doc) + in log_action dflags dflags flag sev s style (formatErrDoc dflags doc) | ErrMsg { errMsgSpan = s, errMsgDoc = doc, errMsgSeverity = sev, + errMsgFlag = flag, errMsgContext = unqual } <- sortMsgBag (Just dflags) bag_of_errors ] @@ -283,7 +294,8 @@ doIfSet_dyn dflags flag action | gopt flag dflags = action dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO () dumpIfSet dflags flag hdr doc | not flag = return () - | otherwise = log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc) + | otherwise = log_action dflags dflags Nothing SevDump + noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc) -- | a wrapper around 'dumpSDoc'. -- First check whether the dump flag is set @@ -359,7 +371,7 @@ dumpSDoc dflags print_unqual flag hdr doc let (doc', severity) | null hdr = (doc, SevOutput) | otherwise = (mkDumpDoc hdr doc, SevDump) - log_action dflags dflags severity noSrcSpan dump_style doc' + log_action dflags dflags Nothing severity noSrcSpan dump_style doc' -- | Choose where to put a dump file based on DynFlags @@ -416,18 +428,20 @@ ifVerbose dflags val act errorMsg :: DynFlags -> MsgDoc -> IO () errorMsg dflags msg - = log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg + = log_action dflags dflags Nothing SevError noSrcSpan + (defaultErrStyle dflags) msg warningMsg :: DynFlags -> MsgDoc -> IO () warningMsg dflags msg - = log_action dflags dflags SevWarning noSrcSpan (defaultErrStyle dflags) msg + = log_action dflags dflags Nothing SevWarning noSrcSpan + (defaultErrStyle dflags) msg fatalErrorMsg :: DynFlags -> MsgDoc -> IO () fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO () fatalErrorMsg' la dflags msg = - la dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg + la dflags Nothing SevFatal noSrcSpan (defaultErrStyle dflags) msg fatalErrorMsg'' :: FatalMessager -> String -> IO () fatalErrorMsg'' fm msg = fm msg @@ -458,11 +472,13 @@ printOutputForUser dflags print_unqual msg = logOutput dflags (mkUserStyle print_unqual AllTheWay) msg logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO () -logInfo dflags sty msg = log_action dflags dflags SevInfo noSrcSpan sty msg +logInfo dflags sty msg + = log_action dflags dflags Nothing SevInfo noSrcSpan sty msg logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO () -- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' -logOutput dflags sty msg = log_action dflags dflags SevOutput noSrcSpan sty msg +logOutput dflags sty msg + = log_action dflags dflags Nothing SevOutput noSrcSpan sty msg prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a prettyPrintGhcErrors dflags diff --git a/compiler/main/ErrUtils.hs-boot b/compiler/main/ErrUtils.hs-boot index 31edcc05ee..b991ec4958 100644 --- a/compiler/main/ErrUtils.hs-boot +++ b/compiler/main/ErrUtils.hs-boot @@ -16,3 +16,4 @@ data Severity type MsgDoc = SDoc mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc +mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 7bbe4be495..3e62d8dea4 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -678,7 +678,7 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs -- | Each module is given a unique 'LogQueue' to redirect compilation messages -- to. A 'Nothing' value contains the result of compilation, and denotes the -- end of the message queue. -data LogQueue = LogQueue !(IORef [Maybe (Severity, SrcSpan, PprStyle, MsgDoc)]) +data LogQueue = LogQueue !(IORef [Maybe (Maybe WarningFlag, Severity, SrcSpan, PprStyle, MsgDoc)]) !(MVar ()) -- | The graph of modules to compile and their corresponding result 'MVar' and @@ -879,7 +879,7 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do return (success_flag,ok_results) where - writeLogQueue :: LogQueue -> Maybe (Severity,SrcSpan,PprStyle,MsgDoc) -> IO () + writeLogQueue :: LogQueue -> Maybe (Maybe WarningFlag,Severity,SrcSpan,PprStyle,MsgDoc) -> IO () writeLogQueue (LogQueue ref sem) msg = do atomicModifyIORef' ref $ \msgs -> (msg:msgs,()) _ <- tryPutMVar sem () @@ -888,8 +888,8 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do -- The log_action callback that is used to synchronize messages from a -- worker thread. parLogAction :: LogQueue -> LogAction - parLogAction log_queue _dflags !severity !srcSpan !style !msg = do - writeLogQueue log_queue (Just (severity,srcSpan,style,msg)) + parLogAction log_queue _dflags !flag !severity !srcSpan !style !msg = do + writeLogQueue log_queue (Just (flag,severity,srcSpan,style,msg)) -- Print each message from the log_queue using the log_action from the -- session's DynFlags. @@ -902,8 +902,8 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do print_loop [] = read_msgs print_loop (x:xs) = case x of - Just (severity,srcSpan,style,msg) -> do - log_action dflags dflags severity srcSpan style msg + Just (flag,severity,srcSpan,style,msg) -> do + log_action dflags dflags flag severity srcSpan style msg print_loop xs -- Exit the loop once we encounter the end marker. Nothing -> return () diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs index c3436edd9e..d7de69ae8d 100644 --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -1367,10 +1367,12 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do msg <- readChan chan case msg of BuildMsg msg -> do - log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg + log_action dflags dflags Nothing SevInfo noSrcSpan + defaultUserStyle msg loop chan hProcess t p exitcode BuildError loc msg -> do - log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg + log_action dflags dflags Nothing SevError (mkSrcSpan loc loc) + defaultUserStyle msg loop chan hProcess t p exitcode EOF -> loop chan hProcess (t-1) p exitcode diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index df31fda16c..072fb840a4 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -390,7 +390,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod -- Print one-line size info ; let cs = coreBindsStats tidy_binds ; when (dopt Opt_D_dump_core_stats dflags) - (log_action dflags dflags SevDump noSrcSpan defaultDumpStyle + (log_action dflags dflags Nothing SevDump noSrcSpan + defaultDumpStyle (text "Tidy size (terms,types,coercions)" <+> ppr (moduleName mod) <> colon <+> int (cs_tm cs) diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 33a1cb447b..be103e5b24 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -462,7 +462,7 @@ rnBind _ bind@(PatBind { pat_lhs = pat -- or an occurrence of, a variable on the RHS ; whenWOptM Opt_WarnUnusedPatternBinds $ when (null bndrs && not is_wild_pat) $ - addWarn $ unusedPatBindWarn bind' + addWarn Opt_WarnUnusedPatternBinds $ unusedPatBindWarn bind' ; fvs' `seq` -- See Note [Free-variable space leak] return (bind', bndrs, all_fvs) } @@ -1104,7 +1104,7 @@ rnGRHS' ctxt rnBody (GRHS guards rhs) rnBody rhs ; unless (pattern_guards_allowed || is_standard_guard guards') - (addWarn (nonStdGuardErr guards')) + (addWarn' (nonStdGuardErr guards')) ; return (GRHS guards' rhs', fvs) } where diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 5d74d7c94f..4f832f8443 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -743,7 +743,8 @@ lookup_demoted rdr_name dflags Just demoted_name | data_kinds -> do { whenWOptM Opt_WarnUntickedPromotedConstructors $ - addWarn (untickedPromConstrWarn demoted_name) + addWarn Opt_WarnUntickedPromotedConstructors + (untickedPromConstrWarn demoted_name) ; return demoted_name } | otherwise -> unboundNameX WL_Any rdr_name suggest_dk } @@ -1068,7 +1069,8 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss }) -- See Note [Handling of deprecations] do { iface <- loadInterfaceForName doc name ; case lookupImpDeprec iface gre of - Just txt -> addWarn (mk_msg imp_spec txt) + Just txt -> addWarn Opt_WarnWarningsDeprecations + (mk_msg imp_spec txt) Nothing -> return () } } | otherwise = return () @@ -1738,7 +1740,8 @@ checkShadowedOccs (global_env,local_env) get_loc_occ ns -- we don't find any GREs that are in scope qualified-only complain [] = return () - complain pp_locs = addWarnAt loc (shadowedNameWarn occ pp_locs) + complain pp_locs = addWarnAt Opt_WarnNameShadowing + loc (shadowedNameWarn occ pp_locs) is_shadowed_gre :: GlobalRdrElt -> RnM Bool -- Returns False for record selectors that are shadowed, when @@ -2118,7 +2121,8 @@ warnUnusedLocals names = do warnUnusedLocal :: NameEnv (FieldLabelString, Name) -> Name -> RnM () warnUnusedLocal fld_env name = when (reportable name) $ - addUnusedWarning occ (nameSrcSpan name) + addUnusedWarning Opt_WarnUnusedLocalBinds + occ (nameSrcSpan name) (text "Defined but not used") where occ = case lookupNameEnv fld_env name of @@ -2132,7 +2136,7 @@ warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is }) | otherwise = when (reportable name) (mapM_ warn is) where occ = greOccName gre - warn spec = addUnusedWarning occ span msg + warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg where span = importSpecLoc spec pp_mod = quotes (ppr (importSpecModule spec)) @@ -2154,9 +2158,9 @@ reportable name -- from Data.Tuple | otherwise = not (startsWithUnderscore (nameOccName name)) -addUnusedWarning :: OccName -> SrcSpan -> SDoc -> RnM () -addUnusedWarning occ span msg - = addWarnAt span $ +addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () +addUnusedWarning flag occ span msg + = addWarnAt flag span $ sep [msg <> colon, nest 2 $ pprNonVarNameSpace (occNameSpace occ) <+> quotes (ppr occ)] diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index d8e08e20aa..33074dbde0 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -236,7 +236,8 @@ rnImportDecl this_mod _ | implicit -> return () -- Do not bleat for implicit imports | qual_only -> return () | otherwise -> whenWOptM Opt_WarnMissingImportList $ - addWarn (missingImportListWarn imp_mod_name) + addWarn Opt_WarnMissingImportList + (missingImportListWarn imp_mod_name) iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg) @@ -253,8 +254,8 @@ rnImportDecl this_mod -- the non-boot module depends on the compilation order, which -- is not deterministic. The hs-boot test can show this up. dflags <- getDynFlags - warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags)) - (warnRedundantSourceImport imp_mod_name) + warnIf' (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags)) + (warnRedundantSourceImport imp_mod_name) when (mod_safe && not (safeImportsOn dflags)) $ addErr (text "safe import can't be used as Safe Haskell isn't on!" $+$ ptext (sLit $ "please enable Safe Haskell through either " @@ -297,7 +298,8 @@ rnImportDecl this_mod -- Complain if we import a deprecated module whenWOptM Opt_WarnWarningsDeprecations ( case (mi_warns iface) of - WarnAll txt -> addWarn $ moduleWarn imp_mod_name txt + WarnAll txt -> addWarn Opt_WarnWarningsDeprecations + (moduleWarn imp_mod_name txt) _ -> return () ) @@ -814,11 +816,11 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) where -- Warn when importing T(..) if T was exported abstractly emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $ - addWarn (dodgyImportWarn n) + addWarn Opt_WarnDodgyImports (dodgyImportWarn n) emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $ - addWarn (missingImportListItem ieRdr) + addWarn Opt_WarnMissingImportList (missingImportListItem ieRdr) emit_warning BadImportW = whenWOptM Opt_WarnDodgyImports $ - addWarn (lookup_err_msg BadImport) + addWarn Opt_WarnDodgyImports (lookup_err_msg BadImport) run_lookup :: IELookupM a -> TcRn (Maybe a) run_lookup m = case m of @@ -1262,7 +1264,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod | (L _ (IEModuleContents (L _ mod))) <- ie_names ] , mod `elem` earlier_mods -- Duplicate export of M = do { warn_dup_exports <- woptM Opt_WarnDuplicateExports ; - warnIf warn_dup_exports (dupModuleExport mod) ; + warnIf Opt_WarnDuplicateExports warn_dup_exports + (dupModuleExport mod) ; return acc } | otherwise @@ -1276,7 +1279,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod } ; checkErr exportValid (moduleNotImported mod) - ; warnIf (warnDodgyExports && exportValid && null gre_prs) + ; warnIf Opt_WarnDodgyExports + (warnDodgyExports && exportValid && null gre_prs) (nullModuleExport mod) ; traceRn (text "efa" <+> (ppr mod $$ ppr all_gres)) @@ -1373,7 +1377,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod warnDodgyExports <- woptM Opt_WarnDodgyExports when (null gres) $ if isTyConName name - then when warnDodgyExports $ addWarn (dodgyExportWarn name) + then when warnDodgyExports $ + addWarn Opt_WarnDodgyExports (dodgyExportWarn name) else -- This occurs when you export T(..), but -- only import T abstractly, or T is a synonym. addErr (exportItemErr ie) @@ -1416,7 +1421,8 @@ check_occs ie occs names -- 'names' are the entities specifed by 'ie' -- by two different module exports. See ticket #4478. -> do unless (dupExport_ok name ie ie') $ do warn_dup_exports <- woptM Opt_WarnDuplicateExports - warnIf warn_dup_exports (dupExportWarn name_occ ie ie') + warnIf Opt_WarnDuplicateExports warn_dup_exports + (dupExportWarn name_occ ie ie') return occs | otherwise -- Same occ name but different names: an error @@ -1550,7 +1556,7 @@ warnUnusedImportDecls gbl_env ; traceRn (vcat [ text "Uses:" <+> ppr uses , text "Import usage" <+> ppr usage]) ; whenWOptM Opt_WarnUnusedImports $ - mapM_ (warnUnusedImport fld_env) usage + mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage ; whenGOptM Opt_D_dump_minimal_imports $ printMinimalImports usage } @@ -1570,9 +1576,14 @@ warnMissingSigs gbl_env ; warn_pat_syns <- woptM Opt_WarnMissingPatSynSigs ; let sig_warn - | warn_only_exported = topSigWarnIfExported exports sig_ns - | warn_missing_sigs || warn_pat_syns = topSigWarn sig_ns - | otherwise = noSigWarn + | warn_only_exported + = topSigWarnIfExported Opt_WarnMissingExportedSigs exports sig_ns + | warn_missing_sigs + = topSigWarn Opt_WarnMissingSigs sig_ns + | warn_pat_syns + = topSigWarn Opt_WarnMissingPatSynSigs sig_ns + | otherwise + = noSigWarn ; let binders = (if warn_pat_syns then ps_binders else []) @@ -1591,35 +1602,36 @@ type SigWarn = [(Type, Name)] -> RnM () noSigWarn :: SigWarn noSigWarn _ = return () -topSigWarnIfExported :: NameSet -> NameSet -> SigWarn -topSigWarnIfExported exported sig_ns ids - = mapM_ (topSigWarnIdIfExported exported sig_ns) ids +topSigWarnIfExported :: WarningFlag -> NameSet -> NameSet -> SigWarn +topSigWarnIfExported flag exported sig_ns ids + = mapM_ (topSigWarnIdIfExported flag exported sig_ns) ids -topSigWarnIdIfExported :: NameSet -> NameSet -> (Type, Name) -> RnM () -topSigWarnIdIfExported exported sig_ns (ty, name) +topSigWarnIdIfExported :: WarningFlag -> NameSet -> NameSet -> (Type, Name) + -> RnM () +topSigWarnIdIfExported flag exported sig_ns (ty, name) | name `elemNameSet` exported - = topSigWarnId sig_ns (ty, name) + = topSigWarnId flag sig_ns (ty, name) | otherwise = return () -topSigWarn :: NameSet -> SigWarn -topSigWarn sig_ns ids = mapM_ (topSigWarnId sig_ns) ids +topSigWarn :: WarningFlag -> NameSet -> SigWarn +topSigWarn flag sig_ns ids = mapM_ (topSigWarnId flag sig_ns) ids -topSigWarnId :: NameSet -> (Type, Name) -> RnM () +topSigWarnId :: WarningFlag -> NameSet -> (Type, Name) -> RnM () -- The NameSet is the Ids that *lack* a signature -- We have to do it this way round because there are -- lots of top-level bindings that are generated by GHC -- and that don't have signatures -topSigWarnId sig_ns (ty, name) - | name `elemNameSet` sig_ns = warnMissingSig msg (ty, name) +topSigWarnId flag sig_ns (ty, name) + | name `elemNameSet` sig_ns = warnMissingSig flag msg (ty, name) | otherwise = return () where msg = text "Top-level binding with no type signature:" -warnMissingSig :: SDoc -> (Type, Name) -> RnM () -warnMissingSig msg (ty, name) = do +warnMissingSig :: WarningFlag -> SDoc -> (Type, Name) -> RnM () +warnMissingSig flag msg (ty, name) = do tymsg <- getMsg ty - addWarnAt (getSrcSpan name) (mk_msg tymsg) + addWarnAt flag (getSrcSpan name) (mk_msg tymsg) where mk_msg endmsg = sep [ msg, nest 2 $ pprPrefixName name <+> endmsg ] @@ -1723,9 +1735,9 @@ extendImportMap gre imp_map -- For srcSpanEnd see Note [The ImportMap] avail = availFromGRE gre -warnUnusedImport :: NameEnv (FieldLabelString, Name) -> ImportDeclUsage - -> RnM () -warnUnusedImport fld_env (L loc decl, used, unused) +warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name) + -> ImportDeclUsage -> RnM () +warnUnusedImport flag fld_env (L loc decl, used, unused) | Just (False,L _ []) <- ideclHiding decl = return () -- Do not warn for 'import M()' @@ -1733,9 +1745,9 @@ warnUnusedImport fld_env (L loc decl, used, unused) , not (null hides) , pRELUDE_NAME == unLoc (ideclName decl) = return () -- Note [Do not warn about Prelude hiding] - | null used = addWarnAt loc msg1 -- Nothing used; drop entire decl + | null used = addWarnAt flag loc msg1 -- Nothing used; drop entire decl | null unused = return () -- Everything imported is used; nop - | otherwise = addWarnAt loc msg2 -- Some imports are unused + | otherwise = addWarnAt flag loc msg2 -- Some imports are unused where msg1 = vcat [pp_herald <+> quotes pp_mod <+> pp_not_used, nest 2 (text "except perhaps to import instances from" diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 4f655090c6..5c5e1b1d3e 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -500,10 +500,12 @@ checkCanonicalInstances cls poly_ty mbinds = do case mbind of FunBind { fun_id = L _ name, fun_matches = mg } | name == pureAName, isAliasMG mg == Just returnMName - -> addWarnNonCanonicalMethod1 "pure" "return" + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonadInstances "pure" "return" | name == thenAName, isAliasMG mg == Just thenMName - -> addWarnNonCanonicalMethod1 "(*>)" "(>>)" + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)" _ -> return () @@ -512,10 +514,12 @@ checkCanonicalInstances cls poly_ty mbinds = do case mbind of FunBind { fun_id = L _ name, fun_matches = mg } | name == returnMName, isAliasMG mg /= Just pureAName - -> addWarnNonCanonicalMethod2 "return" "pure" + -> addWarnNonCanonicalMethod2 + Opt_WarnNonCanonicalMonadInstances "return" "pure" | name == thenMName, isAliasMG mg /= Just thenAName - -> addWarnNonCanonicalMethod2 "(>>)" "(*>)" + -> addWarnNonCanonicalMethod2 + Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)" _ -> return () @@ -540,7 +544,9 @@ checkCanonicalInstances cls poly_ty mbinds = do case mbind of FunBind { fun_id = L _ name, fun_matches = mg } | name == failMName, isAliasMG mg == Just failMName_preMFP - -> addWarnNonCanonicalMethod1 "fail" "Control.Monad.fail" + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonadFailInstances "fail" + "Control.Monad.fail" _ -> return () @@ -549,8 +555,9 @@ checkCanonicalInstances cls poly_ty mbinds = do case mbind of FunBind { fun_id = L _ name, fun_matches = mg } | name == failMName_preMFP, isAliasMG mg /= Just failMName - -> addWarnNonCanonicalMethod2 "fail" - "Control.Monad.Fail.fail" + -> addWarnNonCanonicalMethod2 + Opt_WarnNonCanonicalMonadFailInstances "fail" + "Control.Monad.Fail.fail" _ -> return () | otherwise = return () @@ -574,7 +581,8 @@ checkCanonicalInstances cls poly_ty mbinds = do case mbind of FunBind { fun_id = L _ name, fun_matches = mg } | name == sappendName, isAliasMG mg == Just mappendName - -> addWarnNonCanonicalMethod1 "(<>)" "mappend" + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend" _ -> return () @@ -583,7 +591,8 @@ checkCanonicalInstances cls poly_ty mbinds = do case mbind of FunBind { fun_id = L _ name, fun_matches = mg } | name == mappendName, isAliasMG mg /= Just sappendName - -> addWarnNonCanonicalMethod2NoDefault "mappend" "(<>)" + -> addWarnNonCanonicalMethod2NoDefault + Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)" _ -> return () @@ -599,8 +608,9 @@ checkCanonicalInstances cls poly_ty mbinds = do isAliasMG _ = Nothing -- got "lhs = rhs" but expected something different - addWarnNonCanonicalMethod1 lhs rhs = do - addWarn $ vcat [ text "Noncanonical" <+> + addWarnNonCanonicalMethod1 flag lhs rhs = do + addWarn flag $ vcat + [ text "Noncanonical" <+> quotes (text (lhs ++ " = " ++ rhs)) <+> text "definition detected" , instDeclCtxt1 poly_ty @@ -610,8 +620,9 @@ checkCanonicalInstances cls poly_ty mbinds = do ] -- expected "lhs = rhs" but got something else - addWarnNonCanonicalMethod2 lhs rhs = do - addWarn $ vcat [ text "Noncanonical" <+> + addWarnNonCanonicalMethod2 flag lhs rhs = do + addWarn flag $ vcat + [ text "Noncanonical" <+> quotes (text lhs) <+> text "definition detected" , instDeclCtxt1 poly_ty @@ -621,8 +632,9 @@ checkCanonicalInstances cls poly_ty mbinds = do ] -- like above, but method has no default impl - addWarnNonCanonicalMethod2NoDefault lhs rhs = do - addWarn $ vcat [ text "Noncanonical" <+> + addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do + addWarn flag $ vcat + [ text "Noncanonical" <+> quotes (text lhs) <+> text "definition detected" , instDeclCtxt1 poly_ty diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 118a32b392..b729e3befc 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -1409,7 +1409,7 @@ warnUnusedForAll :: SDoc -> LHsTyVarBndr Name -> FreeVars -> TcM () warnUnusedForAll in_doc (L loc tv) used_names = whenWOptM Opt_WarnUnusedForalls $ unless (hsTyVarName tv `elemNameSet` used_names) $ - addWarnAt loc $ + addWarnAt Opt_WarnUnusedForalls loc $ vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) , in_doc ] diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index 13a7512ffa..36c6d87db1 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -825,7 +825,7 @@ msg sev doc user_sty = mkUserStyle unqual AllTheWay dump_sty = mkDumpStyle unqual ; liftIO $ - (log_action dflags) dflags sev loc sty doc } + (log_action dflags) dflags Nothing sev loc sty doc } -- | Output a String message to the screen putMsgS :: String -> CoreM () diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 6badbf83db..61c0491bf5 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -428,7 +428,8 @@ ruleCheckPass current_phase pat guts = do dflags <- getDynFlags vis_orphs <- getVisibleOrphanMods liftIO $ Err.showPass dflags "RuleCheck" - liftIO $ log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle + liftIO $ log_action dflags dflags Nothing Err.SevDump noSrcSpan + defaultDumpStyle (ruleCheckProgram current_phase pat (RuleEnv rb vis_orphs) (mg_binds guts)) return guts diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs index b8491fcbbe..8ea661d5f2 100644 --- a/compiler/simplStg/SimplStg.hs +++ b/compiler/simplStg/SimplStg.hs @@ -37,7 +37,8 @@ stg2stg dflags module_name binds ; us <- mkSplitUniqSupply 'g' ; when (dopt Opt_D_verbose_stg2stg dflags) - (log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (text "VERBOSE STG-TO-STG:")) + (log_action dflags dflags Nothing SevDump noSrcSpan + defaultDumpStyle (text "VERBOSE STG-TO-STG:")) ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index b3da5ef5ea..03dad405a0 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -520,7 +520,9 @@ newClsInst overlap_mode dfun_name tvs theta clas tys ; oflag <- getOverlapFlag overlap_mode ; let inst = mkLocalInstance dfun oflag tvs' clas tys' ; dflags <- getDynFlags - ; warnIf (isOrphan (is_orphan inst) && wopt Opt_WarnOrphans dflags) (instOrphWarn inst) + ; warnIf Opt_WarnOrphans + (isOrphan (is_orphan inst) && wopt Opt_WarnOrphans dflags) + (instOrphWarn inst) ; return inst } instOrphWarn :: ClsInst -> SDoc diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index b80d5bd236..e1bb975abf 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -29,7 +29,7 @@ tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation] -- No GHCI; emit a warning (not an error) and ignore. cf Trac #4268 tcAnnotations [] = return [] tcAnnotations anns@(L loc _ : _) - = do { setSrcSpan loc $ addWarnTc $ + = do { setSrcSpan loc $ addWarnTc' $ (text "Ignoring ANN annotation" <> plural anns <> comma <+> text "because this is a stage-1 compiler or doesn't support GHCi") ; return [] } diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 43f933b70d..3835bf185c 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -707,7 +707,8 @@ mkExport prag_fn qtvs theta tcSubType_NC sig_ctxt sel_poly_ty (mkCheckExpType poly_ty) ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs - ; when warn_missing_sigs $ localSigWarn poly_id mb_sig + ; when warn_missing_sigs $ + localSigWarn Opt_WarnMissingLocalSigs poly_id mb_sig ; return (ABE { abe_wrap = wrap -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty) @@ -797,7 +798,8 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs , ppr annotated_theta, ppr inferred_theta , ppr inferred_diff ] ; case partial_sigs of - True | warn_partial_sigs -> reportWarning msg + True | warn_partial_sigs -> + reportWarning (Just Opt_WarnPartialTypeSignatures) msg | otherwise -> return () False -> reportError msg @@ -851,19 +853,19 @@ mk_inf_msg poly_name poly_ty tidy_env -- | Warn the user about polymorphic local binders that lack type signatures. -localSigWarn :: Id -> Maybe TcIdSigInfo -> TcM () -localSigWarn id mb_sig +localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInfo -> TcM () +localSigWarn flag id mb_sig | Just _ <- mb_sig = return () | not (isSigmaTy (idType id)) = return () - | otherwise = warnMissingSig msg id + | otherwise = warnMissingSig flag msg id where msg = text "Polymorphic local binding with no type signature:" -warnMissingSig :: SDoc -> Id -> TcM () -warnMissingSig msg id +warnMissingSig :: WarningFlag -> SDoc -> Id -> TcM () +warnMissingSig flag msg id = do { env0 <- tcInitTidyEnv ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) - ; addWarnTcM (env1, mk_msg tidy_ty) } + ; addWarnTcM flag (env1, mk_msg tidy_ty) } where mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ] @@ -1126,7 +1128,7 @@ tcSpecPrags poly_id prag_sigs is_bad_sig s = not (isSpecLSig s || isInlineLSig s) warn_discarded_sigs - = addWarnTc (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) + = addWarnTc' (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) 2 (vcat (map (ppr . getLoc) bad_sigs))) -------------- @@ -1140,7 +1142,7 @@ tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl) -- However we want to use fun_name in the error message, since that is -- what the user wrote (Trac #8537) = addErrCtxt (spec_ctxt prag) $ - do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) + do { warnIf' (not (isOverloadedTy poly_ty || isInlinePragma inl)) (text "SPECIALISE pragma for non-overloaded function" <+> quotes (ppr fun_name)) -- Note [SPECIALISE pragmas] @@ -1206,7 +1208,7 @@ tcImpSpec :: (Name, Sig Name) -> TcM [TcSpecPrag] tcImpSpec (name, prag) = do { id <- tcLookupId name ; unless (isAnyInlinePragma (idInlinePragma id)) - (addWarnTc (impSpecErr name)) + (addWarnTc' (impSpecErr name)) ; tcSpecPrag id prag } impSpecErr :: Name -> SDoc diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index b1baabb963..3ccebeff0c 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -210,9 +210,9 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn ; spec_prags <- discardConstraints $ tcSpecPrags global_dm_id prags - ; warnTc (not (null spec_prags)) - (text "Ignoring SPECIALISE pragmas on default method" - <+> quotes (ppr sel_name)) + ; warnTc' (not (null spec_prags)) + (text "Ignoring SPECIALISE pragmas on default method" + <+> quotes (ppr sel_name)) ; let hs_ty = lookupHsSig hs_sig_fn sel_name `orElse` pprPanic "tc_dm" (ppr sel_name) @@ -280,7 +280,7 @@ tcClassMinimalDef _clas sigs op_info -- class ops without default methods are required, since we -- have no way to fill them in otherwise whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $ - (\bf -> addWarnTc (warningMinimalDefIncomplete bf)) + (\bf -> addWarnTc' (warningMinimalDefIncomplete bf)) return mindef where -- By default require all methods without a default @@ -487,7 +487,7 @@ warnMissingAT :: Name -> TcM () warnMissingAT name = do { warn <- woptM Opt_WarnMissingMethods ; traceTc "warn" (ppr name <+> ppr warn) - ; warnTc warn -- Warn only if -Wmissing-methods + ; warnTc Opt_WarnMissingMethods warn -- Warn only if -Wmissing-methods (text "No explicit" <+> text "associated type" <+> text "or default declaration for " <+> quotes (ppr name)) } diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 56772f2b1a..2c205069da 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -559,7 +559,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode)) warnUselessTypeable :: TcM () warnUselessTypeable = do { warn <- woptM Opt_WarnDerivingTypeable - ; when warn $ addWarnTc + ; when warn $ addWarnTc Opt_WarnDerivingTypeable $ text "Deriving" <+> quotes (ppr typeableClassName) <+> text "has no effect: all types now auto-derive Typeable" } @@ -1499,8 +1499,8 @@ mkNewTypeEqn dflags overlap_mode tvs -- CanDerive/DerivableViaInstance _ -> do when (newtype_deriving && deriveAnyClass) $ - addWarnTc (sep [ text "Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled" - , text "Defaulting to the DeriveAnyClass strategy for instantiating" <+> ppr cls ]) + addWarnTc' (sep [ text "Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled" + , text "Defaulting to the DeriveAnyClass strategy for instantiating" <+> ppr cls ]) go_for_it where newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 2140a797ff..75a3b5cbb7 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -342,13 +342,13 @@ warnRedundantConstraints ctxt env info ev_vars addErrCtxt (text "In" <+> ppr info) $ do { env <- getLclEnv ; msg <- mkErrorReport ctxt env (important doc) - ; reportWarning msg } + ; reportWarning Nothing msg } | otherwise -- But for InstSkol there already *is* a surrounding -- "In the instance declaration for Eq [a]" context -- and we don't want to say it twice. Seems a bit ad-hoc = do { msg <- mkErrorReport ctxt env (important doc) - ; reportWarning msg } + ; reportWarning Nothing msg } where doc = text "Redundant constraint" <> plural redundant_evs <> colon <+> pprEvVarTheta redundant_evs @@ -573,7 +573,7 @@ reportGroup mk_err ctxt cts = -- Only warn about missing MonadFail constraint when -- there are no other missing contstraints! (monadFailCts, []) -> do { err <- mk_err ctxt monadFailCts - ; reportWarning err } + ; reportWarning Nothing err } (_, cts') -> do { err <- mk_err ctxt cts' ; maybeReportError ctxt err @@ -597,7 +597,7 @@ maybeReportHoleError ctxt ct err -- only if -fwarn_partial_type_signatures is on case cec_type_holes ctxt of HoleError -> reportError err - HoleWarn -> reportWarning err + HoleWarn -> reportWarning (Just Opt_WarnPartialTypeSignatures) err HoleDefer -> return () -- Otherwise this is a typed hole in an expression @@ -605,7 +605,7 @@ maybeReportHoleError ctxt ct err = -- If deferring, report a warning only if -Wtyped-holds is on case cec_expr_holes ctxt of HoleError -> reportError err - HoleWarn -> reportWarning err + HoleWarn -> reportWarning (Just Opt_WarnTypedHoles) err HoleDefer -> return () maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM () @@ -615,12 +615,12 @@ maybeReportError ctxt err = return () -- so suppress this error/warning | cec_errors_as_warns ctxt - = reportWarning err + = reportWarning Nothing err | otherwise = case cec_defer_type_errors ctxt of TypeDefer -> return () - TypeWarn -> reportWarning err + TypeWarn -> reportWarning Nothing err TypeError -> reportError err addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () @@ -2328,7 +2328,7 @@ warnDefaulting wanteds default_ty , quotes (ppr default_ty) ]) 2 ppr_wanteds - ; setCtLocM loc $ warnTc warn_default warn_msg } + ; setCtLocM loc $ warnTc Opt_WarnTypeDefaults warn_default warn_msg } {- Note [Runtime skolems] diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index d54fbc7644..025d376e77 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -2221,7 +2221,8 @@ checkMissingFields con_like rbinds warn <- woptM Opt_WarnMissingFields unless (not (warn && notNull missing_ns_fields)) - (warnTc True (missingFields con_like missing_ns_fields)) + (warnTc Opt_WarnMissingFields True + (missingFields con_like missing_ns_fields)) where missing_s_fields diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs index bc3a9283c6..bca9a5603d 100644 --- a/compiler/typecheck/TcForeign.hs +++ b/compiler/typecheck/TcForeign.hs @@ -349,7 +349,8 @@ checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () checkMissingAmpersand dflags arg_tys res_ty | null arg_tys && isFunPtrTy res_ty && wopt Opt_WarnDodgyForeignImports dflags - = addWarn (text "possible missing & in foreign import of FunPtr") + = addWarn Opt_WarnDodgyForeignImports + (text "possible missing & in foreign import of FunPtr") | otherwise = return () @@ -522,7 +523,8 @@ checkCConv StdCallConv = do dflags <- getDynFlags then return StdCallConv else do -- This is a warning, not an error. see #3336 when (wopt Opt_WarnUnsupportedCallingConventions dflags) $ - addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") + addWarnTc Opt_WarnUnsupportedCallingConventions + (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") return CCallConv checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") return PrimCallConv diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 82c66cc953..5b433860bd 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -447,7 +447,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls if isHsBootOrSig (tcg_src env) then do warn <- woptM Opt_WarnDerivingTypeable - when warn $ addWarnTc $ vcat + when warn $ addWarnTc Opt_WarnDerivingTypeable $ vcat [ ppTypeable <+> text "instances in .hs-boot files are ignored" , text "This warning will become an error in future versions of the compiler" ] @@ -1570,7 +1570,7 @@ derivBindCtxt sel_id clas tys warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () warnUnsatisfiedMinimalDefinition mindef = do { warn <- woptM Opt_WarnMissingMethods - ; warnTc warn message + ; warnTc Opt_WarnMissingMethods warn message } where message = vcat [text "No explicit implementation for" diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index 5f3bc5b73a..0070cb79c6 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -975,7 +975,8 @@ emitMonadFailConstraint pat res_ty ; return () } warnRebindableClash :: LPat TcId -> TcRn () -warnRebindableClash pattern = addWarnAt (getLoc pattern) +warnRebindableClash pattern = addWarnAt Opt_WarnMissingMonadFailInstances + (getLoc pattern) (text "The failable pattern" <+> quotes (ppr pattern) $$ nest 2 (text "is used together with -XRebindableSyntax." diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 4d1d09a32f..4eaaa58fc9 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -219,7 +219,7 @@ addInlinePrags poly_id prags warn_multiple_inlines inl2 inls | otherwise = setSrcSpan loc $ - addWarnTc (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) + addWarnTc' (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) 2 (vcat (text "Ignoring all but the first" : map pp_inl (inl1:inl2:inls)))) diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index fdc6e5e638..385405f6a7 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -310,7 +310,8 @@ tcRnModuleTcRnM hsc_env hsc_src implicit_prelude import_decls } ; whenWOptM Opt_WarnImplicitPrelude $ - when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ; + when (notNull prel_imports) $ + addWarn Opt_WarnImplicitPrelude (implicitPreludeWarn) ; tcg_env <- {-# SCC "tcRnImports" #-} tcRnImports hsc_env (prel_imports ++ import_decls) ; @@ -1286,7 +1287,7 @@ tcPreludeClashWarn warnFlag name = do ; traceTc "tcPreludeClashWarn/prelude_functions" (hang (ppr name) 4 (sep [ppr clashingElts])) - ; let warn_msg x = addWarnAt (nameSrcSpan (gre_name x)) (hsep + ; let warn_msg x = addWarnAt warnFlag (nameSrcSpan (gre_name x)) (hsep [ text "Local definition of" , (quotes . ppr . nameOccName . gre_name) x , text "clashes with a future Prelude name." ] @@ -1397,7 +1398,7 @@ tcMissingParentClassWarn warnFlag isName shouldName -- <should>" e.g. "Foo is an instance of Monad but not Applicative" ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst warnMsg (Just name:_) = - addWarnAt instLoc $ + addWarnAt warnFlag instLoc $ hsep [ (quotes . ppr . nameOccName) name , text "is an instance of" , (ppr . nameOccName . className) isClass diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 8cf0d748e3..1db87e4602 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -719,9 +719,13 @@ checkErr :: Bool -> MsgDoc -> TcRn () -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) -warnIf :: Bool -> MsgDoc -> TcRn () -warnIf True msg = addWarn msg -warnIf False _ = return () +warnIf :: WarningFlag -> Bool -> MsgDoc -> TcRn () +warnIf flag True msg = addWarn flag msg +warnIf _ False _ = return () + +warnIf' :: Bool -> MsgDoc -> TcRn () +warnIf' True msg = addWarn' msg +warnIf' False _ = return () addMessages :: Messages -> TcRn () addMessages msgs1 @@ -777,9 +781,9 @@ reportError err (warns, errs) <- readTcRef errs_var ; writeTcRef errs_var (warns, errs `snocBag` err) } -reportWarning :: ErrMsg -> TcRn () -reportWarning err - = do { let warn = makeIntoWarning err +reportWarning :: Maybe WarningFlag -> ErrMsg -> TcRn () +reportWarning flag err + = do { let warn = makeIntoWarning flag err -- 'err' was built by mkLongErrMsg or something like that, -- so it's of error severity. For a warning we downgrade -- its severity to SevWarning @@ -1081,44 +1085,70 @@ failIfTcM True err = failWithTcM err -- Warnings have no 'M' variant, nor failure -warnTc :: Bool -> MsgDoc -> TcM () -warnTc warn_if_true warn_msg - | warn_if_true = addWarnTc warn_msg +warnTc :: WarningFlag -> Bool -> MsgDoc -> TcM () +warnTc flag warn_if_true warn_msg + | warn_if_true = addWarnTc flag warn_msg + | otherwise = return () + +warnTc' :: Bool -> MsgDoc -> TcM () +warnTc' warn_if_true warn_msg + | warn_if_true = addWarnTc' warn_msg | otherwise = return () -warnTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () -warnTcM warn_if_true warn_msg - | warn_if_true = addWarnTcM warn_msg +warnTcM :: WarningFlag -> Bool -> (TidyEnv, MsgDoc) -> TcM () +warnTcM flag warn_if_true warn_msg + | warn_if_true = addWarnTcM flag warn_msg | otherwise = return () -addWarnTc :: MsgDoc -> TcM () -addWarnTc msg = do { env0 <- tcInitTidyEnv - ; addWarnTcM (env0, msg) } +warnTcM' :: Bool -> (TidyEnv, MsgDoc) -> TcM () +warnTcM' warn_if_true warn_msg + | warn_if_true = addWarnTcM' warn_msg + | otherwise = return () + +addWarnTc :: WarningFlag -> MsgDoc -> TcM () +addWarnTc flag msg = do { env0 <- tcInitTidyEnv + ; addWarnTcM flag (env0, msg) } + +addWarnTc' :: MsgDoc -> TcM () +addWarnTc' msg = do { env0 <- tcInitTidyEnv + ; addWarnTcM' (env0, msg) } -addWarnTcM :: (TidyEnv, MsgDoc) -> TcM () -addWarnTcM (env0, msg) +addWarnTcM :: WarningFlag -> (TidyEnv, MsgDoc) -> TcM () +addWarnTcM flag (env0, msg) = do { ctxt <- getErrCtxt ; err_info <- mkErrInfo env0 ctxt ; - add_warn msg err_info } + add_warn (Just flag) msg err_info } + +addWarnTcM' :: (TidyEnv, MsgDoc) -> TcM () +addWarnTcM' (env0, msg) + = do { ctxt <- getErrCtxt ; + err_info <- mkErrInfo env0 ctxt ; + add_warn Nothing msg err_info } + +addWarn :: WarningFlag -> MsgDoc -> TcRn () +addWarn flag msg = add_warn (Just flag) msg Outputable.empty + +addWarn' :: MsgDoc -> TcRn () +addWarn' msg = add_warn Nothing msg Outputable.empty -addWarn :: MsgDoc -> TcRn () -addWarn msg = add_warn msg Outputable.empty +addWarnAt :: WarningFlag -> SrcSpan -> MsgDoc -> TcRn () +addWarnAt flag loc msg = add_warn_at (Just flag) loc msg Outputable.empty -addWarnAt :: SrcSpan -> MsgDoc -> TcRn () -addWarnAt loc msg = add_warn_at loc msg Outputable.empty +addWarnAt' :: SrcSpan -> MsgDoc -> TcRn () +addWarnAt' loc msg = add_warn_at Nothing loc msg Outputable.empty -add_warn :: MsgDoc -> MsgDoc -> TcRn () -add_warn msg extra_info +add_warn :: Maybe WarningFlag -> MsgDoc -> MsgDoc -> TcRn () +add_warn flag msg extra_info = do { loc <- getSrcSpanM - ; add_warn_at loc msg extra_info } + ; add_warn_at flag loc msg extra_info } -add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () -add_warn_at loc msg extra_info +add_warn_at :: Maybe WarningFlag -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +add_warn_at flag loc msg extra_info = do { dflags <- getDynFlags ; printer <- getPrintUnqualified dflags ; let { warn = mkLongWarnMsg dflags loc printer msg extra_info } ; - reportWarning warn } + reportWarning flag warn } tcInitTidyEnv :: TcM TidyEnv tcInitTidyEnv @@ -1486,7 +1516,8 @@ failIfM msg = do { env <- getLclEnv ; let full_msg = (if_loc env <> colon) $$ nest 2 msg ; dflags <- getDynFlags - ; liftIO (log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) full_msg) + ; liftIO (log_action dflags dflags Nothing SevFatal + noSrcSpan (defaultErrStyle dflags) full_msg) ; failM } -------------------- @@ -1522,7 +1553,8 @@ forkM_maybe doc thing_inside dflags <- getDynFlags let msg = hang (text "forkM failed:" <+> doc) 2 (text (show exn)) - liftIO $ log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg + liftIO $ log_action dflags dflags Nothing SevFatal + noSrcSpan (defaultErrStyle dflags) msg ; traceIf (text "} ending fork (badly)" <+> doc) ; return Nothing } diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 053c53b86a..08a0bd87dc 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -2351,9 +2351,10 @@ wrapWarnTcS :: TcM a -> TcS a wrapWarnTcS = wrapTcS failTcS, panicTcS :: SDoc -> TcS a -warnTcS, addErrTcS :: SDoc -> TcS () +warnTcS :: WarningFlag -> SDoc -> TcS () +addErrTcS :: SDoc -> TcS () failTcS = wrapTcS . TcM.failWith -warnTcS = wrapTcS . TcM.addWarn +warnTcS flag = wrapTcS . TcM.addWarn flag addErrTcS = wrapTcS . TcM.addErr panicTcS doc = pprPanic "TcCanonical" doc diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index be0735816b..bb86482590 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -742,7 +742,7 @@ decideQuantification apply_mr sigs name_taus constraints -- Warn about the monomorphism restriction ; warn_mono <- woptM Opt_WarnMonomorphism ; let mr_bites = constrained_tvs `intersectsVarSet` zonked_tkvs - ; warnTc (warn_mono && mr_bites) $ + ; warnTc Opt_WarnMonomorphism (warn_mono && mr_bites) $ hang (text "The Monomorphism Restriction applies to the binding" <> plural bndrs <+> text "for" <+> pp_bndrs) 2 (text "Consider giving a type signature for" diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 921da07d2d..6ea4fa3bc5 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -806,8 +806,8 @@ instance TH.Quasi TcM where -- 'msg' is forced to ensure exceptions don't escape, -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr (text msg) - qReport False msg = seqList msg $ addWarn (text msg) + qReport True msg = seqList msg $ addErr (text msg) + qReport False msg = seqList msg $ addWarn' (text msg) qLocation = do { m <- getModule ; l <- getSrcSpanM diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index e68efd09f9..e550fe0eb4 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -2125,13 +2125,13 @@ checkValidDataCon dflags existential_ok tc con (bad_bang n (text "Lazy annotation (~) without StrictData")) check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n | isSrcUnpacked want_unpack, not is_strict - = addWarnTc (bad_bang n (text "UNPACK pragma lacks '!'")) + = addWarnTc' (bad_bang n (text "UNPACK pragma lacks '!'")) | isSrcUnpacked want_unpack , case rep_bang of { HsUnpack {} -> False; _ -> True } , not (gopt Opt_OmitInterfacePragmas dflags) -- If not optimising, se don't unpack, so don't complain! -- See MkId.dataConArgRep, the (HsBang True) case - = addWarnTc (bad_bang n (text "Ignoring unusable UNPACK pragma")) + = addWarnTc' (bad_bang n (text "Ignoring unusable UNPACK pragma")) where is_strict = case strict_mark of NoSrcStrict -> xopt LangExt.StrictData dflags diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index 56cb348669..b018b52994 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -684,7 +684,8 @@ check_valid_theta _ _ [] = return () check_valid_theta env ctxt theta = do { dflags <- getDynFlags - ; warnTcM (wopt Opt_WarnDuplicateConstraints dflags && + ; warnTcM Opt_WarnDuplicateConstraints + (wopt Opt_WarnDuplicateConstraints dflags && notNull dups) (dupPredWarn env dups) ; traceTc "check_valid_theta" (ppr theta) ; mapM_ (check_pred_ty env dflags ctxt) theta } @@ -1455,7 +1456,7 @@ checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) -- (b) failure of injectivity check_branch_compat prev_branches cur_branch | cur_branch `isDominatedBy` prev_branches - = do { addWarnAt (coAxBranchSpan cur_branch) $ + = do { addWarnAt' (coAxBranchSpan cur_branch) $ inaccessibleCoAxBranch ax cur_branch ; return prev_branches } | otherwise |