X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=becc2d6104aa9ac3c62e22eb13a0aec928c245e2;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=0bf3c314c482c8995d6b8779ac8e49820b35335c;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 0bf3c31..becc2d6 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -1,66 +1,55 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[TcPat]{Typechecking patterns} \begin{code} #include "HsVersions.h" -module TcPat ( - tcPat -#ifdef DPH - , tcPats -#endif - ) where - -import TcMonad -- typechecking monad machinery -import TcMonadFns ( newOpenTyVarTy, newPolyTyVarTy, - newPolyTyVarTys, copyTyVars, newMethod, - newOverloadedLit - ) -import AbsSyn -- the stuff being typechecked - -import AbsPrel ( charPrimTy, intPrimTy, floatPrimTy, - doublePrimTy, charTy, stringTy, mkListTy, - mkTupleTy, addrTy, addrPrimTy, --OLD: eqStringId - PrimOp - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) -#ifdef DPH - ,mkProcessorTy, toDomainId -#endif {- Data Parallel Haskell -} - ) -import AbsUniType ( instantiateTauTy, applyTyCon, InstTyEnv(..) - IF_ATTACK_PRAGMAS(COMMA instantiateTy) - ) -import CmdLineOpts ( GlobalSwitch(..) ) -import Id ( mkInstId, getIdUniType, getDataConSig, - getInstantiatedDataConSig, Id, DataCon(..) +module TcPat ( tcPat ) where + +IMP_Ubiq(){-uitous-} + +import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..), + Match, HsBinds, Qualifier, PolyType, + ArithSeqInfo, Stmt, Fake ) +import RnHsSyn ( SYN_IE(RenamedPat), RnName{-instance Outputable-} ) +import TcHsSyn ( SYN_IE(TcPat), TcIdOcc(..) ) + +import TcMonad hiding ( rnMtoTcM ) +import Inst ( Inst, OverloadedLit(..), InstOrigin(..), + emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE), + newMethod, newOverloadedLit ) -import Inst -import E ( lookupE_Binder, lookupE_Value, - lookupE_ClassOpByKey, E, - LVE(..), TCE(..), UniqFM, CE(..) - -- TCE and CE for pragmas only +import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey, + tcLookupLocalValueOK ) +import SpecEnv ( SpecEnv ) +import TcType ( SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId ) +import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) + +import Bag ( Bag ) +import CmdLineOpts ( opt_IrrefutableTuples ) +import Id ( GenId, idType ) +import Kind ( Kind, mkBoxedTypeKind, mkTypeKind ) +import Maybes ( maybeToBool ) +import PprType ( GenType, GenTyVar ) +--import PprStyle--ToDo:rm +import Pretty +import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys, + getFunTy_maybe, maybeAppDataTyCon, + SYN_IE(Type), GenType ) -import Errors ( dataConArityErr, Error(..), UnifyErrContext(..) +import TyVar ( GenTyVar ) +import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, + doublePrimTy, addrPrimTy ) -import LIE ( nullLIE, plusLIE, mkLIE, LIE ) -import Unify -import Unique -- some ClassKey stuff -import Util - -#ifdef DPH -import TcParQuals -#endif {- Data Parallel Haskell -} +import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, addrTy ) +import Unique ( Unique, eqClassOpKey ) +import Util ( assertPanic, panic ) \end{code} -The E passed in already contains bindings for all the variables in -the pattern, usually to fresh type variables (but maybe not, if there -were type signatures present). - \begin{code} -tcPat :: E -> RenamedPat -> TcM (TypecheckedPat, LIE, UniType) +tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s) \end{code} %************************************************************************ @@ -70,27 +59,34 @@ tcPat :: E -> RenamedPat -> TcM (TypecheckedPat, LIE, UniType) %************************************************************************ \begin{code} -tcPat e (VarPatIn name) - = let - id = lookupE_Binder e name - in - returnTc (VarPat id, nullLIE, getIdUniType id) +tcPat (VarPatIn name) + = tcLookupLocalValueOK ("tcPat1:"{-++ppShow 80 (ppr PprDebug name)-}) name `thenNF_Tc` \ id -> + returnTc (VarPat (TcId id), emptyLIE, idType id) -tcPat e (LazyPatIn pat) - = tcPat e pat `thenTc` \ (pat', lie, ty) -> +tcPat (LazyPatIn pat) + = tcPat pat `thenTc` \ (pat', lie, ty) -> returnTc (LazyPat pat', lie, ty) -tcPat e pat_in@(AsPatIn name pat) - = let - id = lookupE_Binder e name - in - tcPat e pat `thenTc` \ (pat', lie, ty) -> - unifyTauTy (getIdUniType id) ty (PatCtxt pat_in) `thenTc_` - returnTc (AsPat id pat', lie, ty) +tcPat pat_in@(AsPatIn name pat) + = tcLookupLocalValueOK "tcPat2" name `thenNF_Tc` \ id -> + tcPat pat `thenTc` \ (pat', lie, ty) -> + tcAddErrCtxt (patCtxt pat_in) $ + unifyTauTy (idType id) ty `thenTc_` + returnTc (AsPat (TcId id) pat', lie, ty) + +tcPat WildPatIn + = newTyVarTy mkTypeKind `thenNF_Tc` \ tyvar_ty -> + returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty) -tcPat e (WildPatIn) - = newOpenTyVarTy `thenNF_Tc` \ tyvar_ty -> - returnTc (WildPat tyvar_ty, nullLIE, tyvar_ty) +tcPat (NegPatIn pat) + = tcPat (negate_lit pat) + where + negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i)) + negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f)) + negate_lit _ = panic "TcPat:negate_pat" + +tcPat (ParPatIn parend_pat) + = tcPat parend_pat \end{code} %************************************************************************ @@ -100,29 +96,27 @@ tcPat e (WildPatIn) %************************************************************************ \begin{code} -tcPat e pat_in@(ListPatIn pats) - = tcPats e pats `thenTc` \ (pats', lie, tys) -> - newPolyTyVarTy `thenNF_Tc` \ tyvar_ty -> - - unifyTauTyList (tyvar_ty:tys) (PatCtxt pat_in) `thenTc_` +tcPat pat_in@(ListPatIn pats) + = tcPats pats `thenTc` \ (pats', lie, tys) -> + newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty -> + tcAddErrCtxt (patCtxt pat_in) $ + unifyTauTyList (tyvar_ty:tys) `thenTc_` returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty) -tcPat e pat_in@(TuplePatIn pats) +tcPat pat_in@(TuplePatIn pats) = let arity = length pats in - tcPats e pats `thenTc` \ (pats', lie, tys) -> + tcPats pats `thenTc` \ (pats', lie, tys) -> - -- We have to unify with fresh polymorphic type variables, to - -- make sure we record that the tuples can only contain boxed - -- types. - newPolyTyVarTys arity `thenNF_Tc` \ tyvar_tys -> + -- Make sure we record that the tuples can only contain boxed types + newTyVarTys arity mkBoxedTypeKind `thenNF_Tc` \ tyvar_tys -> - unifyTauTyLists tyvar_tys tys (PatCtxt pat_in) `thenTc_` + tcAddErrCtxt (patCtxt pat_in) $ + unifyTauTyLists tyvar_tys tys `thenTc_` -- possibly do the "make all tuple-pats irrefutable" test: - getSwitchCheckerTc `thenNF_Tc` \ sw_chkr -> let unmangled_result = TuplePat pats' @@ -130,8 +124,9 @@ tcPat e pat_in@(TuplePatIn pats) -- so that we can experiment with lazy tuple-matching. -- This is a pretty odd place to make the switch, but -- it was easy to do. + possibly_mangled_result - = if sw_chkr IrrefutableTuples + = if opt_IrrefutableTuples then LazyPat unmangled_result else unmangled_result @@ -168,179 +163,145 @@ ToDo: exploit new representation of constructors to make this more efficient? \begin{code} -tcPat e pat_in@(ConPatIn name pats) - = let - con_id = lookupE_Value e name - in - tcPats e pats `thenTc` \ (pats', lie, tys) -> +tcPat pat_in@(ConPatIn name pats) + = tcPats pats `thenTc` \ (pats', lie, tys) -> - matchConArgTys con_id tys (\ ty -> PatCtxt pat_in) `thenTc` \ data_ty -> + tcAddErrCtxt (patCtxt pat_in) $ + matchConArgTys name tys `thenTc` \ (con_id, data_ty) -> - returnTc (ConPat con_id data_ty pats', lie, data_ty) + returnTc (ConPat con_id data_ty pats', + lie, + data_ty) -tcPat e pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form... - = let - con_id = lookupE_Value e op - in - tcPats e [pat1, pat2] `thenTc` \ ([pat1',pat2'], lie, tys) -> - -- ToDo: there exists a less ugly way, no doubt... +tcPat pat_in@(ConOpPatIn pat1 op pat2) -- in binary-op form... + = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) -> + tcPat pat2 `thenTc` \ (pat2', lie2, ty2) -> - matchConArgTys con_id tys (\ ty -> PatCtxt pat_in) `thenTc` \ data_ty -> + tcAddErrCtxt (patCtxt pat_in) $ + matchConArgTys op [ty1,ty2] `thenTc` \ (con_id, data_ty) -> - returnTc (ConOpPat pat1' con_id pat2' data_ty, lie, data_ty) + returnTc (ConOpPat pat1' con_id pat2' data_ty, + lie1 `plusLIE` lie2, + data_ty) \end{code} %************************************************************************ %* * -\subsection{Non-overloaded literals} +\subsection{Records} %* * %************************************************************************ \begin{code} -tcPat e (LitPatIn lit@(CharLit str)) - = returnTc (LitPat lit charTy, nullLIE, charTy) - -tcPat e (LitPatIn lit@(StringLit str)) - = getSrcLocTc `thenNF_Tc` \ loc -> - let - origin = LiteralOrigin lit loc - eq_id = lookupE_ClassOpByKey e eqClassKey SLIT("==") - in - newMethod origin eq_id [stringTy] `thenNF_Tc` \ eq -> +tcPat pat_in@(RecPatIn name rpats) + = tcLookupGlobalValue name `thenNF_Tc` \ con_id -> + tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) -> let - comp_op = App (Var (mkInstId eq)) (Lit lit) + -- Ignore the con_theta; overloaded constructors only + -- behave differently when called, not when used for + -- matching. + (_, record_ty) = splitFunTy con_tau in - returnTc (NPat lit stringTy comp_op, mkLIE [eq], stringTy) + -- Con is syntactically constrained to be a data constructor + ASSERT( maybeToBool (maybeAppDataTyCon record_ty) ) + + mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) -> + + returnTc (RecPat con_id record_ty rpats', + plusLIEs lies, + record_ty) -{- OLD: -tcPat e (LitPatIn lit@(StringLit str)) - = returnTc (NPat lit stringTy comp_op, nullLIE, stringTy) where - comp_op = App (Var eqStringId) (Lit lit) --} - -tcPat e (LitPatIn lit@(IntPrimLit _)) - = returnTc (LitPat lit intPrimTy, nullLIE, intPrimTy) -tcPat e (LitPatIn lit@(CharPrimLit _)) - = returnTc (LitPat lit charPrimTy, nullLIE, charPrimTy) -tcPat e (LitPatIn lit@(StringPrimLit _)) - = returnTc (LitPat lit addrPrimTy, nullLIE, addrPrimTy) -tcPat e (LitPatIn lit@(FloatPrimLit _)) - = returnTc (LitPat lit floatPrimTy, nullLIE, floatPrimTy) -tcPat e (LitPatIn lit@(DoublePrimLit _)) - = returnTc (LitPat lit doublePrimTy, nullLIE, doublePrimTy) + do_bind expected_record_ty (field_label, rhs_pat, pun_flag) + = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id -> + tcInstId sel_id `thenNF_Tc` \ (_, _, tau) -> + + -- Record selectors all have type + -- forall a1..an. T a1 .. an -> tau + ASSERT( maybeToBool (getFunTy_maybe tau) ) + let + -- Selector must have type RecordType -> FieldType + Just (record_ty, field_ty) = getFunTy_maybe tau + in + tcAddErrCtxt (recordLabel field_label) ( + unifyTauTy expected_record_ty record_ty + ) `thenTc_` + tcPat rhs_pat `thenTc` \ (rhs_pat', lie, rhs_ty) -> + tcAddErrCtxt (recordRhs field_label rhs_pat) ( + unifyTauTy field_ty rhs_ty + ) `thenTc_` + returnTc ((sel_id, rhs_pat', pun_flag), lie) \end{code} %************************************************************************ %* * -\subsection{Overloaded patterns: int literals and \tr{n+k} patterns} +\subsection{Non-overloaded literals} %* * %************************************************************************ \begin{code} -tcPat e (LitPatIn lit@(IntLit i)) - = getSrcLocTc `thenNF_Tc` \ loc -> - let - origin = LiteralOrigin lit loc - in - newPolyTyVarTy `thenNF_Tc` \ tyvar_ty -> +tcPat (LitPatIn lit@(HsChar str)) + = returnTc (LitPat lit charTy, emptyLIE, charTy) + +tcPat (LitPatIn lit@(HsString str)) + = tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ sel_id -> + newMethod (LiteralOrigin lit) + (RealId sel_id) [stringTy] `thenNF_Tc` \ (lie, eq_id) -> let - from_int = lookupE_ClassOpByKey e numClassKey SLIT("fromInt") - from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger") - eq_id = lookupE_ClassOpByKey e eqClassKey SLIT("==") + comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy) in - newOverloadedLit origin - (OverloadedIntegral i from_int from_integer) - tyvar_ty `thenNF_Tc` \ over_lit -> - - newMethod origin eq_id [tyvar_ty] `thenNF_Tc` \ eq -> + returnTc (NPat lit stringTy comp_op, lie, stringTy) + +tcPat (LitPatIn lit@(HsIntPrim _)) + = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy) +tcPat (LitPatIn lit@(HsCharPrim _)) + = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy) +tcPat (LitPatIn lit@(HsStringPrim _)) + = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy) +tcPat (LitPatIn lit@(HsFloatPrim _)) + = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy) +tcPat (LitPatIn lit@(HsDoublePrim _)) + = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy) +\end{code} - returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq)) - (Var (mkInstId over_lit))), - mkLIE [over_lit, eq], - tyvar_ty) +%************************************************************************ +%* * +\subsection{Overloaded patterns: int literals and \tr{n+k} patterns} +%* * +%************************************************************************ -tcPat e (LitPatIn lit@(FracLit f)) - = getSrcLocTc `thenNF_Tc` \ loc -> - let - origin = LiteralOrigin lit loc - in - newPolyTyVarTy `thenNF_Tc` \ tyvar_ty -> - let - eq_id = lookupE_ClassOpByKey e eqClassKey SLIT("==") - from_rational = lookupE_ClassOpByKey e fractionalClassKey SLIT("fromRational") - in - newOverloadedLit origin - (OverloadedFractional f from_rational) - tyvar_ty `thenNF_Tc` \ over_lit -> +\begin{code} +tcPat (LitPatIn lit@(HsInt i)) + = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty -> + newOverloadedLit origin + (OverloadedIntegral i) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) -> - newMethod origin eq_id [tyvar_ty] `thenNF_Tc` \ eq -> + tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id -> + newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) -> - returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq)) - (Var (mkInstId over_lit))), - mkLIE [over_lit, eq], + returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id) + (HsVar over_lit_id)), + lie1 `plusLIE` lie2, tyvar_ty) + where + origin = LiteralOrigin lit -tcPat e (LitPatIn lit@(LitLitLitIn s)) - = error "tcPat: can't handle ``literal-literal'' patterns" -{- - = getSrcLocTc `thenNF_Tc` \ loc -> - let - origin = LiteralOrigin lit loc - in - newPolyTyVarTy `thenNF_Tc` \ tyvar_ty -> - let - eq_id = lookupE_ClassOpByKey e eqClassKey "==" - in +tcPat (LitPatIn lit@(HsFrac f)) + = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty -> newOverloadedLit origin - (OverloadedLitLit s) - tyvar_ty `thenNF_Tc` \ over_lit -> + (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) -> - newMethod origin eq_id [tyvar_ty] `thenNF_Tc` \ eq -> + tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id -> + newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) -> - returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq)) - (Var (mkInstId over_lit))), - mkLIE [over_lit, eq], + returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id) + (HsVar over_lit_id)), + lie1 `plusLIE` lie2, tyvar_ty) --} - -tcPat e (NPlusKPatIn name lit@(IntLit k)) - = getSrcLocTc `thenNF_Tc` \ loc -> - let - origin = LiteralOrigin lit loc - - local = lookupE_Binder e name - local_ty = getIdUniType local + where + origin = LiteralOrigin lit - ge_id = lookupE_ClassOpByKey e ordClassKey SLIT(">=") - minus_id = lookupE_ClassOpByKey e numClassKey SLIT("-") - from_int = lookupE_ClassOpByKey e numClassKey SLIT("fromInt") - from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger") - in - newOverloadedLit origin - (OverloadedIntegral k from_int from_integer) - local_ty `thenNF_Tc` \ over_lit -> - - newMethod origin ge_id [local_ty] `thenNF_Tc` \ ge -> - newMethod origin minus_id [local_ty] `thenNF_Tc` \ minus -> - - returnTc (NPlusKPat local lit local_ty - (Var (mkInstId over_lit)) - (Var (mkInstId ge)) - (Var (mkInstId minus)), - mkLIE [over_lit, ge, minus], - local_ty) - -tcPat e (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an IntLit" - -#ifdef DPH -tcPat e (ProcessorPatIn pats pat) - = tcPidPats e pats `thenTc` \ (pats',convs, lie, tys)-> - tcPat e pat `thenTc` \ (pat', ty, lie') -> - returnTc (ProcessorPat pats' convs pat', - plusLIE lie lie', - mkProcessorTy tys ty) -#endif {- Data Parallel Haskell -} +tcPat (LitPatIn lit@(HsLitLit s)) + = error "tcPat: can't handle ``literal-literal'' patterns" \end{code} %************************************************************************ @@ -350,13 +311,13 @@ tcPat e (ProcessorPatIn pats pat) %************************************************************************ \begin{code} -tcPats :: E -> [RenamedPat] -> TcM ([TypecheckedPat], LIE, [UniType]) +tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s]) -tcPats e [] = returnTc ([], nullLIE, []) +tcPats [] = returnTc ([], emptyLIE, []) -tcPats e (pat:pats) - = tcPat e pat `thenTc` \ (pat', lie, ty) -> - tcPats e pats `thenTc` \ (pats', lie', tys) -> +tcPats (pat:pats) + = tcPat pat `thenTc` \ (pat', lie, ty) -> + tcPats pats `thenTc` \ (pats', lie', tys) -> returnTc (pat':pats', plusLIE lie lie', ty:tys) \end{code} @@ -365,25 +326,39 @@ tcPats e (pat:pats) unifies the actual args against the expected ones. \begin{code} -matchConArgTys :: Id -> [UniType] -> (UniType -> UnifyErrContext) -> TcM UniType +matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s) -matchConArgTys con_id arg_tys err_ctxt - = let - no_of_args = length arg_tys - (sig_tyvars, sig_theta, sig_tys, _) = getDataConSig con_id - -- Ignore the sig_theta; overloaded constructors only +matchConArgTys con arg_tys + = tcLookupGlobalValue con `thenNF_Tc` \ con_id -> + tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) -> + -- Ignore the con_theta; overloaded constructors only -- behave differently when called, not when used for -- matching. - con_arity = length sig_tys + let + (con_args, con_result) = splitFunTy con_tau + con_arity = length con_args + no_of_args = length arg_tys in - getSrcLocTc `thenNF_Tc` \ loc -> - checkTc (con_arity /= no_of_args) - (dataConArityErr con_id con_arity no_of_args loc) `thenTc_` + checkTc (con_arity == no_of_args) + (arityErr "Constructor" con_id con_arity no_of_args) `thenTc_` - copyTyVars sig_tyvars `thenNF_Tc` \ (inst_env, _, new_tyvar_tys) -> - let - (_,inst_arg_tys,inst_result_ty) = getInstantiatedDataConSig con_id new_tyvar_tys - in - unifyTauTyLists arg_tys inst_arg_tys (err_ctxt inst_result_ty) `thenTc_` - returnTc inst_result_ty + unifyTauTyLists con_args arg_tys `thenTc_` + returnTc (con_id, con_result) +\end{code} + + +% ================================================= + +Errors and contexts +~~~~~~~~~~~~~~~~~~~ +\begin{code} +patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat) + +recordLabel field_label sty + = ppHang (ppBesides [ppStr "When matching record field", ppr sty field_label]) + 4 (ppBesides [ppStr "with its immediately enclosing constructor"]) + +recordRhs field_label pat sty + = ppHang (ppStr "In the record field pattern") + 4 (ppSep [ppr sty field_label, ppStr "=", ppr sty pat]) \end{code}