diff options
Diffstat (limited to 'compiler/GHC/HsToCore/Monad.hs')
| -rw-r--r-- | compiler/GHC/HsToCore/Monad.hs | 30 |
1 files changed, 20 insertions, 10 deletions
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 788f4828e2..9bc893f814 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -64,6 +64,7 @@ import GHC.Driver.Ppr import GHC.Hs import GHC.HsToCore.Types +import GHC.HsToCore.Errors.Types import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas) import GHC.Core.FamInstEnv @@ -204,17 +205,22 @@ type DsWarning = (SrcSpan, SDoc) -- into a Doc. -- | Run a 'DsM' action inside the 'TcM' monad. -initDsTc :: DsM a -> TcM a +initDsTc :: DsM a -> TcM (Messages DsMessage, Maybe a) initDsTc thing_inside = do { tcg_env <- getGblEnv - ; msg_var <- getErrsVar + ; msg_var <- liftIO $ newIORef emptyMessages ; hsc_env <- getTopEnv ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env - ; setEnvs envs thing_inside + ; e_result <- tryM $ -- need to tryM so that we don't discard + -- DsMessages + setEnvs envs thing_inside + ; msgs <- liftIO $ readIORef msg_var + ; return (msgs, case e_result of Left _ -> Nothing + Right x -> Just x) } -- | Run a 'DsM' action inside the 'IO' monad. -initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DiagnosticMessage, Maybe a) +initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DsMessage, Maybe a) initDs hsc_env tcg_env thing_inside = do { msg_var <- newIORef emptyMessages ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env @@ -223,7 +229,7 @@ initDs hsc_env tcg_env thing_inside -- | Build a set of desugarer environments derived from a 'TcGblEnv'. mkDsEnvsFromTcGbl :: MonadIO m - => HscEnv -> IORef (Messages DiagnosticMessage) -> TcGblEnv + => HscEnv -> IORef (Messages DsMessage) -> TcGblEnv -> m (DsGblEnv, DsLclEnv) mkDsEnvsFromTcGbl hsc_env msg_var tcg_env = do { cc_st_var <- liftIO $ newIORef newCostCentreState @@ -242,7 +248,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env msg_var cc_st_var next_wrapper_num_var complete_matches } -runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DiagnosticMessage, Maybe a) +runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DsMessage, Maybe a) runDs hsc_env (ds_gbl, ds_lcl) thing_inside = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl (tryM thing_inside) @@ -255,7 +261,7 @@ runDs hsc_env (ds_gbl, ds_lcl) thing_inside } -- | Run a 'DsM' action in the context of an existing 'ModGuts' -initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DiagnosticMessage, Maybe a) +initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DsMessage, Maybe a) initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds , mg_tcs = tycons, mg_fam_insts = fam_insts , mg_patsyns = patsyns, mg_rdr_env = rdr_env @@ -316,7 +322,7 @@ initTcDsForSolver thing_inside Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) } mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv - -> IORef (Messages DiagnosticMessage) -> IORef CostCentreState + -> IORef (Messages DsMessage) -> IORef CostCentreState -> IORef (ModuleEnv Int) -> CompleteMatches -> (DsGblEnv, DsLclEnv) mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var @@ -466,7 +472,9 @@ diagnosticDs reason warn = do { env <- getGblEnv ; loc <- getSrcSpanDs ; dflags <- getDynFlags - ; let msg = mkShortMsgEnvelope dflags reason loc (ds_unqual env) warn + ; let msg = mkMsgEnvelope dflags loc (ds_unqual env) $ + DsUnknownMessage $ + mkPlainDiagnostic reason warn ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } -- | Emit a warning only if the correct WarningWithoutFlag is set in the DynFlags @@ -479,7 +487,9 @@ errDs :: SDoc -> DsM () errDs err = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; let msg = mkShortErrorMsgEnvelope loc (ds_unqual env) err + ; let msg = mkErrorMsgEnvelope loc (ds_unqual env) $ + DsUnknownMessage $ + mkPlainError err ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } -- | Issue an error, but return the expression for (), so that we can continue |