X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=24cc1dedcfd7ae60ed27737fe8e7362ccd0fe870;hb=f714e6b642fd614a9971717045ae47c3d871275e;hp=4b2241cd82a136ab92d95d863cd1768904f1e112;hpb=7d474ff607ee01ebb91081fc57c96b2d6ba05861;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 4b2241c..24cc1de 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -1,128 +1,206 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcPat]{Typechecking patterns} \begin{code} -#include "HsVersions.h" - -module TcPat ( tcPat ) where +module TcPat ( tcPat, tcMonoPatBndr, tcSubPat, + badFieldCon, polyPatSig + ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..), - Match, HsBinds, HsType, Fixity, - ArithSeqInfo, Stmt, DoOrListComp, Fake ) -import RnHsSyn ( SYN_IE(RenamedPat) ) -import TcHsSyn ( SYN_IE(TcPat), TcIdOcc(..) ) +import HsSyn ( Pat(..), LPat, HsConDetails(..), HsLit(..), HsOverLit(..), HsExpr(..) ) +import HsUtils +import TcHsSyn ( TcId, hsLitType, + mkCoercion, idCoercion, isIdCoercion, + (<$>), PatCoFn ) -import TcMonad -import Inst ( Inst, OverloadedLit(..), InstOrigin(..), - emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE), - newMethod, newOverloadedLit +import TcRnMonad +import Inst ( InstOrigin(..), + newMethodFromName, newOverloadedLit, newDicts, + instToId, tcInstDataCon, tcSyntaxName ) -import Name ( Name {- instance Outputable -} ) -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 Id ( idType, mkLocalId, mkSysLocal ) +import Name ( Name ) +import FieldLabel ( fieldLabelName ) +import TcEnv ( tcLookupClass, tcLookupLocatedDataCon, tcLookupId ) +import TcMType ( newTyVarTy, arityErr ) +import TcType ( TcType, TcTyVar, TcSigmaType, mkClassPred ) +import Kind ( argTypeKind, liftedTypeKind ) +import TcUnify ( tcSubOff, Expected(..), readExpectedType, zapExpectedType, + unifyTauTy, zapToListTy, zapToPArrTy, zapToTupleTy ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) + +import TysWiredIn ( stringTy ) import CmdLineOpts ( opt_IrrefutableTuples ) -import Id ( GenId, idType, SYN_IE(Id) ) -import Kind ( Kind, mkBoxedTypeKind, mkTypeKind ) -import Maybes ( maybeToBool ) -import PprType ( GenType, GenTyVar ) -import Pretty -import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys, - getFunTy_maybe, maybeAppDataTyCon, - SYN_IE(Type), GenType - ) -import TyVar ( GenTyVar ) -import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, - doublePrimTy, addrPrimTy - ) -import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, addrTy ) -import Unique ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey ) -import Util ( assertPanic, panic ) - -#if __GLASGOW_HASKELL__ >= 202 +import DataCon ( DataCon, dataConFieldLabels, dataConSourceArity ) +import PrelNames ( eqStringName, eqName, geName, negateName, minusName, + integralClassName ) +import BasicTypes ( isBoxed ) +import SrcLoc ( Located(..), noLoc, unLoc ) +import Bag import Outputable -#endif +import FastString \end{code} + +%************************************************************************ +%* * +\subsection{Variable patterns} +%* * +%************************************************************************ + \begin{code} -tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s) +type BinderChecker = Name -> Expected TcSigmaType -> TcM (PatCoFn, TcId) + -- How to construct a suitable (monomorphic) + -- Id for variables found in the pattern + -- The TcSigmaType is the expected type + -- from the pattern context + +-- The Id may have a sigma type (e.g. f (x::forall a. a->a)) +-- so we want to *create* it during pattern type checking. +-- We don't want to make Ids first with a type-variable type +-- and then unify... becuase we can't unify a sigma type with a type variable. + +tcMonoPatBndr :: BinderChecker + -- This is the right function to pass to tcPat when + -- we're looking at a lambda-bound pattern, + -- so there's no polymorphic guy to worry about + +tcMonoPatBndr binder_name pat_ty + = zapExpectedType pat_ty argTypeKind `thenM` \ pat_ty' -> + -- If there are *no constraints* on the pattern type, we + -- revert to good old H-M typechecking, making + -- the type of the binder into an *ordinary* + -- type variable. We find out if there are no constraints + -- by seeing if we are given an "open hole" as our info. + -- What we are trying to avoid here is giving a binder + -- a type that is a 'hole'. The only place holes should + -- appear is as an argument to tcPat and tcExpr/tcMonoExpr. + + returnM (idCoercion, mkLocalId binder_name pat_ty') \end{code} + %************************************************************************ %* * -\subsection{Variables, wildcards, lazy pats, as-pats} +\subsection{Typechecking patterns} %* * %************************************************************************ \begin{code} -tcPat (VarPatIn name) - = tcLookupLocalValueOK ("tcPat1:"{-++show (ppr PprDebug name)-}) name `thenNF_Tc` \ id -> - returnTc (VarPat (TcId id), emptyLIE, idType id) - -tcPat (LazyPatIn pat) - = tcPat pat `thenTc` \ (pat', lie, ty) -> - returnTc (LazyPat 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 (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 +tcPat :: BinderChecker + -> LPat Name + + -> Expected TcSigmaType -- Expected type derived from the context + -- In the case of a function with a rank-2 signature, + -- this type might be a forall type. + + -> TcM (LPat TcId, + Bag TcTyVar, -- TyVars bound by the pattern + -- These are just the existentially-bound ones. + -- Any tyvars bound by *type signatures* in the + -- patterns are brought into scope before we begin. + Bag (Name, TcId), -- Ids bound by the pattern, along with the Name under + -- which it occurs in the pattern + -- The two aren't the same because we conjure up a new + -- local name for each variable. + [Inst]) -- Dicts or methods [see below] bound by the pattern + -- from existential constructor patterns +tcPat tc_bndr (L span pat) exp_ty + = addSrcSpan span $ + do { (pat', tvs, ids, lie) <- tc_pat tc_bndr pat exp_ty + ; return (L span pat', tvs, ids, lie) } \end{code} + %************************************************************************ %* * -\subsection{Explicit lists and tuples} +\subsection{Variables, wildcards, lazy pats, as-pats} %* * %************************************************************************ \begin{code} -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_` +tc_pat tc_bndr pat@(TypePat ty) pat_ty + = failWithTc (badTypePat pat) + +tc_pat tc_bndr (VarPat name) pat_ty + = tc_bndr name pat_ty `thenM` \ (co_fn, bndr_id) -> + returnM (co_fn <$> VarPat bndr_id, + emptyBag, unitBag (name, bndr_id), []) + +tc_pat tc_bndr (LazyPat pat) pat_ty + = tcPat tc_bndr pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) -> + returnM (LazyPat pat', tvs, ids, lie_avail) + +tc_pat tc_bndr pat_in@(AsPat (L nm_loc name) pat) pat_ty + = addSrcSpan nm_loc (tc_bndr name pat_ty) `thenM` \ (co_fn, bndr_id) -> + tcPat tc_bndr pat (Check (idType bndr_id)) `thenM` \ (pat', tvs, ids, lie_avail) -> + -- NB: if we have: + -- \ (y@(x::forall a. a->a)) = e + -- we'll fail. The as-pattern infers a monotype for 'y', which then + -- fails to unify with the polymorphic type for 'x'. This could be + -- fixed, but only with a bit more work. + returnM (co_fn <$> (AsPat (L nm_loc bndr_id) pat'), + tvs, (name, bndr_id) `consBag` ids, lie_avail) + +tc_pat tc_bndr (WildPat _) pat_ty + = zapExpectedType pat_ty argTypeKind `thenM` \ pat_ty' -> + -- We might have an incoming 'hole' type variable; no annotation + -- so zap it to a type. Rather like tcMonoPatBndr. + -- Note argTypeKind, so that + -- f _ = 3 + -- is rejected when f applied to an unboxed tuple + -- However, this means that + -- (case g x of _ -> ...) + -- is rejected g returns an unboxed tuple, which is perhpas + -- annoying. I suppose we could pass the context into tc_pat... + returnM (WildPat pat_ty', emptyBag, emptyBag, []) + +tc_pat tc_bndr (ParPat parend_pat) pat_ty +-- Leave the parens in, so that warnings from the +-- desugarer have parens in them + = tcPat tc_bndr parend_pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) -> + returnM (ParPat pat', tvs, ids, lie_avail) + +tc_pat tc_bndr pat_in@(SigPatIn pat sig) pat_ty + = addErrCtxt (patCtxt pat_in) $ + tcHsSigType PatSigCtxt sig `thenM` \ sig_ty -> + tcSubPat sig_ty pat_ty `thenM` \ co_fn -> + tcPat tc_bndr pat (Check sig_ty) `thenM` \ (pat', tvs, ids, lie_avail) -> + returnM (co_fn <$> unLoc pat', tvs, ids, lie_avail) +\end{code} - returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty) -tcPat pat_in@(TuplePatIn pats) - = let - arity = length pats - in - tcPats pats `thenTc` \ (pats', lie, tys) -> +%************************************************************************ +%* * +\subsection{Explicit lists, parallel arrays, and tuples} +%* * +%************************************************************************ - -- Make sure we record that the tuples can only contain boxed types - newTyVarTys arity mkBoxedTypeKind `thenNF_Tc` \ tyvar_tys -> +\begin{code} +tc_pat tc_bndr pat_in@(ListPat pats _) pat_ty + = addErrCtxt (patCtxt pat_in) $ + zapToListTy pat_ty `thenM` \ elem_ty -> + tcPats tc_bndr pats (repeat elem_ty) `thenM` \ (pats', tvs, ids, lie_avail) -> + returnM (ListPat pats' elem_ty, tvs, ids, lie_avail) + +tc_pat tc_bndr pat_in@(PArrPat pats _) pat_ty + = addErrCtxt (patCtxt pat_in) $ + zapToPArrTy pat_ty `thenM` \ elem_ty -> + tcPats tc_bndr pats (repeat elem_ty) `thenM` \ (pats', tvs, ids, lie_avail) -> + returnM (PArrPat pats' elem_ty, tvs, ids, lie_avail) + +tc_pat tc_bndr pat_in@(TuplePat pats boxity) pat_ty + = addErrCtxt (patCtxt pat_in) $ - tcAddErrCtxt (patCtxt pat_in) $ - unifyTauTyLists tyvar_tys tys `thenTc_` + zapToTupleTy boxity arity pat_ty `thenM` \ arg_tys -> + tcPats tc_bndr pats arg_tys `thenM` \ (pats', tvs, ids, lie_avail) -> -- possibly do the "make all tuple-pats irrefutable" test: let - unmangled_result = TuplePat pats' + unmangled_result = TuplePat pats' boxity -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) -- so that we can experiment with lazy tuple-matching. @@ -130,263 +208,298 @@ tcPat pat_in@(TuplePatIn pats) -- it was easy to do. possibly_mangled_result - = if opt_IrrefutableTuples - then LazyPat unmangled_result - else unmangled_result - - -- ToDo: IrrefutableEverything + | opt_IrrefutableTuples && isBoxed boxity = LazyPat (noLoc unmangled_result) + | otherwise = unmangled_result in - returnTc (possibly_mangled_result, lie, mkTupleTy arity tys) + returnM (possibly_mangled_result, tvs, ids, lie_avail) + where + arity = length pats \end{code} + %************************************************************************ %* * \subsection{Other constructors} %* * -%************************************************************************ -Constructor patterns are a little fun: -\begin{itemize} -\item -typecheck the arguments -\item -look up the constructor -\item -specialise its type (ignore the translation this produces) -\item -check that the context produced by this specialisation is empty -\item -get the arguments out of the function type produced from specialising -\item -unify them with the types of the patterns -\item -back substitute with the type of the result of the constructor -\end{itemize} - -ToDo: exploit new representation of constructors to make this more -efficient? +%************************************************************************ \begin{code} -tcPat pat_in@(ConPatIn name pats) - = tcPats pats `thenTc` \ (pats', lie, tys) -> +tc_pat tc_bndr pat_in@(ConPatIn con_name arg_pats) pat_ty + = addErrCtxt (patCtxt pat_in) $ - tcAddErrCtxt (patCtxt pat_in) $ - matchConArgTys name tys `thenTc` \ (con_id, data_ty) -> + -- Check that it's a constructor, and instantiate it + tcLookupLocatedDataCon con_name `thenM` \ data_con -> + tcInstDataCon (PatOrigin pat_in) data_con `thenM` \ (_, ex_dicts1, arg_tys, con_res_ty, ex_tvs) -> - returnTc (ConPat con_id data_ty pats', - lie, - data_ty) + -- Check overall type matches. + -- The pat_ty might be a for-all type, in which + -- case we must instantiate to match + tcSubPat con_res_ty pat_ty `thenM` \ co_fn -> -tcPat pat_in@(ConOpPatIn pat1 op _ pat2) -- in binary-op form... - = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) -> - tcPat pat2 `thenTc` \ (pat2', lie2, ty2) -> + -- Check the argument patterns + tcConStuff tc_bndr data_con arg_pats arg_tys `thenM` \ (arg_pats', arg_tvs, arg_ids, ex_dicts2) -> - tcAddErrCtxt (patCtxt pat_in) $ - matchConArgTys op [ty1,ty2] `thenTc` \ (con_id, data_ty) -> - - returnTc (ConOpPat pat1' con_id pat2' data_ty, - lie1 `plusLIE` lie2, - data_ty) + returnM (co_fn <$> ConPatOut data_con arg_pats' con_res_ty ex_tvs (map instToId ex_dicts1), + listToBag ex_tvs `unionBags` arg_tvs, + arg_ids, + ex_dicts1 ++ ex_dicts2) \end{code} + %************************************************************************ %* * -\subsection{Records} +\subsection{Literals} %* * %************************************************************************ \begin{code} -tcPat pat_in@(RecPatIn name rpats) - = tcLookupGlobalValue name `thenNF_Tc` \ con_id -> - tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) -> +tc_pat tc_bndr pat@(LitPat lit@(HsString _)) pat_ty + = zapExpectedType pat_ty liftedTypeKind `thenM` \ pat_ty' -> + unifyTauTy pat_ty' stringTy `thenM_` + tcLookupId eqStringName `thenM` \ eq_id -> + returnM (NPatOut lit stringTy (nlHsVar eq_id `HsApp` nlHsLit lit), + emptyBag, emptyBag, []) + +tc_pat tc_bndr (LitPat simple_lit) pat_ty + = zapExpectedType pat_ty argTypeKind `thenM` \ pat_ty' -> + unifyTauTy pat_ty' (hsLitType simple_lit) `thenM_` + returnM (LitPat simple_lit, emptyBag, emptyBag, []) + +tc_pat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty + = zapExpectedType pat_ty liftedTypeKind `thenM` \ pat_ty' -> + newOverloadedLit origin over_lit pat_ty' `thenM` \ pos_lit_expr -> + newMethodFromName origin pat_ty' eqName `thenM` \ eq -> + (case mb_neg of + Nothing -> returnM pos_lit_expr -- Positive literal + Just neg -> -- Negative literal + -- The 'negate' is re-mappable syntax + tcSyntaxName origin pat_ty' (negateName, noLoc (HsVar neg)) `thenM` \ (_, neg_expr) -> + returnM (mkHsApp neg_expr pos_lit_expr) + ) `thenM` \ lit_expr -> + let - -- Ignore the con_theta; overloaded constructors only - -- behave differently when called, not when used for - -- matching. - (_, record_ty) = splitFunTy con_tau + -- The literal in an NPatIn is always positive... + -- But in NPat, the literal is used to find identical patterns + -- so we must negate the literal when necessary! + lit' = case (over_lit, mb_neg) of + (HsIntegral i _, Nothing) -> HsInteger i pat_ty' + (HsIntegral i _, Just _) -> HsInteger (-i) pat_ty' + (HsFractional f _, Nothing) -> HsRat f pat_ty' + (HsFractional f _, Just _) -> HsRat (-f) pat_ty' in - -- 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) - + returnM (NPatOut lit' pat_ty' (HsApp (nlHsVar eq) lit_expr), + emptyBag, emptyBag, []) where - 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) + origin = PatOrigin pat \end{code} %************************************************************************ %* * -\subsection{Non-overloaded literals} +\subsection{n+k patterns} %* * %************************************************************************ \begin{code} -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 - comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy) +tc_pat tc_bndr pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name) pat_ty + = addSrcSpan nm_loc (tc_bndr name pat_ty) `thenM` \ (co_fn, bndr_id) -> + let + pat_ty' = idType bndr_id in - 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) + newOverloadedLit origin lit pat_ty' `thenM` \ over_lit_expr -> + newMethodFromName origin pat_ty' geName `thenM` \ ge -> + + -- The '-' part is re-mappable syntax + tcSyntaxName origin pat_ty' (minusName, noLoc (HsVar minus_name)) `thenM` \ (_, minus_expr) -> + + -- The Report says that n+k patterns must be in Integral + -- We may not want this when using re-mappable syntax, though (ToDo?) + tcLookupClass integralClassName `thenM` \ icls -> + newDicts origin [mkClassPred icls [pat_ty']] `thenM` \ dicts -> + extendLIEs dicts `thenM_` + + returnM (NPlusKPatOut (L nm_loc bndr_id) i + (SectionR (nlHsVar ge) over_lit_expr) + (SectionR minus_expr over_lit_expr), + emptyBag, unitBag (name, bndr_id), []) + where + origin = PatOrigin pat \end{code} + %************************************************************************ %* * -\subsection{Overloaded patterns: int literals and \tr{n+k} patterns} +\subsection{Lists of patterns} %* * %************************************************************************ +Helper functions + \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) -> - - 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 (HsApp (HsVar eq_id) - (HsVar over_lit_id)), - lie1 `plusLIE` lie2, - tyvar_ty) - where - origin = LiteralOrigin lit +tcPats :: BinderChecker -- How to deal with variables + -> [LPat Name] -> [TcType] -- Excess 'expected types' discarded + -> TcM ([LPat TcId], + Bag TcTyVar, + Bag (Name, TcId), -- Ids bound by the pattern + [Inst]) -- Dicts bound by the pattern + +tcPats tc_bndr [] tys = returnM ([], emptyBag, emptyBag, []) + +tcPats tc_bndr (pat:pats) (ty:tys) + = tcPat tc_bndr pat (Check ty) `thenM` \ (pat', tvs1, ids1, lie_avail1) -> + tcPats tc_bndr pats tys `thenM` \ (pats', tvs2, ids2, lie_avail2) -> + + returnM (pat':pats', + tvs1 `unionBags` tvs2, ids1 `unionBags` ids2, + lie_avail1 ++ lie_avail2) +\end{code} -tcPat (LitPatIn lit@(HsFrac f)) - = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty -> - newOverloadedLit origin - (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) -> - tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id -> - newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) -> +%************************************************************************ +%* * +\subsection{Constructor arguments} +%* * +%************************************************************************ - returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id) - (HsVar over_lit_id)), - lie1 `plusLIE` lie2, - tyvar_ty) - where - origin = LiteralOrigin lit +\begin{code} +tcConStuff tc_bndr data_con (PrefixCon arg_pats) arg_tys + = -- Check correct arity + checkTc (con_arity == no_of_args) + (arityErr "Constructor" data_con con_arity no_of_args) `thenM_` -tcPat (LitPatIn lit@(HsLitLit s)) - = error "tcPat: can't handle ``literal-literal'' patterns" + -- Check arguments + tcPats tc_bndr arg_pats arg_tys `thenM` \ (arg_pats', tvs, ids, lie_avail) -> -tcPat (NPlusKPatIn name lit@(HsInt i)) - = tcLookupLocalValueOK "tcPat1:n+k" name `thenNF_Tc` \ local -> - let - local_ty = idType local - in - tcLookupGlobalValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id -> - tcLookupGlobalValueByKey minusClassOpKey `thenNF_Tc` \ minus_sel_id -> + returnM (PrefixCon arg_pats', tvs, ids, lie_avail) + where + con_arity = dataConSourceArity data_con + no_of_args = length arg_pats - newOverloadedLit origin - (OverloadedIntegral i) local_ty `thenNF_Tc` \ (lie1, over_lit_id) -> +tcConStuff tc_bndr data_con (InfixCon p1 p2) arg_tys + = -- Check correct arity + checkTc (con_arity == 2) + (arityErr "Constructor" data_con con_arity 2) `thenM_` - newMethod origin (RealId ge_sel_id) [local_ty] `thenNF_Tc` \ (lie2, ge_id) -> - newMethod origin (RealId minus_sel_id) [local_ty] `thenNF_Tc` \ (lie3, minus_id) -> + -- Check arguments + tcPat tc_bndr p1 (Check ty1) `thenM` \ (p1', tvs1, ids1, lie_avail1) -> + tcPat tc_bndr p2 (Check ty2) `thenM` \ (p2', tvs2, ids2, lie_avail2) -> - returnTc (NPlusKPat (TcId local) lit local_ty - (SectionR (HsVar ge_id) (HsVar over_lit_id)) - (SectionR (HsVar minus_id) (HsVar over_lit_id)), - lie1 `plusLIE` lie2 `plusLIE` lie3, - local_ty) + returnM (InfixCon p1' p2', + tvs1 `unionBags` tvs2, ids1 `unionBags` ids2, + lie_avail1 ++ lie_avail2) where - origin = LiteralOrigin lit -- Not very good! + con_arity = dataConSourceArity data_con + [ty1, ty2] = arg_tys + +tcConStuff tc_bndr data_con (RecCon rpats) arg_tys + = -- Check the fields + tc_fields field_tys rpats `thenM` \ (rpats', tvs, ids, lie_avail) -> + returnM (RecCon rpats', tvs, ids, lie_avail) -tcPat (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an HsInt literal" + where + field_tys = zip (map fieldLabelName (dataConFieldLabels data_con)) arg_tys + -- Don't use zipEqual! If the constructor isn't really a record, then + -- dataConFieldLabels will be empty (and each field in the pattern + -- will generate an error below). + + tc_fields field_tys [] + = returnM ([], emptyBag, emptyBag, []) + + tc_fields field_tys ((L lbl_loc field_label, rhs_pat) : rpats) + = tc_fields field_tys rpats `thenM` \ (rpats', tvs1, ids1, lie_avail1) -> + + (case [ty | (f,ty) <- field_tys, f == field_label] of + + -- No matching field; chances are this field label comes from some + -- other record type (or maybe none). As well as reporting an + -- error we still want to typecheck the pattern, principally to + -- make sure that all the variables it binds are put into the + -- environment, else the type checker crashes later: + -- f (R { foo = (a,b) }) = a+b + -- If foo isn't one of R's fields, we don't want to crash when + -- typechecking the "a+b". + [] -> addErrTc (badFieldCon data_con field_label) `thenM_` + newTyVarTy liftedTypeKind `thenM` \ bogus_ty -> + returnM (error "Bogus selector Id", bogus_ty) + + -- The normal case, when the field comes from the right constructor + (pat_ty : extras) -> + ASSERT( null extras ) + addSrcSpan lbl_loc (tcLookupId field_label) `thenM` \ sel_id -> + returnM (sel_id, pat_ty) + ) `thenM` \ (sel_id, pat_ty) -> + + tcPat tc_bndr rhs_pat (Check pat_ty) `thenM` \ (rhs_pat', tvs2, ids2, lie_avail2) -> + + returnM ((L lbl_loc sel_id, rhs_pat') : rpats', + tvs1 `unionBags` tvs2, + ids1 `unionBags` ids2, + lie_avail1 ++ lie_avail2) \end{code} + %************************************************************************ %* * -\subsection{Lists of patterns} +\subsection{Subsumption} %* * %************************************************************************ -\begin{code} -tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s]) - -tcPats [] = returnTc ([], emptyLIE, []) - -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} - -@matchConArgTys@ grabs the signature of the data constructor, and -unifies the actual args against the expected ones. +Example: + f :: (forall a. a->a) -> Int -> Int + f (g::Int->Int) y = g y +This is ok: the type signature allows fewer callers than +the (more general) signature f :: (Int->Int) -> Int -> Int +I.e. (forall a. a->a) <= Int -> Int +We end up translating this to: + f = \g' :: (forall a. a->a). let g = g' Int in g' y + +tcSubPat does the work + sig_ty is the signature on the pattern itself + (Int->Int in the example) + expected_ty is the type passed inwards from the context + (forall a. a->a in the example) \begin{code} -matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s) - -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. - let - (con_args, con_result) = splitFunTy con_tau - con_arity = length con_args - no_of_args = length arg_tys - in - checkTc (con_arity == no_of_args) - (arityErr "Constructor" con_id con_arity no_of_args) `thenTc_` - - unifyTauTyLists con_args arg_tys `thenTc_` - returnTc (con_id, con_result) +tcSubPat :: TcSigmaType -> Expected TcSigmaType -> TcM PatCoFn + +tcSubPat sig_ty exp_ty + = tcSubOff sig_ty exp_ty `thenM` \ co_fn -> + -- co_fn is a coercion on *expressions*, and we + -- need to make a coercion on *patterns* + if isIdCoercion co_fn then + returnM idCoercion + else + newUnique `thenM` \ uniq -> + readExpectedType exp_ty `thenM` \ exp_ty' -> + let + arg_id = mkSysLocal FSLIT("sub") uniq exp_ty' + the_fn = DictLam [arg_id] (noLoc (co_fn <$> HsVar arg_id)) + pat_co_fn p = SigPatOut (noLoc p) exp_ty' the_fn + in + returnM (mkCoercion pat_co_fn) \end{code} -% ================================================= +%************************************************************************ +%* * +\subsection{Errors and contexts} +%* * +%************************************************************************ -Errors and contexts -~~~~~~~~~~~~~~~~~~~ \begin{code} -patCtxt pat sty = hang (ptext SLIT("In the pattern:")) 4 (ppr sty pat) +patCtxt pat = hang (ptext SLIT("When checking the pattern:")) + 4 (ppr pat) -recordLabel field_label sty - = hang (hcat [ptext SLIT("When matching record field"), ppr sty field_label]) - 4 (hcat [ptext SLIT("with its immediately enclosing constructor")]) +badFieldCon :: DataCon -> Name -> SDoc +badFieldCon con field + = hsep [ptext SLIT("Constructor") <+> quotes (ppr con), + ptext SLIT("does not have field"), quotes (ppr field)] -recordRhs field_label pat sty - = hang (ptext SLIT("In the record field pattern")) - 4 (sep [ppr sty field_label, char '=', ppr sty pat]) +polyPatSig :: TcType -> SDoc +polyPatSig sig_ty + = hang (ptext SLIT("Illegal polymorphic type signature in pattern:")) + 4 (ppr sig_ty) + +badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat \end{code} +