mkErrorAppDs now takes an SDoc rather than a String

This avoids some showSDoc's where the String then gets converted back
into an SDoc.

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

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}
 

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

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

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

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}