diff options
Diffstat (limited to 'compiler')
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 |