Commit dd77bcdd authored by Alfredo Di Napoli's avatar Alfredo Di Napoli

Add a mkTcRnDiagnostic function

parent 98f78846
Pipeline #31370 failed with stages
in 39 seconds
......@@ -9,7 +9,8 @@ module GHC.Tc.Errors(
reportUnsolved, reportAllUnsolved, warnAllUnsolved,
warnDefaulting,
solverDepthErrorTcS
solverDepthErrorTcS,
mkTcRnDiagnostic
) where
#include "HsVersions.h"
......@@ -38,6 +39,7 @@ import GHC.Core.InstEnv
import GHC.Core.TyCon
import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Tc.Errors.Types
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.EvTerm
import GHC.Hs.Binds ( PatSynBind(..) )
......@@ -125,6 +127,30 @@ and does not fail if -fdefer-type-errors is on, so that we can continue
compilation. The errors are turned into warnings in `reportUnsolved`.
-}
-- | Creates a new TcRn diagnostic message.
mkTcRnDiagnostic :: DynFlags -> SrcSpan -> PrintUnqualified -> TcRnDiagnostic -> MsgEnvelope TcRnMessage
mkTcRnDiagnostic dflags loc printer msg =
mkMsgEnvelope loc printer (TcRnMessage $ DiagnosticMessage msg tcRnReason)
where
tcRnReason :: DiagnosticReason
tcRnReason = case msg of
TcRnUnknownMessage decMsg
-> diagnosticReason decMsg
TcRnMessageWithUnitState _ decMsg
-> diagnosticReason decMsg
TcRnBadTelescope{}
-> ErrReason
TcRnOutOfScope{}
-> ErrReason
TcRnOutOfScopeHole{}
-> let defer_holes = gopt Opt_DeferTypedHoles dflags
warn_holes = wopt Opt_WarnTypedHoles dflags
rea | not defer_holes = ErrReason
| warn_holes = WarnReasonWithFlag Opt_WarnTypedHoles
| otherwise = ErrReason
in rea
-- | Report unsolved goals as errors or warnings. We may also turn some into
-- deferred run-time errors if `-fdefer-type-errors` is on.
reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
......@@ -1113,7 +1139,7 @@ There are two cases to consider:
for holes in partial type signatures, unless -Wpartial-type-signatures is not on, in which case
the messages are discarded. If deferring, report a warning only if -Wtyped-holes is on.
See also 'reportUnresolved'.
See also 'reportUnsolved'.
-}
......
......@@ -24,8 +24,8 @@ import GHC.Utils.Outputable
import qualified Data.List.NonEmpty as NE
instance Diagnostic TcRnMessage where
diagnosticMessage = pprTcRnMessage
diagnosticReason = const ErrReason -- FIXME(adn) Implement this to validate design.
diagnosticMessage (TcRnMessage msg) = pprTcRnDiagnostic . diagMessage $ msg
diagnosticReason (TcRnMessage msg) = diagReason msg
notInScopeErr :: RdrName -> SDoc
notInScopeErr rdr_name
......@@ -43,13 +43,13 @@ exactNameErr name =
, text "perhaps via newName, but did not bind it"
, text "If that's it, then -ddump-splices might be useful" ])
pprTcRnMessage :: TcRnMessage -> DecoratedSDoc
pprTcRnMessage = \case
pprTcRnDiagnostic :: TcRnDiagnostic -> DecoratedSDoc
pprTcRnDiagnostic = \case
TcRnUnknownMessage d ->
d
diagMessage d
TcRnMessageWithUnitState unit_state msg ->
mapDecorated (pprWithUnitState unit_state) $ pprTcRnMessage msg
TcRnMessageWithUnitState unit_state (TcRnMessage msg) ->
mapDecorated (pprWithUnitState unit_state) $ pprTcRnDiagnostic (diagMessage msg)
TcRnBadTelescope telescope sorted_tvs context ->
mkDecorated $ [m, context]
......
module GHC.Tc.Errors.Types (
-- * Main type
-- * Main types
TcRnMessage(..)
, TcRnDiagnostic(..)
-- * Types for suggestions
, HowInScope
, ImportSuggestion(..)
, NameSuggestions(..)
, ExtensionSuggestion(..)
, OutOfScopeSuggestions(..)
-- * Constructing messages
-- , mkTcRnWarn
-- * Constructing suggestions
, noOutOfScopeSuggestions
) where
......@@ -25,20 +24,13 @@ import GHC.Types.Var
import GHC.Unit.Module.Name
import GHC.Unit.State ( UnitState )
import GHC.Unit.Types
-- import GHC.Utils.Outputable
import Data.List.NonEmpty (NonEmpty)
{- TODO: I need to write this function to validate the full design.
newtype TcRnMessage = TcRnMessage (DiagnosticMessage TcRnDiagnostic)
-- | Creates a new 'ErrMsg' parameterised over the input 'Warning', attaching the
-- correct 'WarnReason' to it.
mkTcRnWarn :: WarnReason -> SrcSpan -> PrintUnqualified -> TcRnMessage -> MsgEnvelope TcRnMessage
mkTcRnWarn reason loc printer warn = makeIntoWarning reason (mkErr loc printer warn)
-}
-- | An error which might arise during typechecking/renaming.
data TcRnMessage
= TcRnUnknownMessage !DecoratedSDoc
-- | An diagnostic which might be emitted during typechecking/renaming.
data TcRnDiagnostic
= TcRnUnknownMessage !DecoratedMessage
-- See 'mkDecoratedSDocAt' in 'GHC.Tc.Utils.Monad', where we need the 'UnitState'
-- to render the 'Unit' properly. This is a type constructor to build an embellished
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment