%
-% (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}
%************************************************************************
%************************************************************************
\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}
%************************************************************************
%************************************************************************
\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'
-- 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
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}
%************************************************************************
%************************************************************************
\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}
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}
projects / ghc-hetmet.git / blobdiff