X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=2d46c8bedb0256663a29fc1572e7134a520aee20;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hp=11f63656d1b57faca47eeb7bac14afa0a9ce702d;hpb=ae45ff0e9831a0dc862a5d68d03e355d7e323c62;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 11f6365..2d46c8b 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -6,47 +6,47 @@ \begin{code} #include "HsVersions.h" -module TcExpr ( tcExpr ) where +module TcExpr ( tcExpr, tcId ) where IMP_Ubiq() -import HsSyn ( HsExpr(..), Qualifier(..), Stmt(..), +import HsSyn ( HsExpr(..), Stmt(..), DoOrListComp(..), HsBinds(..), Bind(..), MonoBinds(..), ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds, - Match, Fake, InPat, OutPat, PolyType, - failureFreePat, collectPatBinders ) -import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..), - RenamedStmt(..), RenamedRecordBinds(..), - RnName{-instance Outputable-} + Match, Fake, InPat, OutPat, HsType, Fixity, + pprParendExpr, failureFreePat, collectPatBinders ) +import RnHsSyn ( SYN_IE(RenamedHsExpr), + SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds) ) -import TcHsSyn ( TcExpr(..), TcQual(..), TcStmt(..), - TcIdOcc(..), TcRecordBinds(..), +import TcHsSyn ( SYN_IE(TcExpr), SYN_IE(TcStmt), + TcIdOcc(..), SYN_IE(TcRecordBinds), mkHsTyApp ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import Inst ( Inst, InstOrigin(..), OverloadedLit(..), - LIE(..), emptyLIE, plusLIE, plusLIEs, newOverloadedLit, + SYN_IE(LIE), emptyLIE, plusLIE, plusLIEs, newOverloadedLit, newMethod, newMethodWithGivenTy, newDicts ) -import TcBinds ( tcBindsAndThen ) +import TcBinds ( tcBindsAndThen, checkSigTyVars ) import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey, - tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars + tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars, + tcExtendGlobalTyVars ) +import SpecEnv ( SpecEnv ) import TcMatches ( tcMatchesCase, tcMatch ) -import TcMonoType ( tcPolyType ) +import TcMonoType ( tcHsType ) import TcPat ( tcPat ) import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 ) -import TcType ( TcType(..), TcMaybe(..), - tcInstId, tcInstType, tcInstSigTyVars, +import TcType ( SYN_IE(TcType), TcMaybe(..), + tcInstId, tcInstType, tcInstSigTcType, tcInstSigType, tcInstTcType, tcInstTheta, newTyVarTy, zonkTcTyVars, zonkTcType ) import TcKind ( TcKind ) -import Class ( Class(..), classSig ) +import Class ( SYN_IE(Class), classSig ) import FieldLabel ( fieldLabelName ) -import Id ( idType, dataConFieldLabels, dataConSig, Id(..), GenId ) +import Id ( idType, dataConFieldLabels, dataConSig, SYN_IE(Id), GenId ) import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind ) -import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals ) import Name ( Name{-instance Eq-} ) import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy, getTyVar_maybe, getFunTy_maybe, instantiateTy, @@ -54,21 +54,20 @@ import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy, isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe, getAppDataTyCon, maybeAppDataTyCon ) -import TyVar ( GenTyVar, TyVarSet(..), unionTyVarSets, mkTyVarSet ) +import TyVar ( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, mkTyVarSet ) import TysPrim ( intPrimTy, charPrimTy, doublePrimTy, - floatPrimTy, addrPrimTy + floatPrimTy, addrPrimTy, realWorldTy ) import TysWiredIn ( addrTy, boolTy, charTy, stringTy, mkListTy, - mkTupleTy, mkPrimIoTy + mkTupleTy, mkPrimIoTy, stDataCon ) import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) import Unique ( Unique, cCallableClassKey, cReturnableClassKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromThenToClassOpKey, - thenMClassOpKey, zeroClassOpKey + thenMClassOpKey, zeroClassOpKey, returnMClassOpKey ) ---import Name ( Name ) -- Instance import Outputable ( interpp'SP ) import PprType ( GenType, GenTyVar ) -- Instances import Maybes ( maybeToBool ) @@ -187,9 +186,9 @@ tcExpr (HsApp e1 e2) = accum e1 [e2] returnTc (foldl HsApp fun' args', lie, res_ty) -- equivalent to (op e1) e2: -tcExpr (OpApp arg1 op arg2) +tcExpr (OpApp arg1 op fix arg2) = tcApp op [arg1,arg2] `thenTc` \ (op', [arg1', arg2'], lie, res_ty) -> - returnTc (OpApp arg1' op' arg2', lie, res_ty) + returnTc (OpApp arg1' op' fix arg2', lie, res_ty) \end{code} Note that the operators in sections are expected to be binary, and @@ -229,7 +228,7 @@ tcExpr in_expr@(SectionR op expr) newTyVarTy mkTypeKind `thenNF_Tc` \ ty1 -> newTyVarTy mkTypeKind `thenNF_Tc` \ ty2 -> tcAddErrCtxt (sectionRAppCtxt in_expr) $ - unifyTauTy op_ty (mkFunTys [ty1, expr_ty] ty2) `thenTc_` + unifyTauTy (mkFunTys [ty1, expr_ty] ty2) op_ty `thenTc_` returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2) \end{code} @@ -269,7 +268,9 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s -> newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) -> - returnTc (CCall lbl args' may_gc is_asm result_ty, + returnTc (HsApp (HsVar (RealId stDataCon) `TyApp` [realWorldTy, result_ty]) + (CCall lbl args' may_gc is_asm result_ty), + -- do the wrapping in the newtype constructor here foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie, mkPrimIoTy result_ty) \end{code} @@ -302,7 +303,7 @@ tcExpr (HsIf pred b1 b2 src_loc) tcExpr pred `thenTc` \ (pred',lie1,predTy) -> tcAddErrCtxt (predCtxt pred) ( - unifyTauTy predTy boolTy + unifyTauTy boolTy predTy ) `thenTc_` tcExpr b1 `thenTc` \ (b1',lie2,result_ty) -> @@ -312,15 +313,11 @@ tcExpr (HsIf pred b1 b2 src_loc) unifyTauTy result_ty b2Ty `thenTc_` returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3), result_ty) - -tcExpr (ListComp expr quals) - = tcListComp expr quals `thenTc` \ ((expr',quals'), lie, ty) -> - returnTc (ListComp expr' quals', lie, ty) \end{code} \begin{code} -tcExpr expr@(HsDo stmts src_loc) - = tcDoStmts stmts src_loc +tcExpr expr@(HsDo do_or_lc stmts src_loc) + = tcDoStmts do_or_lc stmts src_loc \end{code} \begin{code} @@ -375,7 +372,8 @@ tcExpr (RecordUpd record_expr rbinds) -- Check that the field names are plausible zonkTcType record_ty `thenNF_Tc` \ record_ty' -> let - (tycon, inst_tys, data_cons) = _trace "TcExpr.getAppDataTyCon" $ getAppDataTyCon record_ty' + (tycon, inst_tys, data_cons) = --trace "TcExpr.getAppDataTyCon" $ + getAppDataTyCon record_ty' -- The record binds are non-empty (syntax); so at least one field -- label will have been unified with record_ty by tcRecordBinds; -- field labels must be of data type; hencd the getAppDataTyCon must succeed. @@ -460,7 +458,7 @@ tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) \begin{code} tcExpr in_expr@(ExprWithTySig expr poly_ty) = tcExpr expr `thenTc` \ (texpr, lie, tau_ty) -> - tcPolyType poly_ty `thenTc` \ sigma_sig -> + tcHsType poly_ty `thenTc` \ sigma_sig -> -- Check the tau-type part tcSetErrCtxt (exprSigCtxt in_expr) $ @@ -468,7 +466,7 @@ tcExpr in_expr@(ExprWithTySig expr poly_ty) let (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig' in - unifyTauTy tau_ty sig_tau' `thenTc_` + unifyTauTy sig_tau' tau_ty `thenTc_` -- Check the type variables of the signature checkSigTyVars sig_tyvars' sig_tau' `thenTc_` @@ -571,16 +569,15 @@ tcArg expected_arg_ty arg -- To ensure that the forall'd type variables don't get unified with each -- other or any other types, we make fresh *signature* type variables -- and unify them with the tyvars. + tcInstSigTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) -> let - (expected_tyvars, expected_theta, expected_tau) = splitSigmaTy expected_arg_ty + (sig_theta, sig_tau) = splitRhoTy sig_rho in - ASSERT( null expected_theta ) -- And expected_tyvars are all DontBind things - tcInstSigTyVars expected_tyvars `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) -> - unifyTauTyLists (mkTyVarTys expected_tyvars) sig_tyvar_tys `thenTc_` + ASSERT( null sig_theta ) -- And expected_tyvars are all DontBind things -- Type-check the arg and unify with expected type tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) -> - unifyTauTy expected_tau actual_arg_ty `thenTc_` ( + unifyTauTy sig_tau actual_arg_ty `thenTc_` -- Check that the arg_tyvars havn't been constrained -- The interesting bit here is that we must include the free variables @@ -593,22 +590,22 @@ tcArg expected_arg_ty arg -- Conclusion: include the free vars of the expected arg type in the -- list of "free vars" for the signature check. - tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $ - checkSigTyVarsGivenGlobals - (tyVarsOfType expected_arg_ty) - expected_tyvars expected_tau `thenTc_` - - -- Check that there's no overloading involved - -- Even if there isn't, there may be some Insts which mention the expected_tyvars, - -- but which, on simplification, don't actually need a dictionary involving - -- the tyvar. So we have to do a proper simplification right here. - tcSimplifyRank2 (mkTyVarSet expected_tyvars) - lie_arg `thenTc` \ (free_insts, inst_binds) -> - - -- This HsLet binds any Insts which came out of the simplification. - -- It's a bit out of place here, but using AbsBind involves inventing - -- a couple of new names which seems worse. - returnTc (TyLam expected_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts) + tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) ( + tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) ( + checkSigTyVars sig_tyvars sig_tau + ) `thenTc_` + + -- Check that there's no overloading involved + -- Even if there isn't, there may be some Insts which mention the expected_tyvars, + -- but which, on simplification, don't actually need a dictionary involving + -- the tyvar. So we have to do a proper simplification right here. + tcSimplifyRank2 (mkTyVarSet sig_tyvars) + lie_arg `thenTc` \ (free_insts, inst_binds) -> + + -- This HsLet binds any Insts which came out of the simplification. + -- It's a bit out of place here, but using AbsBind involves inventing + -- a couple of new names which seems worse. + returnTc (TyLam sig_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts) ) where @@ -625,7 +622,7 @@ tcArg expected_arg_ty arg %************************************************************************ \begin{code} -tcId :: RnName -> NF_TcM s (TcExpr s, LIE s, TcType s) +tcId :: Name -> NF_TcM s (TcExpr s, LIE s, TcType s) tcId name = -- Look up the Id and instantiate its type @@ -669,72 +666,12 @@ tcId name %************************************************************************ %* * -\subsection{@tcQuals@ typechecks list-comprehension qualifiers} -%* * -%************************************************************************ - -\begin{code} -tcListComp expr [] - = tcExpr expr `thenTc` \ (expr', lie, ty) -> - returnTc ((expr',[]), lie, mkListTy ty) - -tcListComp expr (qual@(FilterQual filter) : quals) - = tcAddErrCtxt (qualCtxt qual) ( - tcExpr filter `thenTc` \ (filter', filter_lie, filter_ty) -> - unifyTauTy boolTy filter_ty `thenTc_` - returnTc (FilterQual filter', filter_lie) - ) `thenTc` \ (qual', qual_lie) -> - - tcListComp expr quals `thenTc` \ ((expr',quals'), rest_lie, res_ty) -> - - returnTc ((expr', qual' : quals'), - qual_lie `plusLIE` rest_lie, - res_ty) - -tcListComp expr (qual@(GeneratorQual pat rhs) : quals) - = newMonoIds binder_names mkBoxedTypeKind (\ ids -> - - tcAddErrCtxt (qualCtxt qual) ( - tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) -> - tcExpr rhs `thenTc` \ (rhs', lie_rhs, rhs_ty) -> - -- NB: the environment has been extended with the new binders - -- which the rhs can't "see", but the renamer should have made - -- sure that everything is distinct by now, so there's no problem. - -- Putting the tcExpr before the newMonoIds messes up the nesting - -- of error contexts, so I didn't bother - - unifyTauTy (mkListTy pat_ty) rhs_ty `thenTc_` - returnTc (GeneratorQual pat' rhs', - lie_pat `plusLIE` lie_rhs) - ) `thenTc` \ (qual', lie_qual) -> - - tcListComp expr quals `thenTc` \ ((expr',quals'), lie_rest, res_ty) -> - - returnTc ((expr', qual' : quals'), - lie_qual `plusLIE` lie_rest, - res_ty) - ) - where - binder_names = collectPatBinders pat - -tcListComp expr (LetQual binds : quals) - = tcBindsAndThen -- No error context, but a binding group is - combine -- rather a large thing for an error context anyway - binds - (tcListComp expr quals) - where - combine binds' (expr',quals') = (expr', LetQual binds' : quals') -\end{code} - - -%************************************************************************ -%* * \subsection{@tcDoStmts@ typechecks a {\em list} of do statements} %* * %************************************************************************ \begin{code} -tcDoStmts stmts src_loc +tcDoStmts do_or_lc stmts src_loc = -- get the Monad and MonadZero classes -- create type consisting of a fresh monad tyvar tcAddSrcLoc src_loc $ @@ -742,55 +679,80 @@ tcDoStmts stmts src_loc -- Build the then and zero methods in case we need them + tcLookupGlobalValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id -> tcLookupGlobalValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id -> tcLookupGlobalValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id -> newMethod DoOrigin - (RealId then_sel_id) [m] `thenNF_Tc` \ (m_lie, then_id) -> + (RealId return_sel_id) [m] `thenNF_Tc` \ (return_lie, return_id) -> + newMethod DoOrigin + (RealId then_sel_id) [m] `thenNF_Tc` \ (then_lie, then_id) -> newMethod DoOrigin - (RealId zero_sel_id) [m] `thenNF_Tc` \ (mz_lie, zero_id) -> + (RealId zero_sel_id) [m] `thenNF_Tc` \ (zero_lie, zero_id) -> let - get_m_arg ty - = newTyVarTy mkTypeKind `thenNF_Tc` \ arg_ty -> - unifyTauTy (mkAppTy m arg_ty) ty `thenTc_` - returnTc arg_ty - - go [stmt@(ExprStmt exp src_loc)] - = tcAddSrcLoc src_loc $ - tcSetErrCtxt (stmtCtxt stmt) $ - tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) -> - returnTc ([ExprStmt exp' src_loc], exp_lie, exp_ty) + -- go :: [RenamedStmt] -> TcM s ([TcStmt s], LIE s, TcType s) + go [stmt@(ReturnStmt exp)] -- Must be last statement + = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } ) + tcSetErrCtxt (stmtCtxt do_or_lc stmt) $ + tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) -> + returnTc ([ReturnStmt exp'], return_lie `plusLIE` exp_lie, mkAppTy m exp_ty) + + go (stmt@(GuardStmt exp src_loc) : stmts) + = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } ) + tcAddSrcLoc src_loc ( + tcSetErrCtxt (stmtCtxt do_or_lc stmt) ( + tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) -> + unifyTauTy boolTy exp_ty `thenTc_` + returnTc (GuardStmt exp' src_loc, exp_lie) + )) `thenTc` \ (stmt', stmt_lie) -> + go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) -> + returnTc (stmt' : stmts', + stmt_lie `plusLIE` stmts_lie `plusLIE` zero_lie, + stmts_ty) + go (stmt@(ExprStmt exp src_loc) : stmts) - = tcAddSrcLoc src_loc ( - tcSetErrCtxt (stmtCtxt stmt) ( + = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False } ) + tcAddSrcLoc src_loc ( + tcSetErrCtxt (stmtCtxt do_or_lc stmt) ( tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) -> - get_m_arg exp_ty `thenTc` \ a -> - returnTc (a, exp', exp_lie) - )) `thenTc` \ (a, exp', exp_lie) -> + -- Check that exp has type (m tau) for some tau (doesn't matter what) + newTyVarTy mkTypeKind `thenNF_Tc` \ tau -> + unifyTauTy (mkAppTy m tau) exp_ty `thenTc_` + returnTc (ExprStmt exp' src_loc, exp_lie, exp_ty, exp_ty) + )) `thenTc` \ (stmt', stmt_lie, stmt_ty, result_ty) -> + if null stmts then + -- This is the last statement + returnTc ([stmt'], stmt_lie, result_ty) + else + -- More statments follow go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) -> - get_m_arg stmts_ty `thenTc` \ b -> - returnTc (ExprStmtOut exp' src_loc a b : stmts', - exp_lie `plusLIE` stmts_lie `plusLIE` m_lie, + returnTc (stmt' : stmts', + stmt_lie `plusLIE` stmts_lie `plusLIE` then_lie, stmts_ty) go (stmt@(BindStmt pat exp src_loc) : stmts) = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ -> tcAddSrcLoc src_loc ( - tcSetErrCtxt (stmtCtxt stmt) ( + tcSetErrCtxt (stmtCtxt do_or_lc stmt) ( tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) -> tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) -> - -- See comments with tcListComp on GeneratorQual + unifyTauTy (mkAppTy m pat_ty) exp_ty `thenTc_` + + -- NB: the environment has been extended with the new binders + -- which the rhs can't "see", but the renamer should have made + -- sure that everything is distinct by now, so there's no problem. + -- Putting the tcExpr before the newMonoIds messes up the nesting + -- of error contexts, so I didn't bother + + returnTc (BindStmt pat' exp' src_loc, pat', pat_lie `plusLIE` exp_lie) + )) `thenTc` \ (stmt', pat', stmt_lie) -> - get_m_arg exp_ty `thenTc` \ a -> - unifyTauTy a pat_ty `thenTc_` - returnTc (a, pat', exp', pat_lie `plusLIE` exp_lie) - )) `thenTc` \ (a, pat', exp', stmt_lie) -> go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) -> - get_m_arg stmts_ty `thenTc` \ b -> - returnTc (BindStmtOut pat' exp' src_loc a b : stmts', - stmt_lie `plusLIE` stmts_lie `plusLIE` m_lie `plusLIE` - (if failureFreePat pat' then emptyLIE else mz_lie), + + returnTc (stmt' : stmts', + stmt_lie `plusLIE` stmts_lie `plusLIE` then_lie `plusLIE` + (if failureFreePat pat' then emptyLIE else zero_lie), stmts_ty) go (LetStmt binds : stmts) @@ -802,12 +764,18 @@ tcDoStmts stmts src_loc combine binds' stmts' = LetStmt binds' : stmts' in - go stmts `thenTc` \ (stmts', final_lie, final_ty) -> - returnTc (HsDoOut stmts' then_id zero_id src_loc, + go stmts `thenTc` \ (stmts', final_lie, result_ty) -> + returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id result_ty src_loc, final_lie, - final_ty) + result_ty) \end{code} +%************************************************************************ +%* * +\subsection{Record bindings} +%* * +%************************************************************************ + Game plan for record bindings ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For each binding @@ -899,69 +867,70 @@ pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff) Boring and alphabetical: \begin{code} arithSeqCtxt expr sty - = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr) + = ppHang (ppPStr SLIT("In an arithmetic sequence:")) 4 (ppr sty expr) branchCtxt b1 b2 sty - = ppSep [ppStr "In the branches of a conditional:", + = ppSep [ppPStr SLIT("In the branches of a conditional:"), pp_nest_hang "`then' branch:" (ppr sty b1), pp_nest_hang "`else' branch:" (ppr sty b2)] caseCtxt expr sty - = ppHang (ppStr "In a case expression:") 4 (ppr sty expr) + = ppHang (ppPStr SLIT("In a case expression:")) 4 (ppr sty expr) exprSigCtxt expr sty - = ppHang (ppStr "In an expression with a type signature:") + = ppHang (ppPStr SLIT("In an expression with a type signature:")) 4 (ppr sty expr) listCtxt expr sty - = ppHang (ppStr "In a list expression:") 4 (ppr sty expr) + = ppHang (ppPStr SLIT("In a list expression:")) 4 (ppr sty expr) predCtxt expr sty - = ppHang (ppStr "In a predicate expression:") 4 (ppr sty expr) + = ppHang (ppPStr SLIT("In a predicate expression:")) 4 (ppr sty expr) sectionRAppCtxt expr sty - = ppHang (ppStr "In a right section:") 4 (ppr sty expr) + = ppHang (ppPStr SLIT("In a right section:")) 4 (ppr sty expr) sectionLAppCtxt expr sty - = ppHang (ppStr "In a left section:") 4 (ppr sty expr) + = ppHang (ppPStr SLIT("In a left section:")) 4 (ppr sty expr) funAppCtxt fun arg_no arg sty - = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of", ppr sty fun]) - 4 (ppCat [ppStr "namely", ppr sty arg]) + = ppHang (ppCat [ ppPStr SLIT("In the"), speakNth arg_no, ppPStr SLIT("argument of"), + ppr sty fun `ppBeside` ppStr ", namely"]) + 4 (pprParendExpr sty arg) -qualCtxt qual sty - = ppHang (ppStr "In a list-comprehension qualifer:") - 4 (ppr sty qual) +stmtCtxt ListComp stmt sty + = ppHang (ppPStr SLIT("In a list-comprehension qualifer:")) + 4 (ppr sty stmt) -stmtCtxt stmt sty - = ppHang (ppStr "In a do statement:") +stmtCtxt DoStmt stmt sty + = ppHang (ppPStr SLIT("In a do statement:")) 4 (ppr sty stmt) tooManyArgsCtxt f sty - = ppHang (ppStr "Too many arguments in an application of the function") + = ppHang (ppPStr SLIT("Too many arguments in an application of the function")) 4 (ppr sty f) lurkingRank2Err fun fun_ty sty - = ppHang (ppCat [ppStr "Illegal use of", ppr sty fun]) + = ppHang (ppCat [ppPStr SLIT("Illegal use of"), ppr sty fun]) 4 (ppAboves [ppStr "It is applied to too few arguments,", - ppStr "so that the result type has for-alls in it"]) + ppPStr SLIT("so that the result type has for-alls in it")]) rank2ArgCtxt arg expected_arg_ty sty - = ppHang (ppStr "In a polymorphic function argument:") - 4 (ppSep [ppBeside (ppr sty arg) (ppStr " ::"), + = ppHang (ppPStr SLIT("In a polymorphic function argument:")) + 4 (ppSep [ppBeside (ppr sty arg) (ppPStr SLIT(" ::")), ppr sty expected_arg_ty]) badFieldsUpd rbinds sty - = ppHang (ppStr "No constructor has all these fields:") + = ppHang (ppPStr SLIT("No constructor has all these fields:")) 4 (interpp'SP sty fields) where fields = [field | (field, _, _) <- rbinds] -recordUpdCtxt sty = ppStr "In a record update construct" +recordUpdCtxt sty = ppPStr SLIT("In a record update construct") badFieldsCon con rbinds sty - = ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con]) - 4 (ppBesides [ppStr "and fields:", interpp'SP sty fields]) + = ppHang (ppBesides [ppPStr SLIT("Inconsistent constructor:"), ppr sty con]) + 4 (ppBesides [ppPStr SLIT("and fields:"), interpp'SP sty fields]) where fields = [field | (field, _, _) <- rbinds] \end{code}