From: Ian Lynagh Date: Tue, 31 Mar 2009 13:40:58 +0000 (+0000) Subject: mkErrorAppDs now takes an SDoc rather than a String X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=79b22beb4d2eca1877d99d55838ba6ce69658405 mkErrorAppDs now takes an SDoc rather than a String This avoids some showSDoc's where the String then gets converted back into an SDoc. --- diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 6126b63..509cce2 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -273,7 +273,7 @@ dsExpr (HsCoreAnn fs expr) dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty)) | isEmptyMatchGroup matches -- A Core 'case' is always non-empty = -- So desugar empty HsCase to error call - mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) "case" + mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case")) | otherwise = do { core_discrim <- dsLExpr discrim @@ -396,8 +396,8 @@ dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do = case findField (rec_flds rbinds) lbl of (rhs:rhss) -> ASSERT( null rhss ) dsLExpr rhs - [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl)) - unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty "" + [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl) + unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty labels = dataConFieldLabels (idDataCon data_con_id) -- The data_con_id is guaranteed to be the wrapper id of the constructor diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs index 83ceeca..24086a2 100644 --- a/compiler/deSugar/DsGRHSs.lhs +++ b/compiler/deSugar/DsGRHSs.lhs @@ -32,7 +32,7 @@ import TysWiredIn import PrelNames import Name import SrcLoc - +import Outputable \end{code} @dsGuarded@ is used for both @case@ expressions and pattern bindings. @@ -51,7 +51,7 @@ dsGuarded :: GRHSs Id -> Type -> DsM CoreExpr dsGuarded grhss rhs_ty = do match_result <- dsGRHSs PatBindRhs [] grhss rhs_ty - error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty "" + error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty extractMatchResult match_result error_expr \end{code} diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index 9508e51..99a5dab 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -37,6 +37,7 @@ import PrelNames import PrelInfo import SrcLoc import Outputable +import FastString import Control.Monad ( liftM2 ) \end{code} @@ -611,7 +612,7 @@ dePArrComp (LetStmt ds : qs) body pa cea = do let projBody = mkCoreLet (NonRec let'v clet) $ mkCoreTup [Var v, Var let'v] errTy = exprType projBody - errMsg = "DsListComp.dePArrComp: internal error!" + errMsg = ptext (sLit "DsListComp.dePArrComp: internal error!") cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)] @@ -673,7 +674,7 @@ mkLambda :: Type -- type of the argument -> DsM (CoreExpr, Type) mkLambda ty p ce = do v <- newSysLocalDs ty - let errMsg = do "DsListComp.deLambda: internal error!" + let errMsg = ptext (sLit "DsListComp.deLambda: internal error!") ce'ty = exprType ce cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 6eeb43d..2a6e034 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -73,8 +73,6 @@ import Util import ListSetOps import FastString import StaticFlags - -import Data.Char \end{code} @@ -392,13 +390,13 @@ mkCoAlgCaseMatchResult var ty match_alts \begin{code} mkErrorAppDs :: Id -- The error function -> Type -- Type to which it should be applied - -> String -- The error message string to pass + -> SDoc -- The error message string to pass -> DsM CoreExpr mkErrorAppDs err_id ty msg = do src_loc <- getSrcSpanDs let - full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg]) + full_msg = showSDoc (hcat [ppr src_loc, text "|", msg]) core_msg = Lit (mkMachString full_msg) -- mkMachString returns a result of type String# return (mkApps (Var err_id) [Type ty, core_msg]) @@ -458,7 +456,7 @@ mkSelectorBinds pat val_expr -- For the error message we make one error-app, to avoid duplication. -- But we need it at different types... so we use coerce for that - err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (showSDoc (ppr pat)) + err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (ppr pat) err_var <- newSysLocalDs unitTy binds <- mapM (mk_bind val_var err_var) binders return ( (val_var, val_expr) : @@ -467,7 +465,7 @@ mkSelectorBinds pat val_expr | otherwise = do - error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat)) + error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat) tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr tuple_var <- newSysLocalDs tuple_ty let diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 100a2b5..24c4680 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -687,11 +687,11 @@ matchEquations ctxt vars eqns_info rhs_ty = do { dflags <- getDOptsDs ; locn <- getSrcSpanDs ; let ds_ctxt = DsMatchContext ctxt locn - error_string = matchContextErrString ctxt + error_doc = matchContextErrString ctxt ; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info - ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string + ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc ; extractMatchResult match_result fail_expr } where match_fun dflags ds_ctxt diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 66336b6..2ddb7c8 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -1105,20 +1105,20 @@ pprStmtResultContext other = ptext (sLit "the result of") <+> pprStmtC -} -- Used to generate the string for a *runtime* error message -matchContextErrString :: Outputable id => HsMatchContext id -> String -matchContextErrString (FunRhs fun _) = "function " ++ showSDoc (ppr fun) -matchContextErrString CaseAlt = "case" -matchContextErrString PatBindRhs = "pattern binding" -matchContextErrString RecUpd = "record update" -matchContextErrString LambdaExpr = "lambda" -matchContextErrString ProcExpr = "proc" +matchContextErrString :: Outputable id => HsMatchContext id -> SDoc +matchContextErrString (FunRhs fun _) = ptext (sLit "function") <+> ppr fun +matchContextErrString CaseAlt = ptext (sLit "case") +matchContextErrString PatBindRhs = ptext (sLit "pattern binding") +matchContextErrString RecUpd = ptext (sLit "record update") +matchContextErrString LambdaExpr = ptext (sLit "lambda") +matchContextErrString ProcExpr = ptext (sLit "proc") matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c) -matchContextErrString (StmtCtxt (PatGuard _)) = "pattern guard" -matchContextErrString (StmtCtxt DoExpr) = "'do' expression" -matchContextErrString (StmtCtxt (MDoExpr _)) = "'mdo' expression" -matchContextErrString (StmtCtxt ListComp) = "list comprehension" -matchContextErrString (StmtCtxt PArrComp) = "array comprehension" +matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") +matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' expression") +matchContextErrString (StmtCtxt (MDoExpr _)) = ptext (sLit "'mdo' expression") +matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension") +matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension") \end{code} \begin{code}