diff options
| author | Alfredo Di Napoli <alfredo@well-typed.com> | 2021-05-11 11:27:34 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-06-03 15:58:33 -0400 |
| commit | d5b89ed4d3c444e8bc4fe7cbbee38f9766574b84 (patch) | |
| tree | 85810c3cabe578c1bdca32e92b9eca87bea2c116 /compiler/GHC/HsToCore.hs | |
| parent | 25977ab542a30df4ae71d9699d015bcdd1ab7cfb (diff) | |
| download | haskell-d5b89ed4d3c444e8bc4fe7cbbee38f9766574b84.tar.gz | |
Port HsToCore messages to new infrastructure
This commit converts a bunch of HsToCore (Ds) messages to use the new
GHC's diagnostic message infrastructure. In particular the DsMessage
type has been expanded with a lot of type constructors, each
encapsulating a particular error and warning emitted during desugaring.
Due to the fact that levity polymorphism checking can happen both at the
Ds and at the TcRn level, a new `TcLevityCheckDsMessage` constructor has
been added to the `TcRnMessage` type.
Diffstat (limited to 'compiler/GHC/HsToCore.hs')
| -rw-r--r-- | compiler/GHC/HsToCore.hs | 22 |
1 files changed, 3 insertions, 19 deletions
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 409d0ff6d3..e61be3dd69 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -431,7 +431,7 @@ dsRule (L loc (HsRule { rd_name = name -- and take the body apart into a (f args) form ; dflags <- getDynFlags ; case decomposeRuleLhs dflags bndrs'' lhs'' of { - Left msg -> do { diagnosticDs WarningWithoutFlag msg; return Nothing } ; + Left msg -> do { diagnosticDs msg; return Nothing } ; Right (final_bndrs, fn_id, args) -> do { let is_local = isLocalId fn_id @@ -466,26 +466,10 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids | isLocalId lhs_id || canUnfold (idUnfolding lhs_id) -- If imported with no unfolding, no worries , idInlineActivation lhs_id `competesWith` rule_act - = diagnosticDs (WarningWithFlag Opt_WarnInlineRuleShadowing) - (vcat [ hang (text "Rule" <+> pprRuleName rule_name - <+> text "may never fire") - 2 (text "because" <+> quotes (ppr lhs_id) - <+> text "might inline first") - , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for" - <+> quotes (ppr lhs_id) - , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) - + = diagnosticDs (DsRuleMightInlineFirst rule_name lhs_id rule_act) | check_rules_too , bad_rule : _ <- get_bad_rules lhs_id - = diagnosticDs (WarningWithFlag Opt_WarnInlineRuleShadowing) - (vcat [ hang (text "Rule" <+> pprRuleName rule_name - <+> text "may never fire") - 2 (text "because rule" <+> pprRuleName (ruleName bad_rule) - <+> text "for"<+> quotes (ppr lhs_id) - <+> text "might fire first") - , text "Probable fix: add phase [n] or [~n] to the competing rule" - , whenPprDebug (ppr bad_rule) ]) - + = diagnosticDs (DsAnotherRuleMightFireFirst rule_name (ruleName bad_rule) lhs_id) | otherwise = return () |