diff options
Diffstat (limited to 'compiler/GHC/Driver/Main.hs')
| -rw-r--r-- | compiler/GHC/Driver/Main.hs | 77 |
1 files changed, 39 insertions, 38 deletions
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 92d8034127..9329e96d19 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -277,8 +277,8 @@ getWarnings = Hsc $ \_ w -> return (w, w) clearWarnings :: Hsc () clearWarnings = Hsc $ \_ _ -> return ((), emptyBag) -logWarnings :: WarningMessages -> Hsc () -logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) +logDiagnostics :: Bag (MsgEnvelope DiagnosticMessage) -> Hsc () +logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) getHscEnv :: Hsc HscEnv getHscEnv = Hsc $ \e w -> return (e, w) @@ -297,7 +297,7 @@ logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc () logWarningsReportErrors (warnings,errors) = do let warns = fmap pprWarning warnings errs = fmap pprError errors - logWarnings warns + logDiagnostics warns when (not $ isEmptyBag errs) $ throwErrors errs -- | Log warnings and throw errors, assuming the messages @@ -306,10 +306,10 @@ handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a handleWarningsThrowErrors (warnings, errors) = do let warns = fmap pprWarning warnings errs = fmap pprError errors - logWarnings warns + logDiagnostics warns dflags <- getDynFlags logger <- getLogger - (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings + let (wWarns, wErrs) = partitionMessageBag warns liftIO $ printBagOfErrors logger dflags wWarns throwErrors (unionBags errs wErrs) @@ -329,21 +329,21 @@ handleWarningsThrowErrors (warnings, errors) = do -- 2. If there are no error messages, but the second result indicates failure -- there should be warnings in the first result. That is, if the action -- failed, it must have been due to the warnings (i.e., @-Werror@). -ioMsgMaybe :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc a +ioMsgMaybe :: IO (Messages DiagnosticMessage, Maybe a) -> Hsc a ioMsgMaybe ioA = do (msgs, mb_r) <- liftIO ioA let (warns, errs) = partitionMessages msgs - logWarnings warns + logDiagnostics warns case mb_r of Nothing -> throwErrors errs Just r -> ASSERT( isEmptyBag errs ) return r -- | like ioMsgMaybe, except that we ignore error messages and return -- 'Nothing' instead. -ioMsgMaybe' :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc (Maybe a) +ioMsgMaybe' :: IO (Messages DiagnosticMessage, Maybe a) -> Hsc (Maybe a) ioMsgMaybe' ioA = do (msgs, mb_r) <- liftIO $ ioA - logWarnings (getWarningMessages msgs) + logDiagnostics (getWarningMessages msgs) return mb_r -- ----------------------------------------------------------------------------- @@ -423,7 +423,7 @@ hscParse' mod_summary handleWarningsThrowErrors (getMessages pst) POk pst rdr_module -> do let (warns, errs) = bimap (fmap pprWarning) (fmap pprError) (getMessages pst) - logWarnings warns + logDiagnostics warns liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser" FormatHaskell (ppr rdr_module) liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST" @@ -565,12 +565,12 @@ tcRnModule' sum save_rn_syntax mod = do hsc_env <- getHscEnv dflags <- getDynFlags + let reason = WarningWithFlag Opt_WarnMissingSafeHaskellMode -- -Wmissing-safe-haskell-mode when (not (safeHaskellModeEnabled dflags) && wopt Opt_WarnMissingSafeHaskellMode dflags) $ - logWarnings $ unitBag $ - makeIntoWarning (Reason Opt_WarnMissingSafeHaskellMode) $ - mkPlainWarnMsg (getLoc (hpm_module mod)) $ + logDiagnostics $ unitBag $ + mkPlainMsgEnvelope reason (getLoc (hpm_module mod)) $ warnMissingSafeHaskellMode tcg_res <- {-# SCC "Typecheck-Rename" #-} @@ -597,15 +597,15 @@ tcRnModule' sum save_rn_syntax mod = do case wopt Opt_WarnSafe dflags of True | safeHaskell dflags == Sf_Safe -> return () - | otherwise -> (logWarnings $ unitBag $ - makeIntoWarning (Reason Opt_WarnSafe) $ - mkPlainWarnMsg (warnSafeOnLoc dflags) $ + | otherwise -> (logDiagnostics $ unitBag $ + mkPlainMsgEnvelope (WarningWithFlag Opt_WarnSafe) + (warnSafeOnLoc dflags) $ errSafe tcg_res') False | safeHaskell dflags == Sf_Trustworthy && wopt Opt_WarnTrustworthySafe dflags -> - (logWarnings $ unitBag $ - makeIntoWarning (Reason Opt_WarnTrustworthySafe) $ - mkPlainWarnMsg (trustworthyOnLoc dflags) $ + (logDiagnostics $ unitBag $ + mkPlainMsgEnvelope (WarningWithFlag Opt_WarnTrustworthySafe) + (trustworthyOnLoc dflags) $ errTwthySafe tcg_res') False -> return () return tcg_res' @@ -1136,7 +1136,7 @@ hscCheckSafeImports tcg_env = do case safeLanguageOn dflags of True -> do -- XSafe: we nuke user written RULES - logWarnings $ warns (tcg_rules tcg_env') + logDiagnostics $ warns (tcg_rules tcg_env') return tcg_env' { tcg_rules = [] } False -- SafeInferred: user defined RULES, so not safe @@ -1149,9 +1149,9 @@ hscCheckSafeImports tcg_env = do warns rules = listToBag $ map warnRules rules - warnRules :: LRuleDecl GhcTc -> MsgEnvelope DecoratedSDoc + warnRules :: LRuleDecl GhcTc -> MsgEnvelope DiagnosticMessage warnRules (L loc (HsRule { rd_name = n })) = - mkPlainWarnMsg (locA loc) $ + mkPlainMsgEnvelope WarningWithoutFlag (locA loc) $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" @@ -1195,7 +1195,7 @@ checkSafeImports tcg_env return (infErrs, infPkgs) -- restore old errors - logWarnings oldErrs + logDiagnostics oldErrs case (isEmptyBag safeErrs) of -- Failed safe check @@ -1227,7 +1227,7 @@ checkSafeImports tcg_env cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal cond' v1 v2 | imv_is_safe v1 /= imv_is_safe v2 - = throwOneError $ mkPlainMsgEnvelope (imv_span v1) + = throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag (imv_span v1) (text "Module" <+> ppr (imv_name v1) <+> (text $ "is imported both as a safe and unsafe import!")) | otherwise @@ -1295,7 +1295,7 @@ hscCheckSafe' m l = do iface <- lookup' m case iface of -- can't load iface to check trust! - Nothing -> throwOneError $ mkPlainMsgEnvelope l + Nothing -> throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag l $ text "Can't load the interface file for" <+> ppr m <> text ", to check that it can be safely imported" @@ -1321,28 +1321,28 @@ hscCheckSafe' m l = do (True, False) -> pkgTrustErr (False, _ ) -> modTrustErr in do - logWarnings warns - logWarnings errs + logDiagnostics warns + logDiagnostics errs return (trust == Sf_Trustworthy, pkgRs) where state = hsc_units hsc_env inferredImportWarn = unitBag - $ makeIntoWarning (Reason Opt_WarnInferredSafeImports) - $ mkWarnMsg l (pkgQual state) + $ mkShortMsgEnvelope (WarningWithFlag Opt_WarnInferredSafeImports) + l (pkgQual state) $ sep [ text "Importing Safe-Inferred module " <> ppr (moduleName m) <> text " from explicitly Safe module" ] - pkgTrustErr = unitBag $ mkMsgEnvelope l (pkgQual state) $ + pkgTrustErr = unitBag $ mkShortMsgEnvelope ErrorWithoutFlag l (pkgQual state) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The package (" <> (pprWithUnitState state $ ppr (moduleUnit m)) <> text ") the module resides in isn't trusted." ] - modTrustErr = unitBag $ mkMsgEnvelope l (pkgQual state) $ + modTrustErr = unitBag $ mkShortMsgEnvelope ErrorWithoutFlag l (pkgQual state) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The module itself isn't safe." ] @@ -1388,7 +1388,7 @@ checkPkgTrust pkgs = do | unitIsTrusted $ unsafeLookupUnitId state pkg = acc | otherwise - = (:acc) $ mkMsgEnvelope noSrcSpan (pkgQual state) + = (:acc) $ mkShortMsgEnvelope ErrorWithoutFlag noSrcSpan (pkgQual state) $ pprWithUnitState state $ text "The package (" <> ppr pkg @@ -1411,9 +1411,10 @@ markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv markUnsafeInfer tcg_env whyUnsafe = do dflags <- getDynFlags + let reason = WarningWithFlag Opt_WarnUnsafe when (wopt Opt_WarnUnsafe dflags) - (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $ - mkPlainWarnMsg (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) + (logDiagnostics $ unitBag $ + mkPlainMsgEnvelope reason (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe) -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other @@ -1434,7 +1435,7 @@ markUnsafeInfer tcg_env whyUnsafe = do ] badFlags df = concatMap (badFlag df) unsafeFlagsForInfer badFlag df (str,loc,on,_) - | on df = [mkLocMessage SevOutput (loc df) $ + | on df = [mkLocMessage MCOutput (loc df) $ text str <+> text "is not allowed in Safe Haskell"] | otherwise = [] badInsts insts = concatMap badInst insts @@ -1443,7 +1444,7 @@ markUnsafeInfer tcg_env whyUnsafe = do checkOverlap _ = True badInst ins | checkOverlap (overlapMode (is_flag ins)) - = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $ + = [mkLocMessage MCOutput (nameSrcSpan $ getName $ is_dfun ins) $ ppr (overlapMode $ is_flag ins) <+> text "overlap mode isn't allowed in Safe Haskell"] | otherwise = [] @@ -2006,7 +2007,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do case is of [L _ i] -> return i _ -> liftIO $ throwOneError $ - mkPlainMsgEnvelope noSrcSpan $ + mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $ text "parse error in import declaration" -- | Typecheck an expression (but don't run it) @@ -2035,7 +2036,7 @@ hscParseExpr expr = do maybe_stmt <- hscParseStmt expr case maybe_stmt of Just (L _ (BodyStmt _ expr _ _)) -> return expr - _ -> throwOneError $ mkPlainMsgEnvelope noSrcSpan + _ -> throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan (text "not an expression:" <+> quotes (text expr)) hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) |