This avoids some showSDoc's where the String then gets converted back
into an SDoc.
dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
| isEmptyMatchGroup matches -- A Core 'case' is always non-empty
= -- So desugar empty HsCase to error call
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
| otherwise
= do { core_discrim <- dsLExpr discrim
= case findField (rec_flds rbinds) lbl of
(rhs:rhss) -> ASSERT( null rhss )
dsLExpr rhs
= 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
labels = dataConFieldLabels (idDataCon data_con_id)
-- The data_con_id is guaranteed to be the wrapper id of the constructor
import PrelNames
import Name
import SrcLoc
import PrelNames
import Name
import SrcLoc
\end{code}
@dsGuarded@ is used for both @case@ expressions and pattern bindings.
\end{code}
@dsGuarded@ is used for both @case@ expressions and pattern bindings.
dsGuarded grhss rhs_ty = do
match_result <- dsGRHSs PatBindRhs [] grhss rhs_ty
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}
extractMatchResult match_result error_expr
\end{code}
import PrelInfo
import SrcLoc
import Outputable
import PrelInfo
import SrcLoc
import Outputable
import Control.Monad ( liftM2 )
\end{code}
import Control.Monad ( liftM2 )
\end{code}
let projBody = mkCoreLet (NonRec let'v clet) $
mkCoreTup [Var v, Var let'v]
errTy = exprType projBody
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)]
cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg
ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr
let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]
-> DsM (CoreExpr, Type)
mkLambda ty p ce = do
v <- newSysLocalDs ty
-> 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
ce'ty = exprType ce
cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg
res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr
import ListSetOps
import FastString
import StaticFlags
import ListSetOps
import FastString
import StaticFlags
\begin{code}
mkErrorAppDs :: Id -- The error function
-> Type -- Type to which it should be applied
\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
-> 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])
core_msg = Lit (mkMachString full_msg)
-- mkMachString returns a result of type String#
return (mkApps (Var err_id) [Type ty, core_msg])
-- 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
-- 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) :
err_var <- newSysLocalDs unitTy
binds <- mapM (mk_bind val_var err_var) binders
return ( (val_var, val_expr) :
- 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
tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
tuple_var <- newSysLocalDs tuple_ty
let
= do { dflags <- getDOptsDs
; locn <- getSrcSpanDs
; let ds_ctxt = DsMatchContext ctxt locn
= 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
; 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
; extractMatchResult match_result fail_expr }
where
match_fun dflags ds_ctxt
-}
-- Used to generate the string for a *runtime* error message
-}
-- 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 (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")