summaryrefslogtreecommitdiff
path: root/compiler/GHC/Driver
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Driver')
-rw-r--r--compiler/GHC/Driver/Errors.hs9
-rw-r--r--compiler/GHC/Driver/Errors/Ppr.hs23
-rw-r--r--compiler/GHC/Driver/Errors/Types.hs6
-rw-r--r--compiler/GHC/Driver/Main.hs4
-rw-r--r--compiler/GHC/Driver/Make.hs2
-rw-r--r--compiler/GHC/Driver/Monad.hs2
-rw-r--r--compiler/GHC/Driver/Pipeline.hs2
7 files changed, 27 insertions, 21 deletions
diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs
index baaa551588..efe45b2f6d 100644
--- a/compiler/GHC/Driver/Errors.hs
+++ b/compiler/GHC/Driver/Errors.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
module GHC.Driver.Errors (
printOrThrowDiagnostics
, printMessages
@@ -16,8 +17,8 @@ import GHC.Utils.Outputable (hang, ppr, ($$), SDocContext, text, withPprStyle,
import GHC.Utils.Logger
import qualified GHC.Driver.CmdLine as CmdLine
-printMessages :: Diagnostic a => Logger -> DiagOpts -> Messages a -> IO ()
-printMessages logger opts msgs
+printMessages :: forall a . Diagnostic a => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
+printMessages logger msg_opts opts msgs
= sequence_ [ let style = mkErrStyle unqual
ctx = (diag_ppr_ctx opts) { sdocStyle = style }
in logMsg logger (MCDiagnostic sev . diagnosticReason $ dia) s $
@@ -30,7 +31,7 @@ printMessages logger opts msgs
where
messageWithHints :: Diagnostic a => SDocContext -> a -> SDoc
messageWithHints ctx e =
- let main_msg = formatBulleted ctx $ diagnosticMessage e
+ let main_msg = formatBulleted ctx $ diagnosticMessage msg_opts e
in case diagnosticHints e of
[] -> main_msg
[h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h)
@@ -56,7 +57,7 @@ printOrThrowDiagnostics logger opts msgs
| errorsOrFatalWarningsFound msgs
= throwErrors msgs
| otherwise
- = printMessages logger opts msgs
+ = printMessages logger () opts msgs
-- | Convert a 'PsError' into a wrapped 'DriverMessage'; use it
-- for dealing with parse errors when the driver is doing dependency analysis.
diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs
index 8fe416196b..53fcc8e6ab 100644
--- a/compiler/GHC/Driver/Errors/Ppr.hs
+++ b/compiler/GHC/Driver/Errors/Ppr.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic {DriverMessage, GhcMessage}
module GHC.Driver.Errors.Ppr where
@@ -34,17 +35,19 @@ suggestInstantiatedWith pi_mod_name insts =
instance Diagnostic GhcMessage where
- diagnosticMessage = \case
+ type DiagnosticOpts GhcMessage = ()
+ defaultDiagnosticOpts = ()
+ diagnosticMessage _ = \case
GhcPsMessage m
- -> diagnosticMessage m
+ -> diagnosticMessage () m
GhcTcRnMessage m
- -> diagnosticMessage m
+ -> diagnosticMessage () m
GhcDsMessage m
- -> diagnosticMessage m
+ -> diagnosticMessage () m
GhcDriverMessage m
- -> diagnosticMessage m
+ -> diagnosticMessage () m
GhcUnknownMessage m
- -> diagnosticMessage m
+ -> diagnosticMessage () m
diagnosticReason = \case
GhcPsMessage m
@@ -71,11 +74,13 @@ instance Diagnostic GhcMessage where
-> diagnosticHints m
instance Diagnostic DriverMessage where
- diagnosticMessage = \case
+ type DiagnosticOpts DriverMessage = ()
+ defaultDiagnosticOpts = ()
+ diagnosticMessage _ = \case
DriverUnknownMessage m
- -> diagnosticMessage m
+ -> diagnosticMessage () m
DriverPsHeaderMessage m
- -> diagnosticMessage m
+ -> diagnosticMessage () m
DriverMissingHomeModules missing buildingCabalPackage
-> let msg | buildingCabalPackage == YesBuildingCabalPackage
= hang
diff --git a/compiler/GHC/Driver/Errors/Types.hs b/compiler/GHC/Driver/Errors/Types.hs
index 015ae5e375..5f87c8e94a 100644
--- a/compiler/GHC/Driver/Errors/Types.hs
+++ b/compiler/GHC/Driver/Errors/Types.hs
@@ -83,7 +83,7 @@ data GhcMessage where
-- 'Diagnostic' constraint ensures that worst case scenario we can still
-- render this into something which can be eventually converted into a
-- 'DecoratedSDoc'.
- GhcUnknownMessage :: forall a. (Diagnostic a, Typeable a) => a -> GhcMessage
+ GhcUnknownMessage :: forall a. (DiagnosticOpts a ~ (), Diagnostic a, Typeable a) => a -> GhcMessage
-- | Creates a new 'GhcMessage' out of any diagnostic. This function is also
-- provided to ease the integration of #18516 by allowing diagnostics to be
@@ -91,7 +91,7 @@ data GhcMessage where
-- conversion can happen gradually. This function should not be needed within
-- GHC, as it would typically be used by plugin or library authors (see
-- comment for the 'GhcUnknownMessage' type constructor)
-ghcUnknownMessage :: (Diagnostic a, Typeable a) => a -> GhcMessage
+ghcUnknownMessage :: (DiagnosticOpts a ~ (), Diagnostic a, Typeable a) => a -> GhcMessage
ghcUnknownMessage = GhcUnknownMessage
-- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on
@@ -110,7 +110,7 @@ type DriverMessages = Messages DriverMessage
-- | A message from the driver.
data DriverMessage where
-- | Simply wraps a generic 'Diagnostic' message @a@.
- DriverUnknownMessage :: (Diagnostic a, Typeable a) => a -> DriverMessage
+ DriverUnknownMessage :: (DiagnosticOpts a ~ (), Diagnostic a, Typeable a) => a -> DriverMessage
-- | A parse error in parsing a Haskell file header during dependency
-- analysis
DriverPsHeaderMessage :: !PsMessage -> DriverMessage
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 7db9b62331..982666f490 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -381,7 +381,7 @@ handleWarningsThrowErrors (warnings, errors) = do
logDiagnostics (GhcPsMessage <$> warnings)
logger <- getLogger
let (wWarns, wErrs) = partitionMessages warnings
- liftIO $ printMessages logger diag_opts wWarns
+ liftIO $ printMessages logger () diag_opts wWarns
throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs
-- | Deal with errors and warnings returned by a compilation step
@@ -1580,7 +1580,7 @@ markUnsafeInfer tcg_env whyUnsafe = do
whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
, text "Reason:"
, nest 4 $ (vcat $ badFlags df) $+$
- (vcat $ pprMsgEnvelopeBagWithLoc (getMessages whyUnsafe)) $+$
+ (vcat $ pprMsgEnvelopeBagWithLoc undefined (getMessages whyUnsafe)) $+$
(vcat $ badInsts $ tcg_insts tcg_env)
]
badFlags df = concatMap (badFlag df) unsafeFlagsForInfer
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index efaefd84f5..21f8226f31 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -2267,7 +2267,7 @@ wrapAction :: HscEnv -> IO a -> IO (Maybe a)
wrapAction hsc_env k = do
let lcl_logger = hsc_logger hsc_env
lcl_dynflags = hsc_dflags hsc_env
- let logg err = printMessages lcl_logger (initDiagOpts lcl_dynflags) (srcErrorMessages err)
+ let logg err = printMessages lcl_logger () (initDiagOpts lcl_dynflags) (srcErrorMessages err)
-- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle
-- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches`
-- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to
diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs
index bfe7e0feb8..a620dc0d70 100644
--- a/compiler/GHC/Driver/Monad.hs
+++ b/compiler/GHC/Driver/Monad.hs
@@ -247,7 +247,7 @@ printException err = do
dflags <- getDynFlags
logger <- getLogger
let !diag_opts = initDiagOpts dflags
- liftIO $ printMessages logger diag_opts (srcErrorMessages err)
+ liftIO $ printMessages logger () diag_opts (srcErrorMessages err)
-- | A function called to log warnings and errors.
type WarnErrLogger = forall m. (HasDynFlags m , MonadIO m, HasLogger m) => Maybe SourceError -> m ()
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index e988979df2..b40549e701 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -161,7 +161,7 @@ preprocess hsc_env input_fn mb_input_buf mb_phase =
to_driver_messages :: Messages GhcMessage -> Messages DriverMessage
to_driver_messages msgs = case traverse to_driver_message msgs of
Nothing -> pprPanic "non-driver message in preprocess"
- (vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs))
+ (vcat $ pprMsgEnvelopeBagWithLoc undefined (getMessages msgs))
Just msgs' -> msgs'
to_driver_message = \case
View Lorry Controller Status