[Git][ghc/ghc][wip/t22884] Changes to make :load work with ghci messages
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Fri May 5 11:18:27 UTC 2023
Matthew Pickering pushed to branch wip/t22884 at Glasgow Haskell Compiler / GHC
Commits:
c8d121c4 by Matthew Pickering at 2023-05-05T12:18:13+01:00
Changes to make :load work with ghci messages
- - - - -
8 changed files:
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Exception.hs
- + testsuite/tests/package/T4806_interactive.script
- + testsuite/tests/package/T4806_interactive.stderr
- testsuite/tests/package/all.T
Changes:
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -329,7 +329,7 @@ buildUnit session cid insts lunit = do
mod_graph <- hsunitModuleGraph False (unLoc lunit)
msg <- mkBackpackMsg
- ok <- load' noIfaceCache LoadAllTargets (Just msg) mod_graph
+ ok <- load' noIfaceCache LoadAllTargets AnyDiagnostic (Just msg) mod_graph
when (failed ok) (liftIO $ exitWith (ExitFailure 1))
let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
@@ -418,7 +418,7 @@ compileExe lunit = do
withBkpExeSession deps_w_rns $ do
mod_graph <- hsunitModuleGraph True (unLoc lunit)
msg <- mkBackpackMsg
- ok <- load' noIfaceCache LoadAllTargets (Just msg) mod_graph
+ ok <- load' noIfaceCache LoadAllTargets AnyDiagnostic (Just msg) mod_graph
when (failed ok) (liftIO $ exitWith (ExitFailure 1))
-- | Register a new virtual unit database containing a single unit
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -16,6 +16,9 @@
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeApplications #-}
-- -----------------------------------------------------------------------------
--
@@ -27,7 +30,7 @@
-- -----------------------------------------------------------------------------
module GHC.Driver.Make (
depanal, depanalE, depanalPartial, checkHomeUnitsClosed,
- load, loadWithCache, load', LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache,
+ load, loadWithCache, load', AnyDiagnostic(..), LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache,
instantiationNodes,
downsweep,
@@ -486,7 +489,7 @@ newIfaceCache = do
-- All other errors are reported using the 'defaultWarnErrLogger'.
load :: GhcMonad f => LoadHowMuch -> f SuccessFlag
-load how_much = loadWithCache noIfaceCache how_much
+load how_much = loadWithCache noIfaceCache AnyDiagnostic how_much
mkBatchMsg :: HscEnv -> Messager
mkBatchMsg hsc_env =
@@ -496,11 +499,11 @@ mkBatchMsg hsc_env =
else batchMsg
-loadWithCache :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag
-loadWithCache cache how_much = do
+loadWithCache :: GhcMonad m => Maybe ModIfaceCache -> (GhcMessage -> AnyDiagnostic) -> LoadHowMuch -> m SuccessFlag
+loadWithCache cache diag_wrapper how_much = do
(errs, mod_graph) <- depanalE [] False -- #17459
msg <- mkBatchMsg <$> getSession
- success <- load' cache how_much (Just msg) mod_graph
+ success <- load' cache how_much diag_wrapper (Just msg) mod_graph
if isEmptyMessages errs
then pure success
else throwErrors (fmap GhcDriverMessage errs)
@@ -692,8 +695,8 @@ data WorkerLimit
-- | Generalized version of 'load' which also supports a custom
-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
-- produced by calling 'depanal'.
-load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
-load' mhmi_cache how_much mHscMessage mod_graph = do
+load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> (GhcMessage -> AnyDiagnostic) -> Maybe Messager -> ModuleGraph -> m SuccessFlag
+load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do
modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }
guessOutputFile
hsc_env <- getSession
@@ -774,7 +777,7 @@ load' mhmi_cache how_much mHscMessage mod_graph = do
setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env
(upsweep_ok, hsc_env1) <- withDeferredDiagnostics $ do
hsc_env <- getSession
- liftIO $ upsweep worker_limit hsc_env mhmi_cache mHscMessage (toCache pruned_cache) build_plan
+ liftIO $ upsweep worker_limit hsc_env mhmi_cache diag_wrapper mHscMessage (toCache pruned_cache) build_plan
setSession hsc_env1
case upsweep_ok of
Failed -> loadFinish upsweep_ok
@@ -1070,6 +1073,7 @@ data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be au
-- into the log queue.
, withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a
, env_messager :: !(Maybe Messager)
+ , diag_wrapper :: GhcMessage -> AnyDiagnostic
}
type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a
@@ -1247,13 +1251,14 @@ upsweep
:: WorkerLimit -- ^ The number of workers we wish to run in parallel
-> HscEnv -- ^ The base HscEnv, which is augmented for each module
-> Maybe ModIfaceCache -- ^ A cache to incrementally write final interface files to
+ -> (GhcMessage -> AnyDiagnostic)
-> Maybe Messager
-> M.Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO (SuccessFlag, HscEnv)
-upsweep n_jobs hsc_env hmi_cache mHscMessage old_hpt build_plan = do
+upsweep n_jobs hsc_env hmi_cache diag_rank mHscMessage old_hpt build_plan = do
(cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan
- runPipelines n_jobs hsc_env mHscMessage pipelines
+ runPipelines n_jobs hsc_env diag_wrapper mHscMessage pipelines
res <- collect_result
let completed = [m | Just (Just m) <- res]
@@ -2434,13 +2439,27 @@ setHUG :: HomeUnitGraph -> HscEnv -> HscEnv
setHUG deps hsc_env =
hscUpdateHUG (const $ deps) hsc_env
+data AnyDiagnostic where
+ AnyDiagnostic :: forall b . (DiagnosticOpts b ~ DiagnosticOpts GhcMessage, Diagnostic b) => b -> AnyDiagnostic
+
+instance Diagnostic AnyDiagnostic where
+ type DiagnosticOpts AnyDiagnostic = DiagnosticOpts GhcMessage
+ defaultDiagnosticOpts = defaultDiagnosticOpts @GhcMessage
+ diagnosticMessage opts (AnyDiagnostic b) = diagnosticMessage opts b
+ diagnosticReason (AnyDiagnostic b) = diagnosticReason b
+ diagnosticHints (AnyDiagnostic b) = diagnosticHints b
+ diagnosticCode (AnyDiagnostic b) = diagnosticCode b
+
+
+
+
-- | Wrap an action to catch and handle exceptions.
-wrapAction :: HscEnv -> IO a -> IO (Maybe a)
-wrapAction hsc_env k = do
+wrapAction :: (GhcMessage -> AnyDiagnostic) -> HscEnv -> IO a -> IO (Maybe a)
+wrapAction msg_wrapper hsc_env k = do
let lcl_logger = hsc_logger hsc_env
lcl_dynflags = hsc_dflags hsc_env
print_config = initPrintConfig lcl_dynflags
- let logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (srcErrorMessages err)
+ let logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (msg_wrapper <$> 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
@@ -2490,9 +2509,10 @@ executeInstantiationNode k n deps uid iu = do
-- Output of the logger is mediated by a central worker to
-- avoid output interleaving
msg <- asks env_messager
+ wrapper <- asks diag_wrapper
lift $ MaybeT $ withLoggerHsc k env $ \hsc_env ->
let lcl_hsc_env = setHUG deps hsc_env
- in wrapAction lcl_hsc_env $ do
+ in wrapAction wrapper lcl_hsc_env $ do
res <- upsweep_inst lcl_hsc_env msg k n uid iu
cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env)
return res
@@ -2518,7 +2538,7 @@ executeCompileNode k n !old_hmi hug mrehydrate_mods mod = do
hydrated_hsc_env
-- Compile the module, locking with a semaphore to avoid too many modules
-- being compiled at the same time leading to high memory usage.
- wrapAction lcl_hsc_env $ do
+ wrapAction diag_wrapper lcl_hsc_env $ do
res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n
cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags
return res)
@@ -2849,23 +2869,24 @@ label_self thread_name = do
CC.labelThread self_tid thread_name
-runPipelines :: WorkerLimit -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
+runPipelines :: WorkerLimit -> HscEnv -> (GhcMessage -> AnyDiagnostic) -> Maybe Messager -> [MakeAction] -> IO ()
-- Don't even initialise plugins if there are no pipelines
-runPipelines _ _ _ [] = return ()
-runPipelines n_job orig_hsc_env mHscMessager all_pipelines = do
+runPipelines _ _ _ _ [] = return ()
+runPipelines n_job orig_hsc_env diag_wrapper mHscMessager all_pipelines = do
liftIO $ label_self "main --make thread"
plugins_hsc_env <- initializePlugins orig_hsc_env
case n_job of
- NumProcessorsLimit n | n <= 1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines
- _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines
+ NumProcessorsLimit n | n <= 1 -> runSeqPipelines plugins_hsc_env diag_wrapper mHscMessager all_pipelines
+ _n -> runParPipelines n_job plugins_hsc_env diag_wrapper mHscMessager all_pipelines
-runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
-runSeqPipelines plugin_hsc_env mHscMessager all_pipelines =
+runSeqPipelines :: HscEnv -> (GhcMessage -> AnyDiagnostic) -> Maybe Messager -> [MakeAction] -> IO ()
+runSeqPipelines plugin_hsc_env diag_wrapper mHscMessager all_pipelines =
let env = MakeEnv { hsc_env = plugin_hsc_env
, withLogger = \_ k -> k id
, compile_sem = AbstractSem (return ()) (return ())
, env_messager = mHscMessager
+ , diag_wrapper = diag_wrapper
}
in runAllPipelines (NumProcessorsLimit 1) env all_pipelines
@@ -2895,10 +2916,11 @@ runWorkerLimit worker_limit action = case worker_limit of
-- | Build and run a pipeline
runParPipelines :: WorkerLimit -- ^ How to limit work parallelism
-> HscEnv -- ^ The basic HscEnv which is augmented with specific info for each module
+ -> (GhcMessage -> AnyDiagnostic)
-> Maybe Messager -- ^ Optional custom messager to use to report progress
-> [MakeAction] -- ^ The build plan for all the module nodes
-> IO ()
-runParPipelines worker_limit plugin_hsc_env mHscMessager all_pipelines = do
+runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipelines = do
-- A variable which we write to when an error has happened and we have to tell the
@@ -2920,6 +2942,7 @@ runParPipelines worker_limit plugin_hsc_env mHscMessager all_pipelines = do
, withLogger = withParLog log_queue_queue_var
, compile_sem = abstract_sem
, env_messager = mHscMessager
+ , diag_wrapper = diag_wrapper
}
-- Reset the number of capabilities once the upsweep ends.
runAllPipelines worker_limit env all_pipelines
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -21,6 +21,10 @@ module GHC.Tc.Errors.Ppr
, inHsDocContext
, TcRnMessageOpts(..)
, pprTyThingUsedWrong
+
+ -- | Useful when overriding message printing.
+ , messageWithInfoDiagnosticMessage
+ , messageWithHsDocContext
)
where
@@ -127,12 +131,8 @@ instance Diagnostic TcRnMessage where
(tcOptsShowContext opts)
(diagnosticMessage opts msg)
TcRnWithHsDocContext ctxt msg
- -> if tcOptsShowContext opts
- then main_msg `unionDecoratedSDoc` ctxt_msg
- else main_msg
- where
- main_msg = diagnosticMessage opts msg
- ctxt_msg = mkSimpleDecorated (inHsDocContext ctxt)
+ -> messageWithHsDocContext opts ctxt (diagnosticMessage opts msg)
+
TcRnSolverReport msg _ _
-> mkSimpleDecorated $ pprSolverReportWithCtxt msg
TcRnRedundantConstraints redundants (info, show_info)
@@ -3130,6 +3130,14 @@ messageWithInfoDiagnosticMessage unit_state ErrInfo{..} show_ctxt important =
in (mapDecoratedSDoc (pprWithUnitState unit_state) important) `unionDecoratedSDoc`
mkDecorated err_info'
+messageWithHsDocContext :: TcRnMessageOpts -> HsDocContext -> DecoratedSDoc -> DecoratedSDoc
+messageWithHsDocContext opts ctxt main_msg = do
+ if tcOptsShowContext opts
+ then main_msg `unionDecoratedSDoc` ctxt_msg
+ else main_msg
+ where
+ ctxt_msg = mkSimpleDecorated (inHsDocContext ctxt)
+
dodgy_msg :: Outputable ie => SDoc -> GlobalRdrElt -> ie -> SDoc
dodgy_msg kind tc ie
= vcat [ text "The" <+> kind <+> text "item" <+> quotes (ppr ie) <+> text "suggests that"
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -52,7 +52,7 @@ import GHC.Driver.Session as DynFlags
import GHC.Driver.Ppr hiding (printForUser)
import GHC.Utils.Error hiding (traceCmd)
import GHC.Driver.Monad ( modifySession )
-import GHC.Driver.Make ( newIfaceCache, ModIfaceCache(..) )
+import GHC.Driver.Make ( newIfaceCache, ModIfaceCache(..), AnyDiagnostic(..) )
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Driver.Config.Diagnostic
import qualified GHC
@@ -2176,7 +2176,7 @@ doLoad retain_context howmuch = do
liftIO $ do hSetBuffering stdout NoBuffering
hSetBuffering stderr NoBuffering) $ \_ -> do
hmis <- ifaceCache <$> getGHCiState
- ok <- trySuccess $ GHC.loadWithCache (Just hmis) howmuch
+ ok <- trySuccess $ GHC.loadWithCache (Just hmis) (AnyDiagnostic . GHCiMessage) howmuch
afterLoad ok retain_context
return ok
=====================================
ghc/GHCi/UI/Exception.hs
=====================================
@@ -1,7 +1,7 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-module GHCi.UI.Exception(printGhciException) where
+module GHCi.UI.Exception(printGhciException, GHCiMessage(..)) where
import GHC.Prelude
import GHC.Utils.Logger
@@ -49,16 +49,31 @@ instance Diagnostic GHCiMessage where
ghciDiagnosticMessage :: GhcMessageOpts -> GhcMessage -> DecoratedSDoc
ghciDiagnosticMessage ghc_opts msg =
case msg of
- GhcTcRnMessage (TcRnInterfaceError err) ->
- case ghciInterfaceError err of
- Just sdoc -> mkSimpleDecorated sdoc
- Nothing -> diagnosticMessage ghc_opts msg
+ GhcTcRnMessage msg -> tcRnMessage (tcMessageOpts ghc_opts) msg
GhcDriverMessage (DriverInterfaceError err) ->
case ghciInterfaceError err of
Just sdoc -> mkSimpleDecorated sdoc
Nothing -> diagnosticMessage ghc_opts msg
- _ -> diagnosticMessage ghc_opts msg
+ GhcPsMessage {} -> diagnosticMessage ghc_opts msg
+ GhcDsMessage {} -> diagnosticMessage ghc_opts msg
+ GhcUnknownMessage {} -> diagnosticMessage ghc_opts msg
where
+ tcRnMessage tc_opts tc_msg =
+ case tc_msg of
+ TcRnInterfaceError err ->
+ case ghciInterfaceError err of
+ Just sdoc -> mkSimpleDecorated sdoc
+ Nothing -> diagnosticMessage ghc_opts msg
+ TcRnMessageWithInfo unit_state msg_with_info ->
+ case msg_with_info of
+ TcRnMessageDetailed err_info wrapped_msg
+ -> messageWithInfoDiagnosticMessage unit_state err_info
+ (tcOptsShowContext tc_opts)
+ (tcRnMessage tc_opts wrapped_msg)
+ TcRnWithHsDocContext ctxt wrapped_msg ->
+ messageWithHsDocContext tc_opts ctxt (tcRnMessage tc_opts wrapped_msg)
+ _ -> diagnosticMessage ghc_opts msg
+
opts = tcOptsIfaceOpts (tcMessageOpts ghc_opts)
ghciInterfaceError (Can'tFindInterface err looking_for) =
=====================================
testsuite/tests/package/T4806_interactive.script
=====================================
@@ -0,0 +1,3 @@
+:set -ignore-package containers
+
+:l T4806.hs
=====================================
testsuite/tests/package/T4806_interactive.stderr
=====================================
@@ -0,0 +1,6 @@
+
+T4806.hs:1:1: error: [GHC-87110]
+ Could not load module ‘Data.Map’.
+ It is a member of the package ‘containers-0.6.7’
+ which is ignored due to an -ignore-package flag
+ Use :set -v to see a list of the files searched for.
=====================================
testsuite/tests/package/all.T
=====================================
@@ -22,3 +22,4 @@ test('T4806', normalise_version('containers'), compile_fail, ['-ignore-package c
test('T4806a', normalise_version('deepseq', 'containers', 'template-haskell'), compile_fail, ['-ignore-package deepseq'])
test('T22884', normalise_version('text'), compile_fail, ['-hide-package text'])
test('T22884_interactive', normalise_version('text'), ghci_script, ['T22884_interactive.script'])
+test('T4806_interactive', [extra_files(['T4806.hs']), normalise_version('containers')], ghci_script, ['T4806_interactive.script'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c8d121c46fe63cdff2324d09b882978e0b815012
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c8d121c46fe63cdff2324d09b882978e0b815012
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230505/fe2189e9/attachment-0001.html>
More information about the ghc-commits
mailing list