diff options
Diffstat (limited to 'compiler/GHC/Tc/Utils')
| -rw-r--r-- | compiler/GHC/Tc/Utils/Backpack.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Utils/Monad.hs | 74 |
2 files changed, 43 insertions, 38 deletions
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index a1f802b254..a27c4de082 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -23,7 +23,6 @@ import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Types.Basic (TypeOrKind(..)) -import GHC.Types.Error ( DiagnosticMessage ) import GHC.Types.Fixity (defaultFixity) import GHC.Types.Fixity.Env import GHC.Types.TypeEnv @@ -372,7 +371,7 @@ checkUnit (VirtUnit indef) = do -- an @hsig@ file.) tcRnCheckUnit :: HscEnv -> Unit -> - IO (Messages DiagnosticMessage, Maybe ()) + IO (Messages TcRnMessage, Maybe ()) tcRnCheckUnit hsc_env uid = withTiming logger dflags (text "Check unit id" <+> ppr uid) @@ -393,7 +392,7 @@ tcRnCheckUnit hsc_env uid = -- | Top-level driver for signature merging (run after typechecking -- an @hsig@ file). tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface - -> IO (Messages DiagnosticMessage, Maybe TcGblEnv) + -> IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = withTiming logger dflags (text "Signature merging" <+> brackets (ppr this_mod)) @@ -931,7 +930,7 @@ mergeSignatures -- an @hsig@ file.) tcRnInstantiateSignature :: HscEnv -> Module -> RealSrcSpan -> - IO (Messages DiagnosticMessage, Maybe TcGblEnv) + IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnInstantiateSignature hsc_env this_mod real_loc = withTiming logger dflags (text "Signature instantiation"<+>brackets (ppr this_mod)) diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 5568e34b75..3243be77de 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -76,7 +76,7 @@ module GHC.Tc.Utils.Monad( tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage, -- * Shared error message stuff: renamer and typechecker - mkLongErrAt, mkDecoratedSDocAt, addLongErrAt, reportDiagnostic, reportDiagnostics, + mkLongErrAt, mkTcRnMessage, addLongErrAt, reportDiagnostic, reportDiagnostics, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, attemptM, tryTc, askNoErrs, discardErrs, tryTcDiscardingErrs, @@ -215,6 +215,7 @@ import qualified GHC.LanguageExtensions as LangExt import Data.IORef import Control.Monad +import GHC.Tc.Errors.Types import {-# SOURCE #-} GHC.Tc.Utils.Env ( tcInitTidyEnv ) import qualified Data.Map as Map @@ -234,7 +235,7 @@ initTc :: HscEnv -> Module -> RealSrcSpan -> TcM r - -> IO (Messages DiagnosticMessage, Maybe r) + -> IO (Messages TcRnMessage, Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already) @@ -243,7 +244,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this used_gre_var <- newIORef [] ; th_var <- newIORef False ; th_splice_var<- newIORef False ; - infer_var <- newIORef (True, emptyBag) ; + infer_var <- newIORef True ; + infer_reasons_var <- newIORef emptyMessages ; dfun_n_var <- newIORef emptyOccSet ; type_env_var <- case hsc_type_env_var hsc_env of { Just (_mod, te_var) -> return te_var ; @@ -341,7 +343,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_hpc = False, tcg_main = Nothing, tcg_self_boot = NoSelfBoot, - tcg_safeInfer = infer_var, + tcg_safe_infer = infer_var, + tcg_safe_infer_reasons = infer_reasons_var, tcg_dependent_files = dependent_files_var, tcg_tc_plugins = [], tcg_hf_plugins = [], @@ -362,7 +365,7 @@ initTcWithGbl :: HscEnv -> TcGblEnv -> RealSrcSpan -> TcM r - -> IO (Messages DiagnosticMessage, Maybe r) + -> IO (Messages TcRnMessage, Maybe r) initTcWithGbl hsc_env gbl_env loc do_this = do { lie_var <- newIORef emptyWC ; errs_var <- newIORef emptyMessages @@ -408,7 +411,7 @@ initTcWithGbl hsc_env gbl_env loc do_this ; return (msgs, final_res) } -initTcInteractive :: HscEnv -> TcM a -> IO (Messages DiagnosticMessage, Maybe a) +initTcInteractive :: HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a) -- Initialise the type checker monad for use in GHCi initTcInteractive hsc_env thing_inside = initTc hsc_env HsSrcFile False @@ -968,10 +971,10 @@ wrapLocMA_ fn (L loc a) = setSrcSpan (locA loc) (fn a) -- Reporting errors -getErrsVar :: TcRn (TcRef (Messages DiagnosticMessage)) +getErrsVar :: TcRn (TcRef (Messages TcRnMessage)) getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } -setErrsVar :: TcRef (Messages DiagnosticMessage) -> TcRn a -> TcRn a +setErrsVar :: TcRef (Messages TcRnMessage) -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) addErr :: SDoc -> TcRn () @@ -1001,7 +1004,7 @@ checkErr :: Bool -> SDoc -> TcRn () -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) -addMessages :: Messages DiagnosticMessage -> TcRn () +addMessages :: Messages TcRnMessage -> TcRn () addMessages msgs1 = do { errs_var <- getErrsVar ; msgs0 <- readTcRef errs_var ; @@ -1030,40 +1033,42 @@ discardWarnings thing_inside ************************************************************************ -} -mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DiagnosticMessage) +mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope TcRnMessage) mkLongErrAt loc msg extra = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; - dflags <- getDynFlags ; let msg' = pprWithUnitState unit_state msg in - return $ mkLongMsgEnvelope dflags ErrorWithoutFlag loc printer msg' extra } + return $ mkErrorMsgEnvelope loc printer + $ TcRnUnknownMessage + $ mkDecoratedError [msg', extra] } -mkDecoratedSDocAt :: DiagnosticReason - -> SrcSpan - -> SDoc +mkTcRnMessage :: DiagnosticReason + -> SrcSpan + -> SDoc -- ^ The important part of the message - -> SDoc + -> SDoc -- ^ The context of the message - -> SDoc + -> SDoc -- ^ Any supplementary information. - -> TcRn (MsgEnvelope DiagnosticMessage) -mkDecoratedSDocAt reason loc important context extra + -> TcRn (MsgEnvelope TcRnMessage) +mkTcRnMessage reason loc important context extra = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; dflags <- getDynFlags ; - let f = pprWithUnitState unit_state - errDoc = [important, context, extra] - errDoc' = DiagnosticMessage (mkDecorated $ map f errDoc) reason + let errDocs = map (pprWithUnitState unit_state) + [important, context, extra] in - return $ mkMsgEnvelope dflags loc printer errDoc' } + return $ mkMsgEnvelope dflags loc printer + $ TcRnUnknownMessage + $ mkDecoratedDiagnostic reason errDocs } addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn () addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportDiagnostic -reportDiagnostics :: [MsgEnvelope DiagnosticMessage] -> TcM () +reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM () reportDiagnostics = mapM_ reportDiagnostic -reportDiagnostic :: MsgEnvelope DiagnosticMessage -> TcRn () +reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn () reportDiagnostic msg = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelope msg) ; errs_var <- getErrsVar ; @@ -1241,7 +1246,7 @@ capture_constraints thing_inside ; lie <- readTcRef lie_var ; return (res, lie) } -capture_messages :: TcM r -> TcM (r, Messages DiagnosticMessage) +capture_messages :: TcM r -> TcM (r, Messages TcRnMessage) -- capture_messages simply captures and returns the -- errors arnd warnings generated by thing_inside -- Precondition: thing_inside must not throw an exception! @@ -1411,7 +1416,7 @@ foldAndRecoverM f acc (x:xs) = Just acc' -> foldAndRecoverM f acc' xs } ----------------------- -tryTc :: TcRn a -> TcRn (Maybe a, Messages DiagnosticMessage) +tryTc :: TcRn a -> TcRn (Maybe a, Messages TcRnMessage) -- (tryTc m) executes m, and returns -- Just r, if m succeeds (returning r) -- Nothing, if m fails @@ -1561,9 +1566,9 @@ add_diagnostic_at :: DiagnosticReason -> SrcSpan -> SDoc -> SDoc -> TcRn () add_diagnostic_at reason loc msg extra_info = do { printer <- getPrintUnqualified ; dflags <- getDynFlags ; - let { dia = mkLongMsgEnvelope dflags reason - loc printer - msg extra_info } ; + let { dia = mkMsgEnvelope dflags loc printer $ + TcRnUnknownMessage $ + mkDecoratedDiagnostic reason [msg, extra_info] } ; reportDiagnostic dia } @@ -1982,14 +1987,15 @@ addModFinalizersWithLclEnv mod_finalizers -- | Mark that safe inference has failed -- See Note [Safe Haskell Overlapping Instances Implementation] -- although this is used for more than just that failure case. -recordUnsafeInfer :: WarningMessages -> TcM () -recordUnsafeInfer warns = - getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns) +recordUnsafeInfer :: Messages TcRnMessage -> TcM () +recordUnsafeInfer msgs = + getGblEnv >>= \env -> do writeTcRef (tcg_safe_infer env) False + writeTcRef (tcg_safe_infer_reasons env) msgs -- | Figure out the final correct safe haskell mode finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode finalSafeMode dflags tcg_env = do - safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env) + safeInf <- readIORef (tcg_safe_infer tcg_env) return $ case safeHaskell dflags of Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred | otherwise -> Sf_None |