From 3280100897934f13e25697100ffce850d3bd0745 Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Wed, 24 Mar 2021 10:01:53 +0100 Subject: Review, part 3 --- compiler/GHC/Driver/Main.hs | 6 ++++-- compiler/GHC/Driver/Make.hs | 16 ++++++++-------- compiler/GHC/Driver/Monad.hs | 11 +++++++---- compiler/GHC/Rename/HsType.hs | 3 ++- compiler/GHC/Rename/Module.hs | 19 ++++++++++--------- 5 files changed, 31 insertions(+), 24 deletions(-) diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index fd5548934b..afd81533ae 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -284,7 +284,9 @@ clearWarnings :: Hsc () clearWarnings = Hsc $ \_ _ -> return ((), emptyBag) logDiagnostics :: Bag (MsgEnvelope DiagnosticMessage) -> Hsc () -logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) +logDiagnostics w + | isEmptyBag w = pure () + | otherwise = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) getHscEnv :: Hsc HscEnv getHscEnv = Hsc $ \e w -> return (e, w) @@ -1338,7 +1340,7 @@ hscCheckSafe' m l = do where state = hsc_units hsc_env - inferredImportWarn dflags = catBagMaybes $ unitBag + inferredImportWarn dflags = maybeToBag $ mkShortMsgEnvelope dflags (WarningWithFlag Opt_WarnInferredSafeImports) l (pkgQual state) $ sep diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index fe269e0f85..a069fd186d 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -69,10 +69,10 @@ import GHC.Iface.Load ( cannotFindModule ) import GHC.IfaceToCore ( typecheckIface ) import GHC.Iface.Recomp ( RecompileRequired ( MustCompile ) ) -import GHC.Data.Bag ( unitBag, listToBag, unionManyBags, isEmptyBag ) +import GHC.Data.Bag ( unitBag, listToBag, unionManyBags, isEmptyBag, maybeToBag ) import GHC.Data.Graph.Directed import GHC.Data.FastString -import GHC.Data.Maybe (whenIsJust, expectJust ) +import GHC.Data.Maybe ( expectJust ) import GHC.Data.StringBuffer import qualified GHC.LanguageExtensions as LangExt @@ -270,7 +270,7 @@ instantiationNodes unit_state = InstantiationNode <$> iuids_to_check warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m () warnMissingHomeModules hsc_env mod_graph = when (not (null missing)) $ - whenIsJust warn $ logWarnings . unitBag + logWarnings warn where dflags = hsc_dflags hsc_env targets = map targetId (hsc_targets hsc_env) @@ -317,8 +317,8 @@ warnMissingHomeModules hsc_env mod_graph = (text "Modules are not listed in command line but needed for compilation: ") 4 (sep (map ppr missing)) - warn = - mkPlainMsgEnvelope (hsc_dflags hsc_env) (WarningWithFlag Opt_WarnMissingHomeModules) noSrcSpan msg + warn = maybeToBag + $ mkPlainMsgEnvelope (hsc_dflags hsc_env) (WarningWithFlag Opt_WarnMissingHomeModules) noSrcSpan msg -- | Describes which modules of the module graph need to be loaded. data LoadHowMuch @@ -383,15 +383,15 @@ warnUnusedPackages = do = filter (\arg -> not $ any (matching state arg) loadedPackages) requestedArgs - let warn = - mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnUnusedPackages) noSrcSpan msg + let warn = maybeToBag + $ mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnUnusedPackages) noSrcSpan msg msg = vcat [ text "The following packages were specified" <+> text "via -package or -package-id flags," , text "but were not needed for compilation:" , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ] when (not (null unusedArgs)) $ - whenIsJust warn $ logWarnings . unitBag + logWarnings warn where packageArg (ExposePackage _ arg _) = Just arg diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs index 1a42d8402f..587d594dba 100644 --- a/compiler/GHC/Driver/Monad.hs +++ b/compiler/GHC/Driver/Monad.hs @@ -33,6 +33,7 @@ module GHC.Driver.Monad ( ) where import GHC.Prelude +import GHC.Data.Bag ( isEmptyBag ) import GHC.Driver.Session import GHC.Driver.Env @@ -144,10 +145,12 @@ withTimingM doc force action = do -- | A monad that allows logging of warnings. logWarnings :: GhcMonad m => WarningMessages -> m () -logWarnings warns = do - dflags <- getSessionDynFlags - logger <- getLogger - liftIO $ printOrThrowDiagnostics logger dflags warns +logWarnings warns + | isEmptyBag warns = pure () + | otherwise = do + dflags <- getSessionDynFlags + logger <- getLogger + liftIO $ printOrThrowDiagnostics logger dflags warns -- ----------------------------------------------------------------------------- -- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index fbdcc15730..07cc79fd17 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -1648,7 +1648,8 @@ dataKindsErr env thing warnUnusedForAll :: OutputableBndrFlag flag 'Renamed => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () warnUnusedForAll doc (L loc tv) used_names - = unless (hsTyVarName tv `elemNameSet` used_names) $ + = whenWOptM Opt_WarnUnusedForalls $ + unless (hsTyVarName tv `elemNameSet` used_names) $ addDiagnosticAt (WarningWithFlag Opt_WarnUnusedForalls) (locA loc) $ vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) , inHsDocContext doc ] diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index d5a787f9ab..b5c91c8cc3 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -1945,15 +1945,16 @@ warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) -> RnM () warnNoDerivStrat mds loc = do { dyn_flags <- getDynFlags - ; case mds of - Nothing -> addDiagnosticAt - (WarningWithFlag Opt_WarnMissingDerivingStrategies) - loc - (if xopt LangExt.DerivingStrategies dyn_flags - then no_strat_warning - else no_strat_warning $+$ deriv_strat_nenabled - ) - _ -> pure () + ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $ + case mds of + Nothing -> addDiagnosticAt + (WarningWithFlag Opt_WarnMissingDerivingStrategies) + loc + (if xopt LangExt.DerivingStrategies dyn_flags + then no_strat_warning + else no_strat_warning $+$ deriv_strat_nenabled + ) + _ -> pure () } where no_strat_warning :: SDoc -- cgit v1.2.1