diff options
| author | Alfredo Di Napoli <alfredo@well-typed.com> | 2021-01-06 08:12:04 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-02-01 14:06:11 -0500 |
| commit | ddc2a7595a28b6098b6aab61bc830f2296affcdc (patch) | |
| tree | 2863cb09e18f9d2cba1ff8a4f78b6a2f6431837f | |
| parent | 5464845a012bf174cfafe03aaeb2e47150e7efb5 (diff) | |
| download | haskell-ddc2a7595a28b6098b6aab61bc830f2296affcdc.tar.gz | |
Remove ErrDoc and MsgDoc
This commit boldly removes the ErrDoc and the MsgDoc from the codebase.
The former was introduced with the only purpose of classifying errors
according to their importance, but a similar result can be obtained just
by having a simple [SDoc], and placing bullets after each of them.
On top of that I have taken the perhaps controversial decision to also
banish MsgDoc, as it was merely a type alias over an SDoc and as such it wasn't
offering any extra type safety. Granted, it was perhaps making type
signatures slightly more "focused", but at the expense of cognitive
burden: if it's really just an SDoc, let's call it with its proper name.
37 files changed, 272 insertions, 297 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index c3524c7776..15257be0d1 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -1474,7 +1474,7 @@ getNameToInstancesIndex :: GhcMonad m -- if it is visible from at least one module in the list. -> Maybe [Module] -- ^ modules to load. If this is not specified, we load -- modules for everything that is in scope unqualified. - -> m (Messages ErrDoc, Maybe (NameEnv ([ClsInst], [FamInst]))) + -> m (Messages [SDoc], Maybe (NameEnv ([ClsInst], [FamInst]))) getNameToInstancesIndex visible_mods mods_to_load = do hsc_env <- getSession liftIO $ runTcInteractive hsc_env $ diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs index 24e1d84107..0a5b306705 100644 --- a/compiler/GHC/Core/InstEnv.hs +++ b/compiler/GHC/Core/InstEnv.hs @@ -53,7 +53,6 @@ import Data.Maybe ( isJust, isNothing ) import GHC.Utils.Misc import GHC.Utils.Outputable -import GHC.Utils.Error import GHC.Utils.Panic {- @@ -810,7 +809,7 @@ anyone noticing, so it's manifestly not ruining anyone's day.) -- yield 'Left errorMessage'. lookupUniqueInstEnv :: InstEnvs -> Class -> [Type] - -> Either MsgDoc (ClsInst, [Type]) + -> Either SDoc (ClsInst, [Type]) lookupUniqueInstEnv instEnv cls tys = case lookupInstEnv False instEnv cls tys of ([(inst, inst_tys)], _, _) diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 14ebb47b1e..0746b54811 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -541,7 +541,7 @@ lintUnfolding :: Bool -- True <=> is a compulsory unfolding -> SrcLoc -> VarSet -- Treat these as in scope -> CoreExpr - -> Maybe (Bag MsgDoc) -- Nothing => OK + -> Maybe (Bag SDoc) -- Nothing => OK lintUnfolding is_compulsory dflags locn var_set expr | isEmptyBag errs = Nothing @@ -559,7 +559,7 @@ lintUnfolding is_compulsory dflags locn var_set expr lintExpr :: DynFlags -> [Var] -- Treat these as in scope -> CoreExpr - -> Maybe (Bag MsgDoc) -- Nothing => OK + -> Maybe (Bag SDoc) -- Nothing => OK lintExpr dflags vars expr | isEmptyBag errs = Nothing @@ -2551,7 +2551,7 @@ newtype LintM a = (Maybe a, WarnsAndErrs) } -- Result and messages (if any) deriving (Functor) -type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) +type WarnsAndErrs = (Bag SDoc, Bag SDoc) {- Note [Checking for global Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2710,31 +2710,31 @@ noLPChecks thing_inside getLintFlags :: LintM LintFlags getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs) -checkL :: Bool -> MsgDoc -> LintM () +checkL :: Bool -> SDoc -> LintM () checkL True _ = return () checkL False msg = failWithL msg -- like checkL, but relevant to type checking -lintL :: Bool -> MsgDoc -> LintM () +lintL :: Bool -> SDoc -> LintM () lintL = checkL -checkWarnL :: Bool -> MsgDoc -> LintM () +checkWarnL :: Bool -> SDoc -> LintM () checkWarnL True _ = return () checkWarnL False msg = addWarnL msg -failWithL :: MsgDoc -> LintM a +failWithL :: SDoc -> LintM a failWithL msg = LintM $ \ env (warns,errs) -> (Nothing, (warns, addMsg True env errs msg)) -addErrL :: MsgDoc -> LintM () +addErrL :: SDoc -> LintM () addErrL msg = LintM $ \ env (warns,errs) -> (Just (), (warns, addMsg True env errs msg)) -addWarnL :: MsgDoc -> LintM () +addWarnL :: SDoc -> LintM () addWarnL msg = LintM $ \ env (warns,errs) -> (Just (), (addMsg False env warns msg, errs)) -addMsg :: Bool -> LintEnv -> Bag MsgDoc -> MsgDoc -> Bag MsgDoc +addMsg :: Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc addMsg is_error env msgs msg = ASSERT2( notNull loc_msgs, msg ) msgs `snocBag` mk_msg msg @@ -2862,7 +2862,7 @@ varCallSiteUsage id = Nothing -> unitUE id One Just id_ue -> id_ue -ensureEqTys :: LintedType -> LintedType -> MsgDoc -> LintM () +ensureEqTys :: LintedType -> LintedType -> SDoc -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage -- annotations need only be consistent, not equal) -- Assumes ty1,ty2 are have already had the substitution applied @@ -2996,36 +2996,36 @@ pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] ------------------------------------------------------ -- Messages for case expressions -mkDefaultArgsMsg :: [Var] -> MsgDoc +mkDefaultArgsMsg :: [Var] -> SDoc mkDefaultArgsMsg args = hang (text "DEFAULT case with binders") 4 (ppr args) -mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc +mkCaseAltMsg :: CoreExpr -> Type -> Type -> SDoc mkCaseAltMsg e ty1 ty2 = hang (text "Type of case alternatives not the same as the annotation on case:") 4 (vcat [ text "Actual type:" <+> ppr ty1, text "Annotation on case:" <+> ppr ty2, text "Alt Rhs:" <+> ppr e ]) -mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> MsgDoc +mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> SDoc mkScrutMsg var var_ty scrut_ty subst = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, text "Result binder type:" <+> ppr var_ty,--(idType var), text "Scrutinee type:" <+> ppr scrut_ty, hsep [text "Current TCv subst", ppr subst]] -mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc +mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> SDoc mkNonDefltMsg e = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e) mkNonIncreasingAltsMsg e = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) -nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc +nonExhaustiveAltsMsg :: CoreExpr -> SDoc nonExhaustiveAltsMsg e = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) -mkBadConMsg :: TyCon -> DataCon -> MsgDoc +mkBadConMsg :: TyCon -> DataCon -> SDoc mkBadConMsg tycon datacon = vcat [ text "In a case alternative, data constructor isn't in scrutinee type:", @@ -3033,7 +3033,7 @@ mkBadConMsg tycon datacon text "Data con:" <+> ppr datacon ] -mkBadPatMsg :: Type -> Type -> MsgDoc +mkBadPatMsg :: Type -> Type -> SDoc mkBadPatMsg con_result_ty scrut_ty = vcat [ text "In a case alternative, pattern result type doesn't match scrutinee type:", @@ -3041,17 +3041,17 @@ mkBadPatMsg con_result_ty scrut_ty text "Scrutinee type:" <+> ppr scrut_ty ] -integerScrutinisedMsg :: MsgDoc +integerScrutinisedMsg :: SDoc integerScrutinisedMsg = text "In a LitAlt, the literal is lifted (probably Integer)" -mkBadAltMsg :: Type -> CoreAlt -> MsgDoc +mkBadAltMsg :: Type -> CoreAlt -> SDoc mkBadAltMsg scrut_ty alt = vcat [ text "Data alternative when scrutinee is not a tycon application", text "Scrutinee type:" <+> ppr scrut_ty, text "Alternative:" <+> pprCoreAlt alt ] -mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc +mkNewTyDataConAltMsg :: Type -> CoreAlt -> SDoc mkNewTyDataConAltMsg scrut_ty alt = vcat [ text "Data alternative for newtype datacon", text "Scrutinee type:" <+> ppr scrut_ty, @@ -3061,21 +3061,21 @@ mkNewTyDataConAltMsg scrut_ty alt ------------------------------------------------------ -- Other error messages -mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc +mkAppMsg :: Type -> Type -> CoreExpr -> SDoc mkAppMsg fun_ty arg_ty arg = vcat [text "Argument value doesn't match argument type:", hang (text "Fun type:") 4 (ppr fun_ty), hang (text "Arg type:") 4 (ppr arg_ty), hang (text "Arg:") 4 (ppr arg)] -mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc +mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc mkNonFunAppMsg fun_ty arg_ty arg = vcat [text "Non-function type in function position", hang (text "Fun type:") 4 (ppr fun_ty), hang (text "Arg type:") 4 (ppr arg_ty), hang (text "Arg:") 4 (ppr arg)] -mkLetErr :: TyVar -> CoreExpr -> MsgDoc +mkLetErr :: TyVar -> CoreExpr -> SDoc mkLetErr bndr rhs = vcat [text "Bad `let' binding:", hang (text "Variable:") @@ -3083,7 +3083,7 @@ mkLetErr bndr rhs hang (text "Rhs:") 4 (ppr rhs)] -mkTyAppMsg :: Type -> Type -> MsgDoc +mkTyAppMsg :: Type -> Type -> SDoc mkTyAppMsg ty arg_ty = vcat [text "Illegal type application:", hang (text "Exp type:") @@ -3091,10 +3091,10 @@ mkTyAppMsg ty arg_ty hang (text "Arg type:") 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -emptyRec :: CoreExpr -> MsgDoc +emptyRec :: CoreExpr -> SDoc emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e) -mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc +mkRhsMsg :: Id -> SDoc -> Type -> SDoc mkRhsMsg binder what ty = vcat [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon, @@ -3102,29 +3102,29 @@ mkRhsMsg binder what ty hsep [text "Binder's type:", ppr (idType binder)], hsep [text "Rhs type:", ppr ty]] -mkLetAppMsg :: CoreExpr -> MsgDoc +mkLetAppMsg :: CoreExpr -> SDoc mkLetAppMsg e = hang (text "This argument does not satisfy the let/app invariant:") 2 (ppr e) -badBndrTyMsg :: Id -> SDoc -> MsgDoc +badBndrTyMsg :: Id -> SDoc -> SDoc badBndrTyMsg binder what = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder , text "Binder's type:" <+> ppr (idType binder) ] -mkNonTopExportedMsg :: Id -> MsgDoc +mkNonTopExportedMsg :: Id -> SDoc mkNonTopExportedMsg binder = hsep [text "Non-top-level binder is marked as exported:", ppr binder] -mkNonTopExternalNameMsg :: Id -> MsgDoc +mkNonTopExternalNameMsg :: Id -> SDoc mkNonTopExternalNameMsg binder = hsep [text "Non-top-level binder has an external name:", ppr binder] -mkTopNonLitStrMsg :: Id -> MsgDoc +mkTopNonLitStrMsg :: Id -> SDoc mkTopNonLitStrMsg binder = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] -mkKindErrMsg :: TyVar -> Type -> MsgDoc +mkKindErrMsg :: TyVar -> Type -> SDoc mkKindErrMsg tyvar arg_ty = vcat [text "Kinds don't match in type application:", hang (text "Type variable:") @@ -3132,10 +3132,10 @@ mkKindErrMsg tyvar arg_ty hang (text "Arg type:") 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc +mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> SDoc mkCastErr expr = mk_cast_err "expression" "type" (ppr expr) -mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> MsgDoc +mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> SDoc mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty) mk_cast_err :: String -- ^ What sort of casted thing this is @@ -3143,7 +3143,7 @@ mk_cast_err :: String -- ^ What sort of casted thing this is -> String -- ^ What sort of coercion is being used -- (\"type\" or \"kind\"). -> SDoc -- ^ The thing being casted. - -> Coercion -> Type -> Type -> MsgDoc + -> Coercion -> Type -> Type -> SDoc mk_cast_err thing_str co_str pp_thing co from_ty thing_ty = vcat [from_msg <+> text "of Cast differs from" <+> co_msg <+> text "of" <+> enclosed_msg, @@ -3234,16 +3234,16 @@ mkBadJoinPointRuleMsg bndr join_arity rule , text "Join arity:" <+> ppr join_arity , text "Rule:" <+> ppr rule ] -pprLeftOrRight :: LeftOrRight -> MsgDoc +pprLeftOrRight :: LeftOrRight -> SDoc pprLeftOrRight CLeft = text "left" pprLeftOrRight CRight = text "right" -dupVars :: [NonEmpty Var] -> MsgDoc +dupVars :: [NonEmpty Var] -> SDoc dupVars vars = hang (text "Duplicate variables brought into scope") 2 (ppr (map toList vars)) -dupExtVars :: [NonEmpty Name] -> MsgDoc +dupExtVars :: [NonEmpty Name] -> SDoc dupExtVars vars = hang (text "Duplicate top-level variables with the same qualified name") 2 (ppr (map toList vars)) diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 889d808b41..25a405a383 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -321,7 +321,7 @@ handleWarningsThrowErrors (warnings, errors) = do -- 2. If there are no error messages, but the second result indicates failure -- there should be warnings in the first result. That is, if the action -- failed, it must have been due to the warnings (i.e., @-Werror@). -ioMsgMaybe :: IO (Messages ErrDoc, Maybe a) -> Hsc a +ioMsgMaybe :: IO (Messages [SDoc], Maybe a) -> Hsc a ioMsgMaybe ioA = do (msgs, mb_r) <- liftIO ioA let (warns, errs) = partitionMessages msgs @@ -332,7 +332,7 @@ ioMsgMaybe ioA = do -- | like ioMsgMaybe, except that we ignore error messages and return -- 'Nothing' instead. -ioMsgMaybe' :: IO (Messages ErrDoc, Maybe a) -> Hsc (Maybe a) +ioMsgMaybe' :: IO (Messages [SDoc], Maybe a) -> Hsc (Maybe a) ioMsgMaybe' ioA = do (msgs, mb_r) <- liftIO $ ioA logWarnings (getWarningMessages msgs) @@ -1134,7 +1134,7 @@ hscCheckSafeImports tcg_env = do warns rules = listToBag $ map warnRules rules - warnRules :: GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg ErrDoc + warnRules :: GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg [SDoc] warnRules (L loc (HsRule { rd_name = n })) = mkPlainWarnMsg loc $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index a6be00188d..b009c6829a 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -982,7 +982,7 @@ checkStability hpt sccs all_home_mods = -- | Each module is given a unique 'LogQueue' to redirect compilation messages -- to. A 'Nothing' value contains the result of compilation, and denotes the -- end of the message queue. -data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, MsgDoc)]) +data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]) !(MVar ()) -- | The graph of modules to compile and their corresponding result 'MVar' and @@ -1236,7 +1236,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do return (success_flag,ok_results) where - writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,MsgDoc) -> IO () + writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,SDoc) -> IO () writeLogQueue (LogQueue ref sem) msg = do atomicModifyIORef' ref $ \msgs -> (msg:msgs,()) _ <- tryPutMVar sem () @@ -2886,7 +2886,7 @@ withDeferredDiagnostics f = do (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics) (\_ -> f) -noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> ErrMsg ErrDoc +noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> ErrMsg [SDoc] -- ToDo: we don't have a proper line number for this error noModError hsc_env loc wanted_mod err = mkPlainErrMsg loc $ cannotFindModule hsc_env wanted_mod err diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index c63301fd71..85f1b71852 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -645,7 +645,7 @@ data DynFlags = DynFlags { ghciHistSize :: Int, - -- | MsgDoc output action: use "GHC.Utils.Error" instead of this if you can + -- | SDoc output action: use "GHC.Utils.Error" instead of this if you can log_action :: LogAction, dump_action :: DumpAction, trace_action :: TraceAction, @@ -1334,7 +1334,7 @@ type LogAction = DynFlags -> WarnReason -> Severity -> SrcSpan - -> MsgDoc + -> SDoc -> IO () defaultFatalMessager :: FatalMessager @@ -1980,7 +1980,7 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do return (dflags4, leftover, warns' ++ warns) -- | Write an error or warning to the 'LogOutput'. -putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO () +putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO () putLogMsg dflags = log_action dflags dflags -- | Check (and potentially disable) any extensions that aren't allowed diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 3622d9f8af..8f47cc1208 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -100,7 +100,7 @@ import GHC.Driver.Plugins ( LoadedPlugin(..) ) -} -- | Main entry point to the desugarer. -deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages ErrDoc, Maybe ModGuts) +deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages [SDoc], Maybe ModGuts) -- Can modify PCS by faulting in more declarations deSugar hsc_env @@ -283,7 +283,7 @@ So we pull out the type/coercion variables (which are in dependency order), and Rec the rest. -} -deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages ErrDoc, Maybe CoreExpr) +deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages [SDoc], Maybe CoreExpr) deSugarExpr hsc_env tc_expr = do { let dflags = hsc_dflags hsc_env diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 6e832ae6f6..a4b4e325dd 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -213,7 +213,7 @@ initDsTc thing_inside } -- | Run a 'DsM' action inside the 'IO' monad. -initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages ErrDoc, Maybe a) +initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages [SDoc], Maybe a) initDs hsc_env tcg_env thing_inside = do { msg_var <- newIORef emptyMessages ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env @@ -222,7 +222,7 @@ initDs hsc_env tcg_env thing_inside -- | Build a set of desugarer environments derived from a 'TcGblEnv'. mkDsEnvsFromTcGbl :: MonadIO m - => HscEnv -> IORef (Messages ErrDoc) -> TcGblEnv + => HscEnv -> IORef (Messages [SDoc]) -> TcGblEnv -> m (DsGblEnv, DsLclEnv) mkDsEnvsFromTcGbl hsc_env msg_var tcg_env = do { cc_st_var <- liftIO $ newIORef newCostCentreState @@ -239,7 +239,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env msg_var cc_st_var complete_matches } -runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages ErrDoc, Maybe a) +runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages [SDoc], Maybe a) runDs hsc_env (ds_gbl, ds_lcl) thing_inside = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl (tryM thing_inside) @@ -252,7 +252,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 ErrDoc, Maybe a) +initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages [SDoc], 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 @@ -278,7 +278,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds ; runDs hsc_env envs thing_inside } -initTcDsForSolver :: TcM a -> DsM (Messages ErrDoc, Maybe a) +initTcDsForSolver :: TcM a -> DsM (Messages [SDoc], Maybe a) -- Spin up a TcM context so that we can run the constraint solver -- Returns any error messages generated by the constraint solver -- and (Just res) if no error happened; Nothing if an error happened @@ -309,7 +309,7 @@ initTcDsForSolver thing_inside thing_inside } mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv - -> IORef (Messages ErrDoc) -> IORef CostCentreState -> CompleteMatches + -> IORef (Messages [SDoc]) -> IORef CostCentreState -> CompleteMatches -> (DsGblEnv, DsLclEnv) mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var complete_matches diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs index 782b5faeee..c971f927cf 100644 --- a/compiler/GHC/HsToCore/Types.hs +++ b/compiler/GHC/HsToCore/Types.hs @@ -47,7 +47,7 @@ data DsGblEnv -- constructors are in scope during -- pattern-match satisfiability checking , ds_unqual :: PrintUnqualified - , ds_msgs :: IORef (Messages ErrDoc) -- Warning messages + , ds_msgs :: IORef (Messages [SDoc]) -- Warning messages , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, -- possibly-imported things , ds_complete_matches :: CompleteMatches diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 8e5bcf9f4b..01b4f4906f 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -140,7 +140,7 @@ where the code that e1 expands to might import some defns that also turn out to be needed by the code that e2 expands to. -} -tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing) +tcLookupImported_maybe :: Name -> TcM (MaybeErr SDoc TyThing) -- Returns (Failed err) if we can't find the interface file for the thing tcLookupImported_maybe name = do { hsc_env <- getTopEnv @@ -149,7 +149,7 @@ tcLookupImported_maybe name Just thing -> return (Succeeded thing) Nothing -> tcImportDecl_maybe name } -tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing) +tcImportDecl_maybe :: Name -> TcM (MaybeErr SDoc TyThing) -- Entry point for *source-code* uses of importDecl tcImportDecl_maybe name | Just thing <- wiredInNameTyThing_maybe name @@ -160,7 +160,7 @@ tcImportDecl_maybe name | otherwise = initIfaceTcRn (importDecl name) -importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing) +importDecl :: Name -> IfM lcl (MaybeErr SDoc TyThing) -- Get the TyThing for this Name from an interface file -- It's not a wired-in thing -- the caller caught that importDecl name @@ -302,7 +302,7 @@ loadSrcInterface_maybe :: SDoc -> ModuleName -> IsBootInterface -- {-# SOURCE #-} ? -> Maybe FastString -- "package", if any - -> RnM (MaybeErr MsgDoc ModIface) + -> RnM (MaybeErr SDoc ModIface) loadSrcInterface_maybe doc mod want_boot maybe_pkg -- We must first find which Module this import refers to. This involves @@ -408,7 +408,7 @@ loadInterfaceWithException doc mod_name where_from ------------------ loadInterface :: SDoc -> Module -> WhereFrom - -> IfM lcl (MaybeErr MsgDoc ModIface) + -> IfM lcl (MaybeErr SDoc ModIface) -- loadInterface looks in both the HPT and PIT for the required interface -- If not found, it loads it, and puts it in the PIT (always). @@ -663,7 +663,7 @@ is_external_sig home_unit iface = -- we are actually typechecking p.) computeInterface :: SDoc -> IsBootInterface -> Module - -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) + -> TcRnIf gbl lcl (MaybeErr SDoc (ModIface, FilePath)) computeInterface doc_str hi_boot_file mod0 = do MASSERT( not (isHoleModule mod0) ) hsc_env <- getTopEnv @@ -695,7 +695,7 @@ computeInterface doc_str hi_boot_file mod0 = do -- @p[A=\<A>,B=\<B>]:B@ never includes B. moduleFreeHolesPrecise :: SDoc -> Module - -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName)) + -> TcRnIf gbl lcl (MaybeErr SDoc (UniqDSet ModuleName)) moduleFreeHolesPrecise doc_str mod | moduleIsDefinite mod = return (Succeeded emptyUniqDSet) | otherwise = @@ -728,7 +728,7 @@ moduleFreeHolesPrecise doc_str mod Failed err -> return (Failed err) wantHiBootFile :: HomeUnit -> ExternalPackageState -> Module -> WhereFrom - -> MaybeErr MsgDoc IsBootInterface + -> MaybeErr SDoc IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot wantHiBootFile home_unit eps mod from = case from of @@ -816,7 +816,7 @@ findAndReadIface :: SDoc -> Module -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file - -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) + -> TcRnIf gbl lcl (MaybeErr SDoc (ModIface, FilePath)) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed @@ -926,7 +926,7 @@ writeIface dflags hi_file_path new_iface -- @readIface@ tries just the one file. readIface :: Module -> FilePath - -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface) + -> TcRnIf gbl lcl (MaybeErr SDoc ModIface) -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed @@ -1229,7 +1229,7 @@ badIfaceFile file err = vcat [text "Bad interface file:" <+> text file, nest 4 err] -hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc +hiModuleNameMismatchWarn :: Module -> Module -> SDoc hiModuleNameMismatchWarn requested_mod read_mod | moduleUnit requested_mod == moduleUnit read_mod = sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma, diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index a316af61db..96688f8d08 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -576,7 +576,7 @@ loadExpr hsc_env span root_ul_bco -- All wired-in names are in the base package, which we link -- by default, so we can safely ignore them here. -dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a +dieWith :: DynFlags -> SrcSpan -> SDoc -> IO a dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg))) diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 671453e4c1..e40087302f 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -24,25 +24,25 @@ import GHC.Hs.Type (pprLHsContext) import GHC.Builtin.Names (allNameStrings) import GHC.Builtin.Types (filterCTuple) -mkParserErr :: SrcSpan -> SDoc -> ErrMsg ErrDoc +mkParserErr :: SrcSpan -> SDoc -> ErrMsg [SDoc] mkParserErr span doc = ErrMsg { errMsgSpan = span , errMsgContext = alwaysQualify - , errMsgDiagnostic = ErrDoc [doc] [] [] + , errMsgDiagnostic = [doc] , errMsgSeverity = SevError , errMsgReason = NoReason } -mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> ErrMsg ErrDoc +mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> ErrMsg [SDoc] mkParserWarn flag span doc = ErrMsg { errMsgSpan = span , errMsgContext = alwaysQualify - , errMsgDiagnostic = ErrDoc [doc] [] [] + , errMsgDiagnostic = [doc] , errMsgSeverity = SevWarning , errMsgReason = Reason flag } -pprWarning :: PsWarning -> ErrMsg ErrDoc +pprWarning :: PsWarning -> ErrMsg [SDoc] pprWarning = \case PsWarnTab loc tc -> mkParserWarn Opt_WarnTabs loc $ @@ -128,7 +128,7 @@ pprWarning = \case OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix" OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix" -pprError :: PsError -> ErrMsg ErrDoc +pprError :: PsError -> ErrMsg [SDoc] pprError err = mkParserErr (errLoc err) $ vcat (pp_err (errDesc err) : map pp_hint (errHints err)) diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index 3b13e1d382..e4af48a15a 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -348,7 +348,7 @@ unsupportedExtnError dflags loc unsup = suggestions = fuzzyMatch unsup supported -optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages ErrDoc +optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages [SDoc] optionsErrorMsgs unhandled_flags flags_lines _filename = mkMessages $ listToBag (map mkMsg unhandled_flags_lines) where unhandled_flags_lines :: [Located String] diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index 435c20c16e..972e6706de 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -71,7 +71,7 @@ import GHC.Unit.Module.Warnings ( WarningTxt, pprWarningTxtForMsg ) import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon -import GHC.Utils.Error ( MsgDoc ) +import GHC.Utils.Error import GHC.Builtin.Names( rOOT_MAIN ) import GHC.Types.Basic ( TopLevelFlag(..), TupleSort(..) ) import GHC.Types.SrcLoc as SrcLoc @@ -279,7 +279,7 @@ lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn -- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. -- This never adds an error, but it may return one, see -- Note [Errors in lookup functions] -lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name) +lookupExactOcc_either :: Name -> RnM (Either SDoc Name) lookupExactOcc_either name | Just thing <- wiredInNameTyThing_maybe name , Just tycon <- case thing of @@ -326,7 +326,7 @@ lookupExactOcc_either name gres -> return (Left (sameNameErr gres)) -- Ugh! See Note [Template Haskell ambiguity] } -sameNameErr :: [GlobalRdrElt] -> MsgDoc +sameNameErr :: [GlobalRdrElt] -> SDoc sameNameErr [] = panic "addSameNameErr: empty list" sameNameErr gres@(_ : _) = hang (text "Same exact name in multiple name-spaces:") @@ -435,7 +435,7 @@ lookupExactOrOrig_maybe rdr_name res k NotExactOrOrig -> k } data ExactOrOrigResult = FoundExactOrOrig Name -- ^ Found an Exact Or Orig Name - | ExactOrOrigError MsgDoc -- ^ The RdrName was an Exact + | ExactOrOrigError SDoc -- ^ The RdrName was an Exact -- or Orig, but there was an -- error looking up the Name | NotExactOrOrig -- ^ The RdrName is neither an Exact nor @@ -753,7 +753,7 @@ lookupSubBndrOcc :: Bool -> Name -- Parent -> SDoc -> RdrName - -> RnM (Either MsgDoc Name) + -> RnM (Either SDoc Name) -- Find all the things the rdr-name maps to -- and pick the one with the right parent namep lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do @@ -1516,7 +1516,7 @@ lookupSigCtxtOccRn ctxt what lookupBindGroupOcc :: HsSigCtxt -> SDoc - -> RdrName -> RnM (Either MsgDoc Name) + -> RdrName -> RnM (Either SDoc Name) -- Looks up the RdrName, expecting it to resolve to one of the -- bound names passed in. If not, return an appropriate error message -- @@ -1587,7 +1587,7 @@ lookupBindGroupOcc ctxt what rdr_name <+> quotes (ppr rdr_name) <+> text "is declared" -- Identify all similar names and produce a message listing them - candidates :: [Name] -> MsgDoc + candidates :: [Name] -> SDoc candidates names_in_scope = case similar_names of [] -> Outputable.empty diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index 742b29ee71..32b213be45 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -50,7 +50,7 @@ import GHC.Types.Var.Set import GHC.Core.DataCon import GHC.Core ( AltCon(..) ) import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom ) -import GHC.Utils.Error ( MsgDoc, Severity(..), mkLocMessage ) +import GHC.Utils.Error ( Severity(..), mkLocMessage ) import GHC.Core.Type import GHC.Types.RepType import GHC.Types.SrcLoc @@ -242,8 +242,8 @@ newtype LintM a = LintM -> StgPprOpts -- Pretty-printing options -> [LintLocInfo] -- Locations -> IdSet -- Local vars in scope - -> Bag MsgDoc -- Error messages so far - -> (a, Bag MsgDoc) -- Result and error messages (if any) + -> Bag SDoc -- Error messages so far + -> (a, Bag SDoc) -- Result and error messages (if any) } deriving (Functor) @@ -273,7 +273,7 @@ pp_binders bs pp_binder b = hsep [ppr b, dcolon, ppr (idType b)] -initL :: Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe MsgDoc +initL :: Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc initL this_mod unarised opts locals (LintM m) = do let (_, errs) = m this_mod (LintFlags unarised) opts [] locals emptyBag if isEmptyBag errs then @@ -300,7 +300,7 @@ thenL_ m k = LintM $ \mod lf opts loc scope errs -> case unLintM m mod lf opts loc scope errs of (_, errs') -> unLintM k mod lf opts loc scope errs' -checkL :: Bool -> MsgDoc -> LintM () +checkL :: Bool -> SDoc -> LintM () checkL True _ = return () checkL False msg = addErrL msg @@ -342,10 +342,10 @@ checkPostUnariseId id = in is_sum <|> is_tuple <|> is_void -addErrL :: MsgDoc -> LintM () +addErrL :: SDoc -> LintM () addErrL msg = LintM $ \_mod _lf _opts loc _scope errs -> ((), addErr errs msg loc) -addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc +addErr :: Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc addErr errs_so_far msg locs = errs_so_far `snocBag` mk_msg locs where diff --git a/compiler/GHC/SysTools/Elf.hs b/compiler/GHC/SysTools/Elf.hs index ca563dfb52..197c30624f 100644 --- a/compiler/GHC/SysTools/Elf.hs +++ b/compiler/GHC/SysTools/Elf.hs @@ -23,7 +23,7 @@ import GHC.Platform import GHC.Utils.Error import GHC.Data.Maybe (MaybeT(..),runMaybeT) import GHC.Utils.Misc (charToC) -import GHC.Utils.Outputable (text,hcat,SDoc) +import GHC.Utils.Outputable (text,hcat) import Control.Monad (when) import Data.Binary.Get diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index 407cb6a21b..e3dec46f91 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -2219,10 +2219,10 @@ gndNonNewtypeErr :: SDoc gndNonNewtypeErr = text "GeneralizedNewtypeDeriving cannot be used on non-newtypes" -derivingNullaryErr :: MsgDoc +derivingNullaryErr :: SDoc derivingNullaryErr = text "Cannot derive instances for nullary classes" -derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc +derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> SDoc derivingKindErr tc cls cls_tys cls_kind enough_args = sep [ hang (text "Cannot derive well-kinded instance of form" <+> quotes (pprClassPred cls cls_tys @@ -2237,7 +2237,7 @@ derivingKindErr tc cls cls_tys cls_kind enough_args = text "(Perhaps you intended to use PolyKinds)" | otherwise = Outputable.empty -derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc +derivingViaKindErr :: Class -> Kind -> Type -> Kind -> SDoc derivingViaKindErr cls cls_kind via_ty via_kind = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) 2 (text "Class" <+> quotes (ppr cls) @@ -2246,26 +2246,26 @@ derivingViaKindErr cls cls_kind via_ty via_kind $+$ text "but" <+> quotes (pprType via_ty) <+> text "has kind" <+> quotes (pprKind via_kind)) -derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc +derivingEtaErr :: Class -> [Type] -> Type -> SDoc derivingEtaErr cls cls_tys inst_ty = sep [text "Cannot eta-reduce to an instance of form", nest 2 (text "instance (...) =>" <+> pprClassPred cls (cls_tys ++ [inst_ty]))] derivingThingErr :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc + -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc derivingThingErr newtype_deriving cls cls_args mb_strat why = derivingThingErr' newtype_deriving cls cls_args mb_strat (maybe empty derivStrategyName mb_strat) why -derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc +derivingThingErrM :: Bool -> SDoc -> DerivM SDoc derivingThingErrM newtype_deriving why = do DerivEnv { denv_cls = cls , denv_inst_tys = cls_args , denv_strat = mb_strat } <- ask pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why -derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc +derivingThingErrMechanism :: DerivSpecMechanism -> SDoc -> DerivM SDoc derivingThingErrMechanism mechanism why = do DerivEnv { denv_cls = cls , denv_inst_tys = cls_args @@ -2274,7 +2274,7 @@ derivingThingErrMechanism mechanism why (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why derivingThingErr' :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc + -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc -> SDoc derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why = sep [(hang (text "Can't make a derived instance of") 2 (quotes (ppr pred) <+> via_mechanism) diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs index d65564d1da..5ce54339c6 100644 --- a/compiler/GHC/Tc/Deriv/Infer.hs +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -700,7 +700,7 @@ simplifyInstanceContexts infer_specs where the_pred = mkClassPred clas inst_tys -derivInstCtxt :: PredType -> MsgDoc +derivInstCtxt :: PredType -> SDoc derivInstCtxt pred = text "When deriving the instance for" <+> parens (ppr pred) diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index fcd48c3d5c..43f6505d7b 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -750,7 +750,7 @@ mkUserTypeErrorReporter ctxt ; maybeReportError ctxt err ; addDeferredBinding ctxt err ct } -mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (ErrMsg ErrDoc) +mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (ErrMsg [SDoc]) mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct $ important $ pprUserTypeErrorTy @@ -826,7 +826,7 @@ pattern match which binds some equality constraints. If we find one, we report the insoluble Given. -} -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)) +mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc])) -- Make error message for a group -> Reporter -- Deal with lots of constraints -- Group together errors from same location, @@ -835,7 +835,7 @@ mkGroupReporter mk_err ctxt cts = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) -- Like mkGroupReporter, but doesn't actually print error messages -mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)) -> Reporter +mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc])) -> Reporter mkSuppressReporter mk_err ctxt cts = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) @@ -853,7 +853,7 @@ cmp_loc ct1 ct2 = get ct1 `compare` get ct2 -- Reduce duplication by reporting only one error from each -- /starting/ location even if the end location differs -reportGroup :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)) -> Reporter +reportGroup :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc])) -> Reporter reportGroup mk_err ctxt cts = ASSERT( not (null cts)) do { err <- mk_err ctxt cts @@ -872,13 +872,13 @@ reportGroup mk_err ctxt cts = -- like reportGroup, but does not actually report messages. It still adds -- -fdefer-type-errors bindings, though. -suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)) -> Reporter +suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc])) -> Reporter suppressGroup mk_err ctxt cts = do { err <- mk_err ctxt cts ; traceTc "Suppressing errors for" (ppr cts) ; mapM_ (addDeferredBinding ctxt err) cts } -maybeReportHoleError :: ReportErrCtxt -> Hole -> ErrMsg ErrDoc -> TcM () +maybeReportHoleError :: ReportErrCtxt -> Hole -> ErrMsg [SDoc] -> TcM () maybeReportHoleError ctxt hole err | isOutOfScopeHole hole -- Always report an error for out-of-scope variables @@ -920,7 +920,7 @@ maybeReportHoleError ctxt hole err HoleWarn -> reportWarning (Reason Opt_WarnTypedHoles) err HoleDefer -> return () -maybeReportError :: ReportErrCtxt -> ErrMsg ErrDoc -> TcM () +maybeReportError :: ReportErrCtxt -> ErrMsg [SDoc] -> TcM () -- Report the error and/or make a deferred binding for it maybeReportError ctxt err | cec_suppress ctxt -- Some worse error has occurred; @@ -932,7 +932,7 @@ maybeReportError ctxt err TypeWarn reason -> reportWarning reason err TypeError -> reportError err -addDeferredBinding :: ReportErrCtxt -> ErrMsg ErrDoc -> Ct -> TcM () +addDeferredBinding :: ReportErrCtxt -> ErrMsg [SDoc] -> Ct -> TcM () -- See Note [Deferring coercion errors to runtime] addDeferredBinding ctxt err ct | deferringAnyBindings ctxt @@ -955,14 +955,14 @@ addDeferredBinding ctxt err ct = return () mkErrorTerm :: DynFlags -> Type -- of the error term - -> ErrMsg ErrDoc -> EvTerm + -> ErrMsg [SDoc] -> EvTerm mkErrorTerm dflags ty err = evDelayedError ty err_fs where err_msg = pprLocErrMsg err err_fs = mkFastString $ showSDoc dflags $ err_msg $$ text "(deferred type error)" -maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg ErrDoc -> Hole -> TcM () +maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg [SDoc] -> Hole -> TcM () maybeAddDeferredHoleBinding ctxt err (Hole { hole_sort = ExprHole (HER ref ref_ty _) }) -- Only add bindings for holes in expressions -- not for holes in partial type signatures @@ -1048,15 +1048,15 @@ pprWithArising (ct:cts) ppr_one ct' = hang (parens (pprType (ctPred ct'))) 2 (pprCtLoc (ctLoc ct')) -mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM (ErrMsg ErrDoc) +mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM (ErrMsg [SDoc]) mkErrorMsgFromCt ctxt ct report = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report -mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM (ErrMsg ErrDoc) +mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM (ErrMsg [SDoc]) mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs) = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing) - (errDoc important [context] (relevant_bindings ++ valid_subs)) + [vcat important, context, vcat (relevant_bindings ++ valid_subs)] } type UserGiven = Implication @@ -1153,7 +1153,7 @@ solve it. ************************************************************************ -} -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc) +mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc]) mkIrredErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 ; let orig = ctOrigin ct1 @@ -1164,7 +1164,7 @@ mkIrredErr ctxt cts (ct1:_) = cts ---------------- -mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (ErrMsg ErrDoc) +mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (ErrMsg [SDoc]) mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ , hole_ty = hole_ty , hole_loc = ct_loc }) @@ -1175,9 +1175,9 @@ mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ ; curr_mod <- getModule ; hpt <- getHpt ; mkErrDocAt (RealSrcSpan (tcl_loc lcl_env) Nothing) $ - errDoc [out_of_scope_msg] [] - [unknownNameSuggestions dflags hpt curr_mod rdr_env - (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)] } + [out_of_scope_msg, + (unknownNameSuggestions dflags hpt curr_mod rdr_env + (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ))] } where herald | isDataOcc occ = text "Data constructor not in scope:" | otherwise = text "Variable not in scope:" @@ -1305,7 +1305,7 @@ givenConstraintsMsg ctxt = 2 (vcat $ map pprConstraint constraints) ---------------- -mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc) +mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc]) mkIPErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 ; let orig = ctOrigin ct1 @@ -1382,11 +1382,11 @@ any more. So we don't assert that it is. -- Don't have multiple equality errors from the same location -- E.g. (Int,Bool) ~ (Bool,Int) one error will do! -mkEqErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc) +mkEqErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc]) mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct mkEqErr _ [] = panic "mkEqErr" -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (ErrMsg ErrDoc) +mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (ErrMsg [SDoc]) mkEqErr1 ctxt ct -- Wanted or derived; -- givens handled in mkGivenErrorReporter = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct @@ -1452,7 +1452,7 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report -> Ct - -> TcType -> TcType -> TcM (ErrMsg ErrDoc) + -> TcType -> TcType -> TcM (ErrMsg [SDoc]) mkEqErr_help dflags ctxt report ct ty1 ty2 | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt report ct tv1 ty2 @@ -1463,7 +1463,7 @@ mkEqErr_help dflags ctxt report ct ty1 ty2 reportEqErr :: ReportErrCtxt -> Report -> Ct - -> TcType -> TcType -> TcM (ErrMsg ErrDoc) + -> TcType -> TcType -> TcM (ErrMsg [SDoc]) reportEqErr ctxt report ct ty1 ty2 = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo]) where @@ -1472,7 +1472,7 @@ reportEqErr ctxt report ct ty1 ty2 mkTyVarEqErr, mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Report -> Ct - -> TcTyVar -> TcType -> TcM (ErrMsg ErrDoc) + -> TcTyVar -> TcType -> TcM (ErrMsg [SDoc]) -- tv1 and ty2 are already tidied mkTyVarEqErr dflags ctxt report ct tv1 ty2 = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2) @@ -1672,7 +1672,7 @@ pp_givens givens -- always be another unsolved wanted around, which will ordinarily suppress -- this message. But this can still be printed out with -fdefer-type-errors -- (sigh), so we must produce a message. -mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc) +mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc]) mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ctxt ct report where report = important msg @@ -2279,7 +2279,7 @@ Warn of loopy local equalities that were dropped. ************************************************************************ -} -mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc) +mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg [SDoc]) mkDictErr ctxt cts = ASSERT( not (null cts) ) do { inst_envs <- tcGetInstEnvs diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index 62c6cb218a..c677643be5 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -230,7 +230,7 @@ tcHsBootSigs binds sigs -- Notice that we make GlobalIds, not LocalIds tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) -badBootDeclErr :: MsgDoc +badBootDeclErr :: SDoc badBootDeclErr = text "Illegal declarations in an hs-boot file" ------------------------ diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index 4d0c8da8e3..114e339dec 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -814,7 +814,7 @@ failWithDcErr parent child parents = do exportClashErr :: GlobalRdrEnv -> GreName -> GreName -> IE GhcPs -> IE GhcPs - -> MsgDoc + -> SDoc exportClashErr global_env child1 child2 ie1 ie2 = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon , ppr_export child1' gre1' ie1' diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index 9818642d47..b40386e513 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -542,7 +542,7 @@ checkCConv JavaScriptCallConv = do dflags <- getDynFlags -- Warnings -check :: Validity -> (MsgDoc -> MsgDoc) -> TcM () +check :: Validity -> (SDoc -> SDoc) -> TcM () check IsValid _ = return () check (NotValid doc) err_fn = addErrTc (err_fn doc) @@ -558,7 +558,7 @@ argument, result :: SDoc argument = text "argument" result = text "result" -badCName :: CLabelString -> MsgDoc +badCName :: CLabelString -> SDoc badCName target = sep [quotes (ppr target) <+> text "is not a valid C identifier"] diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index e21adf31df..346000975a 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -789,7 +789,7 @@ runAnnotation target expr = do ann_value = serialized } -convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized) +convertAnnotationWrapper :: ForeignHValue -> TcM (Either SDoc Serialized) convertAnnotationWrapper fhv = do interp <- tcGetInterp case interp of @@ -910,7 +910,7 @@ runMetaD = runMeta metaRequestD --------------- runMeta' :: Bool -- Whether code should be printed in the exception message -> (hs_syn -> SDoc) -- how to print the code - -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x + -> (SrcSpan -> ForeignHValue -> TcM (Either SDoc hs_syn)) -- How to run x -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or -- something like that -> TcM hs_syn -- Of type t @@ -1285,7 +1285,7 @@ runTH ty fhv = do -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. runRemoteTH :: IServInstance - -> [Messages ErrDoc] -- saved from nested calls to qRecover + -> [Messages [SDoc]] -- saved from nested calls to qRecover -> TcM () runRemoteTH iserv recovers = do THMsg msg <- liftIO $ readIServ iserv getTHMessage diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 746b5c71ea..bdcc85ef64 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -188,7 +188,7 @@ tcRnModule :: HscEnv -> ModSummary -> Bool -- True <=> save renamed syntax -> HsParsedModule - -> IO (Messages ErrDoc, Maybe TcGblEnv) + -> IO (Messages [SDoc], Maybe TcGblEnv) tcRnModule hsc_env mod_sum save_rn_syntax parsedModule@HsParsedModule {hpm_module= L loc this_module} @@ -1986,7 +1986,7 @@ this Note. ********************************************************* -} -runTcInteractive :: HscEnv -> TcRn a -> IO (Messages ErrDoc, Maybe a) +runTcInteractive :: HscEnv -> TcRn a -> IO (Messages [SDoc], Maybe a) -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports runTcInteractive hsc_env thing_inside @@ -2102,7 +2102,7 @@ We don't bother with the tcl_th_bndrs environment either. -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound -- values, coerced to (). tcRnStmt :: HscEnv -> GhciLStmt GhcPs - -> IO (Messages ErrDoc, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) + -> IO (Messages [SDoc], Maybe ([Id], LHsExpr GhcTc, FixityEnv)) tcRnStmt hsc_env rdr_stmt = runTcInteractive hsc_env $ do { @@ -2482,7 +2482,7 @@ getGhciStepIO = do return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) -isGHCiMonad :: HscEnv -> String -> IO (Messages ErrDoc, Maybe Name) +isGHCiMonad :: HscEnv -> String -> IO (Messages [SDoc], Maybe Name) isGHCiMonad hsc_env ty = runTcInteractive hsc_env $ do rdrEnv <- getGlobalRdrEnv @@ -2509,7 +2509,7 @@ data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:typ tcRnExpr :: HscEnv -> TcRnExprMode -> LHsExpr GhcPs - -> IO (Messages ErrDoc, Maybe Type) + -> IO (Messages [SDoc], Maybe Type) tcRnExpr hsc_env mode rdr_expr = runTcInteractive hsc_env $ do { @@ -2578,7 +2578,7 @@ has a special case for application chains. -------------------------- tcRnImportDecls :: HscEnv -> [LImportDecl GhcPs] - -> IO (Messages ErrDoc, Maybe GlobalRdrEnv) + -> IO (Messages [SDoc], Maybe GlobalRdrEnv) -- Find the new chunk of GlobalRdrEnv created by this list of import -- decls. In contract tcRnImports *extends* the TcGblEnv. tcRnImportDecls hsc_env import_decls @@ -2594,7 +2594,7 @@ tcRnType :: HscEnv -> ZonkFlexi -> Bool -- Normalise the returned type -> LHsType GhcPs - -> IO (Messages ErrDoc, Maybe (Type, Kind)) + -> IO (Messages [SDoc], Maybe (Type, Kind)) tcRnType hsc_env flexi normalise rdr_type = runTcInteractive hsc_env $ setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType] @@ -2728,7 +2728,7 @@ tcRnDeclsi exists to allow class, data, and other declarations in GHCi. tcRnDeclsi :: HscEnv -> [LHsDecl GhcPs] - -> IO (Messages ErrDoc, Maybe TcGblEnv) + -> IO (Messages [SDoc], Maybe TcGblEnv) tcRnDeclsi hsc_env local_decls = runTcInteractive hsc_env $ tcRnSrcDecls False local_decls Nothing @@ -2753,13 +2753,13 @@ externaliseAndTidyId this_mod id -- a package module with an interface on disk. If neither of these is -- true, then the result will be an error indicating the interface -- could not be found. -getModuleInterface :: HscEnv -> Module -> IO (Messages ErrDoc, Maybe ModIface) +getModuleInterface :: HscEnv -> Module -> IO (Messages [SDoc], Maybe ModIface) getModuleInterface hsc_env mod = runTcInteractive hsc_env $ loadModuleInterface (text "getModuleInterface") mod tcRnLookupRdrName :: HscEnv -> Located RdrName - -> IO (Messages ErrDoc, Maybe [Name]) + -> IO (Messages [SDoc], Maybe [Name]) -- ^ Find all the Names that this RdrName could mean, in GHCi tcRnLookupRdrName hsc_env (L loc rdr_name) = runTcInteractive hsc_env $ @@ -2773,7 +2773,7 @@ tcRnLookupRdrName hsc_env (L loc rdr_name) ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name))) ; return names } -tcRnLookupName :: HscEnv -> Name -> IO (Messages ErrDoc, Maybe TyThing) +tcRnLookupName :: HscEnv -> Name -> IO (Messages [SDoc], Maybe TyThing) tcRnLookupName hsc_env name = runTcInteractive hsc_env $ tcRnLookupName' name @@ -2792,7 +2792,7 @@ tcRnLookupName' name = do tcRnGetInfo :: HscEnv -> Name - -> IO ( Messages ErrDoc + -> IO ( Messages [SDoc] , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) -- Used to implement :info in GHCi diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index d4e8827d3d..8bc1d3a746 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -1960,7 +1960,7 @@ mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty theta = map idType dfun_ev_vars -methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) +methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) methSigCtxt sel_name sig_ty meth_ty env0 = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 43388472d7..338e24153c 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -60,7 +60,6 @@ import GHC.Types.FieldLabel import GHC.Rename.Env import GHC.Data.Bag import GHC.Utils.Misc -import GHC.Utils.Error import GHC.Driver.Session ( getDynFlags ) import Data.Maybe( mapMaybe ) import Control.Monad ( zipWithM ) @@ -974,7 +973,7 @@ add_void need_dummy_arg ty | otherwise = ty tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn - -> Either MsgDoc (LHsExpr GhcRn) + -> Either SDoc (LHsExpr GhcRn) -- Given a /pattern/, return an /expression/ that builds a value -- that matches the pattern. E.g. if the pattern is (Just [x]), -- the expression is (Just [x]). They look the same, but the @@ -989,7 +988,7 @@ tcPatToExpr name args pat = go pat -- Make a prefix con for prefix and infix patterns for simplicity mkPrefixConExpr :: Located Name -> [LPat GhcRn] - -> Either MsgDoc (HsExpr GhcRn) + -> Either SDoc (HsExpr GhcRn) mkPrefixConExpr lcon@(L loc _) pats = do { exprs <- mapM go pats ; let con = L loc (HsVar noExtField lcon) @@ -997,15 +996,15 @@ tcPatToExpr name args pat = go pat } mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) - -> Either MsgDoc (HsExpr GhcRn) + -> Either SDoc (HsExpr GhcRn) mkRecordConExpr con fields = do { exprFields <- mapM go fields ; return (RecordCon noExtField con exprFields) } - go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) + go :: LPat GhcRn -> Either SDoc (LHsExpr GhcRn) go (L loc p) = L loc <$> go1 p - go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn) + go1 :: Pat GhcRn -> Either SDoc (HsExpr GhcRn) go1 (ConPat NoExtField con info) = case info of PrefixCon _ ps -> mkPrefixConExpr con ps diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 8197220f09..4995e6702e 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -748,7 +748,7 @@ data TcLclEnv -- Changes as we move inside an expression -- and for tidying types tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints - tcl_errs :: TcRef (Messages ErrDoc) -- Place to accumulate errors + tcl_errs :: TcRef (Messages [SDoc]) -- Place to accumulate errors } setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv @@ -763,7 +763,7 @@ setLclEnvLoc env loc = env { tcl_loc = loc } getLclEnvLoc :: TcLclEnv -> RealSrcSpan getLclEnvLoc = tcl_loc -type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) +type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, SDoc)) -- Monadic so that we have a chance -- to deal with bound type variables just before error -- message construction diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 0265abef64..9e9f01aa0b 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -361,7 +361,7 @@ checkUnit (VirtUnit indef) = do -- an @hsig@ file.) tcRnCheckUnit :: HscEnv -> Unit -> - IO (Messages ErrDoc, Maybe ()) + IO (Messages [SDoc], Maybe ()) tcRnCheckUnit hsc_env uid = withTiming dflags (text "Check unit id" <+> ppr uid) @@ -381,7 +381,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 ErrDoc, Maybe TcGblEnv) + -> IO (Messages [SDoc], Maybe TcGblEnv) tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = withTiming dflags (text "Signature merging" <+> brackets (ppr this_mod)) @@ -912,7 +912,7 @@ mergeSignatures -- an @hsig@ file.) tcRnInstantiateSignature :: HscEnv -> Module -> RealSrcSpan -> - IO (Messages ErrDoc, Maybe TcGblEnv) + IO (Messages [SDoc], Maybe TcGblEnv) tcRnInstantiateSignature hsc_env this_mod real_loc = withTiming dflags (text "Signature instantiation"<+>brackets (ppr this_mod)) diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 3267a24cd6..8dcb0b47f7 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -112,7 +112,6 @@ import GHC.Unit.External import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Encoding -import GHC.Utils.Error import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Data.FastString @@ -155,7 +154,7 @@ lookupGlobal hsc_env name Failed msg -> pprPanic "lookupGlobal" msg } -lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) +lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) -- This may look up an Id that one has previously looked up. -- If so, we are going to read its interface file, and add its bindings -- to the ExternalPackageTable. @@ -174,7 +173,7 @@ lookupGlobal_maybe hsc_env name lookupImported_maybe hsc_env name } -lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) +lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) -- Returns (Failed err) if we can't find the interface file for the thing lookupImported_maybe hsc_env name = do { mb_thing <- lookupType hsc_env name @@ -183,7 +182,7 @@ lookupImported_maybe hsc_env name Nothing -> importDecl_maybe hsc_env name } -importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) +importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) importDecl_maybe hsc_env name | Just thing <- wiredInNameTyThing_maybe name = do { when (needWiredInHomeIface thing) @@ -200,7 +199,7 @@ ioLookupDataCon hsc_env name = do Succeeded thing -> return thing Failed msg -> pprPanic "lookupDataConIO" msg -ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc DataCon) +ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc DataCon) ioLookupDataCon_maybe hsc_env name = do thing <- lookupGlobal hsc_env name return $ case thing of diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 08d76b64a0..76856d7439 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -231,7 +231,7 @@ initTc :: HscEnv -> Module -> RealSrcSpan -> TcM r - -> IO (Messages ErrDoc, Maybe r) + -> IO (Messages [SDoc], Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already) @@ -353,7 +353,7 @@ initTcWithGbl :: HscEnv -> TcGblEnv -> RealSrcSpan -> TcM r - -> IO (Messages ErrDoc, Maybe r) + -> IO (Messages [SDoc], Maybe r) initTcWithGbl hsc_env gbl_env loc do_this = do { lie_var <- newIORef emptyWC ; errs_var <- newIORef emptyMessages @@ -399,7 +399,7 @@ initTcWithGbl hsc_env gbl_env loc do_this ; return (msgs, final_res) } -initTcInteractive :: HscEnv -> TcM a -> IO (Messages ErrDoc, Maybe a) +initTcInteractive :: HscEnv -> TcM a -> IO (Messages [SDoc], Maybe a) -- Initialise the type checker monad for use in GHCi initTcInteractive hsc_env thing_inside = initTc hsc_env HsSrcFile False @@ -588,9 +588,9 @@ getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) ; return (eps, hsc_HPT env) } --- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing +-- | A convenient wrapper for taking a @MaybeErr SDoc a@ and throwing -- an exception if it is an error. -withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a +withException :: TcRnIf gbl lcl (MaybeErr SDoc a) -> TcRnIf gbl lcl a withException do_this = do r <- do_this dflags <- getDynFlags @@ -930,22 +930,22 @@ wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a) -- Reporting errors -getErrsVar :: TcRn (TcRef (Messages ErrDoc)) +getErrsVar :: TcRn (TcRef (Messages [SDoc])) getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } -setErrsVar :: TcRef (Messages ErrDoc) -> TcRn a -> TcRn a +setErrsVar :: TcRef (Messages [SDoc]) -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) -addErr :: MsgDoc -> TcRn () +addErr :: SDoc -> TcRn () addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } -failWith :: MsgDoc -> TcRn a +failWith :: SDoc -> TcRn a failWith msg = addErr msg >> failM -failAt :: SrcSpan -> MsgDoc -> TcRn a +failAt :: SrcSpan -> SDoc -> TcRn a failAt loc msg = addErrAt loc msg >> failM -addErrAt :: SrcSpan -> MsgDoc -> TcRn () +addErrAt :: SrcSpan -> SDoc -> TcRn () -- addErrAt is mainly (exclusively?) used by the renamer, where -- tidying is not an issue, but it's all lazy so the extra -- work doesn't matter @@ -954,16 +954,16 @@ addErrAt loc msg = do { ctxt <- getErrCtxt ; err_info <- mkErrInfo tidy_env ctxt ; addLongErrAt loc msg err_info } -addErrs :: [(SrcSpan,MsgDoc)] -> TcRn () +addErrs :: [(SrcSpan,SDoc)] -> TcRn () addErrs msgs = mapM_ add msgs where add (loc,msg) = addErrAt loc msg -checkErr :: Bool -> MsgDoc -> TcRn () +checkErr :: Bool -> SDoc -> TcRn () -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) -addMessages :: Messages ErrDoc -> TcRn () +addMessages :: Messages [SDoc] -> TcRn () addMessages msgs1 = do { errs_var <- getErrsVar ; msgs0 <- readTcRef errs_var ; @@ -992,36 +992,36 @@ discardWarnings thing_inside ************************************************************************ -} -mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn (ErrMsg ErrDoc) +mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (ErrMsg [SDoc]) mkLongErrAt loc msg extra = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; let msg' = pprWithUnitState unit_state msg in return $ mkLongErrMsg loc printer msg' extra } -mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn (ErrMsg ErrDoc) +mkErrDocAt :: SrcSpan -> [SDoc] -> TcRn (ErrMsg [SDoc]) mkErrDocAt loc errDoc = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; let f = pprWithUnitState unit_state - errDoc' = mapErrDoc f errDoc + errDoc' = map f errDoc in return $ mkErr loc printer errDoc' } -addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn () addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError -reportErrors :: [ErrMsg ErrDoc] -> TcM () +reportErrors :: [ErrMsg [SDoc]] -> TcM () reportErrors = mapM_ reportError -reportError :: ErrMsg ErrDoc -> TcRn () +reportError :: ErrMsg [SDoc] -> TcRn () reportError err = do { traceTc "Adding error:" (pprLocErrMsg err) ; errs_var <- getErrsVar ; msgs <- readTcRef errs_var ; writeTcRef errs_var (err `addMessage` msgs) } -reportWarning :: WarnReason -> ErrMsg ErrDoc -> TcRn () +reportWarning :: WarnReason -> ErrMsg [SDoc] -> TcRn () reportWarning reason err = do { let warn = makeIntoWarning reason err -- 'err' was built by mkLongErrMsg or something like that, @@ -1100,12 +1100,12 @@ setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) -- | Add a fixed message to the error context. This message should not -- do any tidying. -addErrCtxt :: MsgDoc -> TcM a -> TcM a +addErrCtxt :: SDoc -> TcM a -> TcM a {-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt] addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -- | Add a message to the error context. This message may do tidying. -addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a +addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a {-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] addErrCtxtM ctxt m = updCtxt (push_ctxt (False, ctxt)) m @@ -1113,17 +1113,17 @@ addErrCtxtM ctxt m = updCtxt (push_ctxt (False, ctxt)) m -- message is always sure to be reported, even if there is a lot of -- context. It also doesn't count toward the maximum number of contexts -- reported. -addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a +addLandmarkErrCtxt :: SDoc -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxt #-} -- Note [Inlining addErrCtxt] addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations -- and tidying. -addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a +addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt] addLandmarkErrCtxtM ctxt m = updCtxt (push_ctxt (True, ctxt)) m -push_ctxt :: (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) +push_ctxt :: (Bool, TidyEnv -> TcM (TidyEnv, SDoc)) -> Bool -> [ErrCtxt] -> [ErrCtxt] push_ctxt ctxt in_gen ctxts | in_gen = ctxts @@ -1191,7 +1191,7 @@ capture_constraints thing_inside ; lie <- readTcRef lie_var ; return (res, lie) } -capture_messages :: TcM r -> TcM (r, Messages ErrDoc) +capture_messages :: TcM r -> TcM (r, Messages [SDoc]) -- capture_messages simply captures and returns the -- errors arnd warnings generated by thing_inside -- Precondition: thing_inside must not throw an exception! @@ -1361,7 +1361,7 @@ foldAndRecoverM f acc (x:xs) = Just acc' -> foldAndRecoverM f acc' xs } ----------------------- -tryTc :: TcRn a -> TcRn (Maybe a, Messages ErrDoc) +tryTc :: TcRn a -> TcRn (Maybe a, Messages [SDoc]) -- (tryTc m) executes m, and returns -- Just r, if m succeeds (returning r) -- Nothing, if m fails @@ -1414,11 +1414,11 @@ tryTcDiscardingErrs recover thing_inside tidy up the message; we then use it to tidy the context messages -} -addErrTc :: MsgDoc -> TcM () +addErrTc :: SDoc -> TcM () addErrTc err_msg = do { env0 <- tcInitTidyEnv ; addErrTcM (env0, err_msg) } -addErrTcM :: (TidyEnv, MsgDoc) -> TcM () +addErrTcM :: (TidyEnv, SDoc) -> TcM () addErrTcM (tidy_env, err_msg) = do { ctxt <- getErrCtxt ; loc <- getSrcSpanM ; @@ -1426,27 +1426,27 @@ addErrTcM (tidy_env, err_msg) -- The failWith functions add an error message and cause failure -failWithTc :: MsgDoc -> TcM a -- Add an error message and fail +failWithTc :: SDoc -> TcM a -- Add an error message and fail failWithTc err_msg = addErrTc err_msg >> failM -failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail +failWithTcM :: (TidyEnv, SDoc) -> TcM a -- Add an error message and fail failWithTcM local_and_msg = addErrTcM local_and_msg >> failM -checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true +checkTc :: Bool -> SDoc -> TcM () -- Check that the boolean is true checkTc True _ = return () checkTc False err = failWithTc err -checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () +checkTcM :: Bool -> (TidyEnv, SDoc) -> TcM () checkTcM True _ = return () checkTcM False err = failWithTcM err -failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false +failIfTc :: Bool -> SDoc -> TcM () -- Check that the boolean is false failIfTc False _ = return () failIfTc True err = failWithTc err -failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () +failIfTcM :: Bool -> (TidyEnv, SDoc) -> TcM () -- Check that the boolean is false failIfTcM False _ = return () failIfTcM True err = failWithTcM err @@ -1456,59 +1456,59 @@ failIfTcM True err = failWithTcM err -- | Display a warning if a condition is met, -- and the warning is enabled -warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn () +warnIfFlag :: WarningFlag -> Bool -> SDoc -> TcRn () warnIfFlag warn_flag is_bad msg = do { warn_on <- woptM warn_flag ; when (warn_on && is_bad) $ addWarn (Reason warn_flag) msg } -- | Display a warning if a condition is met. -warnIf :: Bool -> MsgDoc -> TcRn () +warnIf :: Bool -> SDoc -> TcRn () warnIf is_bad msg = when is_bad (addWarn NoReason msg) -- | Display a warning if a condition is met. -warnTc :: WarnReason -> Bool -> MsgDoc -> TcM () +warnTc :: WarnReason -> Bool -> SDoc -> TcM () warnTc reason warn_if_true warn_msg | warn_if_true = addWarnTc reason warn_msg | otherwise = return () -- | Display a warning if a condition is met. -warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM () +warnTcM :: WarnReason -> Bool -> (TidyEnv, SDoc) -> TcM () warnTcM reason warn_if_true warn_msg | warn_if_true = addWarnTcM reason warn_msg | otherwise = return () -- | Display a warning in the current context. -addWarnTc :: WarnReason -> MsgDoc -> TcM () +addWarnTc :: WarnReason -> SDoc -> TcM () addWarnTc reason msg = do { env0 <- tcInitTidyEnv ; addWarnTcM reason (env0, msg) } -- | Display a warning in a given context. -addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM () +addWarnTcM :: WarnReason -> (TidyEnv, SDoc) -> TcM () addWarnTcM reason (env0, msg) = do { ctxt <- getErrCtxt ; err_info <- mkErrInfo env0 ctxt ; add_warn reason msg err_info } -- | Display a warning for the current source location. -addWarn :: WarnReason -> MsgDoc -> TcRn () +addWarn :: WarnReason -> SDoc -> TcRn () addWarn reason msg = add_warn reason msg Outputable.empty -- | Display a warning for a given source location. -addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn () +addWarnAt :: WarnReason -> SrcSpan -> SDoc -> TcRn () addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty -- | Display a warning, with an optional flag, for the current source -- location. -add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn () +add_warn :: WarnReason -> SDoc -> SDoc -> TcRn () add_warn reason msg extra_info = do { loc <- getSrcSpanM ; add_warn_at reason loc msg extra_info } -- | Display a warning, with an optional flag, for a given location. -add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +add_warn_at :: WarnReason -> SrcSpan -> SDoc -> SDoc -> TcRn () add_warn_at reason loc msg extra_info = do { printer <- getPrintUnqualified ; let { warn = mkLongWarnMsg loc printer @@ -1521,7 +1521,7 @@ add_warn_at reason loc msg extra_info Other helper functions -} -add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan +add_err_tcm :: TidyEnv -> SDoc -> SrcSpan -> [ErrCtxt] -> TcM () add_err_tcm tidy_env err_msg loc ctxt @@ -2046,7 +2046,7 @@ getIfModule :: IfL Module getIfModule = do { env <- getLclEnv; return (if_mod env) } -------------------- -failIfM :: MsgDoc -> IfL a +failIfM :: SDoc -> IfL a -- The Iface monad doesn't have a place to accumulate errors, so we -- just fall over fast if one happens; it "shouldn't happen". -- We use IfL here so that we can get context info out of the local env diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index 0a0d341a47..8b85ff1a6c 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -230,7 +230,7 @@ import GHC.Data.List.SetOps ( getNth, findDupsEq ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString -import GHC.Utils.Error( Validity(..), MsgDoc, isValid ) +import GHC.Utils.Error( Validity(..), isValid ) import qualified GHC.LanguageExtensions as LangExt import Data.List ( mapAccumL ) @@ -2432,7 +2432,7 @@ legalFIPrimResultTyCon dflags tc | otherwise = NotValid unlifted_only -unlifted_only :: MsgDoc +unlifted_only :: SDoc unlifted_only = text "foreign import prim only accepts simple unlifted types" validIfUnliftedFFITypes :: DynFlags -> Validity diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index f5cf306dc1..23dcfe6e83 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -159,7 +159,7 @@ matchActualFunTySigma herald mb_thing err_info fun_ty ; return (mkWpCastN co, Scaled mult arg_ty, res_ty) } ------------ - mk_ctxt :: TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) + mk_ctxt :: TcType -> TidyEnv -> TcM (TidyEnv, SDoc) mk_ctxt res_ty env = mkFunTysMsg env herald (reverse arg_tys_so_far) res_ty n_val_args_in_call (n_val_args_in_call, arg_tys_so_far) = err_info @@ -371,7 +371,7 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside ; return (wrap, result) } ------------ - mk_ctxt :: [Scaled ExpSigmaType] -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) + mk_ctxt :: [Scaled ExpSigmaType] -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) mk_ctxt arg_tys res_ty env = mkFunTysMsg env herald arg_tys' res_ty arity where @@ -380,7 +380,7 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside -- this is safe b/c we're called from "go" mkFunTysMsg :: TidyEnv -> SDoc -> [Scaled TcType] -> TcType -> Arity - -> TcM (TidyEnv, MsgDoc) + -> TcM (TidyEnv, SDoc) mkFunTysMsg env herald arg_tys res_ty n_val_args_in_call = do { (env', fun_rho) <- zonkTidyTcType env $ mkVisFunTys arg_tys res_ty diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index f66c768c57..f446b69634 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -2205,7 +2205,7 @@ checkValidAssocTyFamDeflt fam_tc pats = -- checkFamInstRhs :: TyCon -> [Type] -- LHS -> [(TyCon, [Type])] -- type family calls in RHS - -> [MsgDoc] + -> [SDoc] checkFamInstRhs lhs_tc lhs_tys famInsts = mapMaybe check famInsts where diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index cad86d1445..49fc1bd912 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -68,25 +68,25 @@ import System.IO.Unsafe ------------------------------------------------------------------- -- The external interface -convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs] +convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either SDoc [LHsDecl GhcPs] convertToHsDecls origin loc ds = initCvt origin loc (fmap catMaybes (mapM cvt_dec ds)) where cvt_dec d = wrapMsg "declaration" d (cvtDec d) -convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs) +convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either SDoc (LHsExpr GhcPs) convertToHsExpr origin loc e = initCvt origin loc $ wrapMsg "expression" e $ cvtl e -convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs) +convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either SDoc (LPat GhcPs) convertToPat origin loc p = initCvt origin loc $ wrapMsg "pattern" p $ cvtPat p -convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs) +convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either SDoc (LHsType GhcPs) convertToHsType origin loc t = initCvt origin loc $ wrapMsg "type" t $ cvtType t ------------------------------------------------------------------- -newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a) } +newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either SDoc (SrcSpan, a) } deriving (Functor) -- Push down the Origin (that is configurable by -- -fenable-th-splice-warnings) and source location; @@ -110,13 +110,13 @@ instance Monad CvtM where Left err -> Left err Right (loc',v) -> unCvtM (k v) origin loc' -initCvt :: Origin -> SrcSpan -> CvtM a -> Either MsgDoc a +initCvt :: Origin -> SrcSpan -> CvtM a -> Either SDoc a initCvt origin loc (CvtM m) = fmap snd (m origin loc) force :: a -> CvtM () force a = a `seq` return () -failWith :: MsgDoc -> CvtM a +failWith :: SDoc -> CvtM a failWith m = CvtM (\_ _ -> Left m) getOrigin :: CvtM Origin @@ -467,7 +467,7 @@ cvtTySynEqn (TySynEqn mb_bndrs lhs rhs) } ---------------- -cvt_ci_decs :: MsgDoc -> [TH.Dec] +cvt_ci_decs :: SDoc -> [TH.Dec] -> CvtM (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], @@ -564,7 +564,7 @@ is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e) is_ip_bind decl = Right decl -mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc +mkBadDecMsg :: Outputable a => SDoc -> [a] -> SDoc mkBadDecMsg doc bads = sep [ text "Illegal declaration(s) in" <+> doc <> colon , nest 2 (vcat (map Outputable.ppr bads)) ] @@ -862,7 +862,7 @@ cvtRuleBndr (TypedRuleVar n ty) -- Declarations --------------------------------------------------- -cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) +cvtLocalDecs :: SDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) cvtLocalDecs doc ds = case partitionWith is_ip_bind ds of ([], []) -> return (EmptyLocalBinds noExtField) diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index 6107f9da49..8b4f760cfc 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -13,13 +13,11 @@ module GHC.Types.Error , addMessage , unionMessages , ErrMsg (..) + , MsgEnvelope (..) , WarnMsg - , ErrDoc (..) - , MsgDoc + , SDoc , Severity (..) , RenderableDiagnostic (..) - , errDoc - , mapErrDoc , pprMessageBag , mkLocMessage , mkLocMessageAnn @@ -99,11 +97,10 @@ addMessage x (Messages xs) = Messages (x `consBag` xs) unionMessages :: Messages e -> Messages e -> Messages e unionMessages (Messages msgs1) (Messages msgs2) = Messages (msgs1 `unionBags` msgs2) -type WarningMessages = Bag (ErrMsg ErrDoc) -type ErrorMessages = Bag (ErrMsg ErrDoc) +type WarningMessages = Bag (ErrMsg [SDoc]) +type ErrorMessages = Bag (ErrMsg [SDoc]) -type MsgDoc = SDoc -type WarnMsg = ErrMsg ErrDoc +type WarnMsg = ErrMsg [SDoc] {- Note [Rendering Messages] @@ -135,7 +132,7 @@ knowledge that a given type 'e' has a 'RenderableDiagnostic' constraint. -- | A class for types (typically errors and warnings) which can be \"rendered\" into an opaque 'ErrDoc'. -- For more information, see Note [Rendering Messages]. class RenderableDiagnostic a where - renderDiagnostic :: a -> ErrDoc + renderDiagnostic :: a -> [SDoc] -- | The main 'GHC' error type, parameterised over the /domain-specific/ message. data ErrMsg e = ErrMsg @@ -147,27 +144,9 @@ data ErrMsg e = ErrMsg , errMsgReason :: WarnReason } deriving Functor --- | Categorise error msgs by their importance. This is so each section can --- be rendered visually distinct. See Note [Error report] for where these come --- from. -data ErrDoc = ErrDoc { - -- | Primary error msg. - errDocImportant :: [MsgDoc], - -- | Context e.g. \"In the second argument of ...\". - errDocContext :: [MsgDoc], - -- | Supplementary information, e.g. \"Relevant bindings include ...\". - errDocSupplementary :: [MsgDoc] - } - -instance RenderableDiagnostic ErrDoc where +instance RenderableDiagnostic [SDoc] where renderDiagnostic = id -errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc -errDoc = ErrDoc - -mapErrDoc :: (MsgDoc -> MsgDoc) -> ErrDoc -> ErrDoc -mapErrDoc f (ErrDoc a b c) = ErrDoc (map f a) (map f b) (map f c) - data Severity = SevOutput | SevFatal @@ -194,19 +173,19 @@ data Severity instance ToJson Severity where json s = JSString (show s) -instance Show (ErrMsg ErrDoc) where +instance Show (ErrMsg [SDoc]) where show = showErrMsg -- | Shows an 'ErrMsg'. showErrMsg :: RenderableDiagnostic a => ErrMsg a -> String showErrMsg err = - renderWithContext defaultSDocContext (vcat (errDocImportant $ renderDiagnostic $ errMsgDiagnostic err)) + renderWithContext defaultSDocContext (vcat (renderDiagnostic $ errMsgDiagnostic err)) -pprMessageBag :: Bag MsgDoc -> SDoc +pprMessageBag :: Bag SDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) -- | Make an unannotated error message with location info. -mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc +mkLocMessage :: Severity -> SrcSpan -> SDoc -> SDoc mkLocMessage = mkLocMessageAnn Nothing -- | Make a possibly annotated error message with location info. @@ -214,8 +193,8 @@ mkLocMessageAnn :: Maybe String -- ^ optional annotation -> Severity -- ^ severity -> SrcSpan -- ^ location - -> MsgDoc -- ^ message - -> MsgDoc + -> SDoc -- ^ message + -> SDoc -- Always print the location, even if it is unhelpful. Error messages -- are supposed to be in a standard format, and one without a location -- would look strange. Better to say explicitly "<no location info>". @@ -255,7 +234,7 @@ getSeverityColour SevError = Col.sError getSeverityColour SevFatal = Col.sFatal getSeverityColour _ = const mempty -getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc +getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty getCaretDiagnostic severity (RealSrcSpan span _) = caretDiagnostic <$> getSrcLine (srcSpanFile span) row @@ -352,19 +331,19 @@ mk_err_msg sev locn print_unqual err mkErr :: SrcSpan -> PrintUnqualified -> e -> ErrMsg e mkErr = mk_err_msg SevError -mkLongErrMsg, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg ErrDoc +mkLongErrMsg, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> ErrMsg [SDoc] -- ^ A long (multi-line) error message -mkErrMsg, mkWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg ErrDoc +mkErrMsg, mkWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg [SDoc] -- ^ A short (one-line) error message -mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan -> MsgDoc -> ErrMsg ErrDoc +mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan -> SDoc -> ErrMsg [SDoc] -- ^ Variant that doesn't care about qualified/unqualified names -mkLongErrMsg locn unqual msg extra = mk_err_msg SevError locn unqual (ErrDoc [msg] [] [extra]) -mkErrMsg locn unqual msg = mk_err_msg SevError locn unqual (ErrDoc [msg] [] []) -mkPlainErrMsg locn msg = mk_err_msg SevError locn alwaysQualify (ErrDoc [msg] [] []) -mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual (ErrDoc [msg] [] [extra]) -mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual (ErrDoc [msg] [] []) -mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify (ErrDoc [msg] [] []) +mkLongErrMsg locn unqual msg extra = mk_err_msg SevError locn unqual [msg,extra] +mkErrMsg locn unqual msg = mk_err_msg SevError locn unqual [msg] +mkPlainErrMsg locn msg = mk_err_msg SevError locn alwaysQualify [msg] +mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual [msg,extra] +mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual [msg] +mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify [msg] -- -- Queries diff --git a/compiler/GHC/Types/SourceError.hs b/compiler/GHC/Types/SourceError.hs index 200905881a..640bae3dfc 100644 --- a/compiler/GHC/Types/SourceError.hs +++ b/compiler/GHC/Types/SourceError.hs @@ -27,7 +27,7 @@ srcErrorMessages (SourceError msgs) = msgs throwErrors :: MonadIO io => ErrorMessages -> io a throwErrors = liftIO . throwIO . mkSrcErr -throwOneError :: MonadIO io => ErrMsg ErrDoc -> io a +throwOneError :: MonadIO io => ErrMsg [SDoc] -> io a throwOneError = throwErrors . unitBag -- | A source error is an error that is caused by one or more errors in the diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index f371b17953..05d98c9ed8 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -15,9 +15,8 @@ module GHC.Utils.Error ( -- * Messages ErrMsg(..), - ErrDoc(..), errDoc, - mapErrDoc, - WarnMsg, MsgDoc, + WarnMsg, + SDoc, Messages, ErrorMessages, WarningMessages, unionMessages, errorsFound, isEmptyMessages, @@ -91,11 +90,10 @@ import System.IO import GHC.Conc ( getAllocationCounter ) import System.CPUTime - ------------------------- data Validity = IsValid -- ^ Everything is fine - | NotValid MsgDoc -- ^ A problem, and some indication of why + | NotValid SDoc -- ^ A problem, and some indication of why isValid :: Validity -> Bool isValid IsValid = True @@ -110,7 +108,7 @@ allValid :: [Validity] -> Validity allValid [] = IsValid allValid (v : vs) = v `andValid` allValid vs -getInvalids :: [Validity] -> [MsgDoc] +getInvalids :: [Validity] -> [SDoc] getInvalids vs = [d | NotValid d <- vs] orValid :: Validity -> Validity -> Validity @@ -121,17 +119,18 @@ orValid _ v = v -- Collecting up messages for later ordering and printing. ---------------- -formatErrDoc :: SDocContext -> ErrDoc -> SDoc -formatErrDoc ctx (ErrDoc important context supplementary) +-- | Formats the input list of structured document, where each element of the list gets a bullet. +formatErrDoc :: SDocContext -> [SDoc] -> SDoc +formatErrDoc ctx docs = case msgs of - [msg] -> vcat msg - _ -> vcat $ map starred msgs + [] -> Outputable.empty + [msg] -> msg + _ -> vcat $ map starred msgs where - msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty ctx)) - [important, context, supplementary] - starred = (bullet<+>) . vcat + msgs = filter (not . Outputable.isEmpty ctx) docs + starred = (bullet<+>) -pprErrMsgBagWithLoc :: Bag (ErrMsg ErrDoc) -> [SDoc] +pprErrMsgBagWithLoc :: Bag (ErrMsg [SDoc]) -> [SDoc] pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ] pprLocErrMsg :: RenderableDiagnostic e => ErrMsg e -> SDoc @@ -353,15 +352,15 @@ ifVerbose dflags val act | otherwise = return () {-# INLINE ifVerbose #-} -- see Note [INLINE conditional tracing utilities] -errorMsg :: DynFlags -> MsgDoc -> IO () +errorMsg :: DynFlags -> SDoc -> IO () errorMsg dflags msg = putLogMsg dflags NoReason SevError noSrcSpan $ withPprStyle defaultErrStyle msg -warningMsg :: DynFlags -> MsgDoc -> IO () +warningMsg :: DynFlags -> SDoc -> IO () warningMsg dflags msg = putLogMsg dflags NoReason SevWarning noSrcSpan $ withPprStyle defaultErrStyle msg -fatalErrorMsg :: DynFlags -> MsgDoc -> IO () +fatalErrorMsg :: DynFlags -> SDoc -> IO () fatalErrorMsg dflags msg = putLogMsg dflags NoReason SevFatal noSrcSpan $ withPprStyle defaultErrStyle msg @@ -528,29 +527,29 @@ withTiming' dflags what force_result prtimings action eventBeginsDoc ctx w = showSDocOneLine ctx $ text "GHC:started:" <+> w eventEndsDoc ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w -debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () +debugTraceMsg :: DynFlags -> Int -> SDoc -> IO () debugTraceMsg dflags val msg = ifVerbose dflags val $ logInfo dflags (withPprStyle defaultDumpStyle msg) {-# INLINE debugTraceMsg #-} -- see Note [INLINE conditional tracing utilities] -putMsg :: DynFlags -> MsgDoc -> IO () +putMsg :: DynFlags -> SDoc -> IO () putMsg dflags msg = logInfo dflags (withPprStyle defaultUserStyle msg) -printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () +printInfoForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO () printInfoForUser dflags print_unqual msg = logInfo dflags (withUserStyle print_unqual AllTheWay msg) -printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () +printOutputForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO () printOutputForUser dflags print_unqual msg = logOutput dflags (withUserStyle print_unqual AllTheWay msg) -logInfo :: DynFlags -> MsgDoc -> IO () +logInfo :: DynFlags -> SDoc -> IO () logInfo dflags msg = putLogMsg dflags NoReason SevInfo noSrcSpan msg -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' -logOutput :: DynFlags -> MsgDoc -> IO () +logOutput :: DynFlags -> SDoc -> IO () logOutput dflags msg = putLogMsg dflags NoReason SevOutput noSrcSpan msg |