Commit 79b22beb authored by Ian Lynagh's avatar Ian Lynagh
Browse files

mkErrorAppDs now takes an SDoc rather than a String

This avoids some showSDoc's where the String then gets converted back
into an SDoc.
parent b6fcd8d1
......@@ -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
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment