X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=9a44d8d8713e4ca2882d11be6a72450793150b02;hb=861e836ed0cc1aa45932ecb3470967964440a0ef;hp=edb4cc52c8ddffe87b6856d83138f1b95a06bb2e;hpb=b117679aefcfabd2f8b34a9f495ede8508d7f88d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index edb4cc5..9a44d8d 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -1,52 +1,102 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcPat]{Typechecking patterns} \begin{code} -module TcPat ( tcPat, badFieldsCon ) where +module TcPat ( tcPat, tcPatBndr_NoSigs, simpleHsLitTy, badFieldCon, polyPatSig ) where #include "HsVersions.h" -import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsExpr(..) ) +import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsOverLit(..), HsExpr(..) ) import RnHsSyn ( RenamedPat ) -import TcHsSyn ( TcPat ) +import TcHsSyn ( TcPat, TcId ) import TcMonad -import Inst ( Inst, OverloadedLit(..), InstOrigin(..), - emptyLIE, plusLIE, plusLIEs, LIE, - newMethod, newOverloadedLit +import Inst ( InstOrigin(..), + emptyLIE, plusLIE, LIE, + newMethod, newOverloadedLit, newDicts, newClassDicts ) -import Name ( Name {- instance Outputable -} ) -import TcEnv ( TcIdOcc(..), tcLookupGlobalValue, tcLookupGlobalValueByKey, - tcLookupLocalValueOK, tcInstId - ) -import TcType ( TcType, TcMaybe, newTyVarTy, newTyVarTys ) +import Name ( Name, getOccName, getSrcLoc ) import FieldLabel ( fieldLabelName ) -import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) +import TcEnv ( tcLookupValue, tcLookupClassByKey, + tcLookupValueByKey, newLocalId, badCon + ) +import TcType ( TcType, TcTyVar, tcInstTyVars, newTyVarTy ) +import TcMonoType ( tcHsSigType ) +import TcUnify ( unifyTauTy, unifyListTy, unifyTupleTy ) -import Maybes ( maybeToBool ) -import Bag ( Bag ) import CmdLineOpts ( opt_IrrefutableTuples ) -import Id ( GenId, idType, Id, dataConFieldLabels ) -import Kind ( Kind, mkBoxedTypeKind, mkTypeKind ) -import Type ( splitFunTys, splitRhoTy, - splitFunTy_maybe, splitAlgTyConApp_maybe, - Type +import DataCon ( dataConSig, dataConFieldLabels, + dataConSourceArity ) +import Id ( isDataConWrapId_maybe ) +import Type ( isTauTy, mkTyConApp, mkClassPred, boxedTypeKind ) +import Subst ( substTy, substClasses ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) -import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, intTy ) -import Unique ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey ) -import Util ( assertPanic, panic ) +import TysWiredIn ( charTy, stringTy, intTy, integerTy ) +import PrelNames ( eqClassOpKey, geClassOpKey, + cCallableClassKey, eqStringIdKey, + ) +import BasicTypes ( isBoxed ) +import Bag import Outputable \end{code} + +%************************************************************************ +%* * +\subsection{Variable patterns} +%* * +%************************************************************************ + +\begin{code} +-- This is the right function to pass to tcPat when there are no signatures +tcPatBndr_NoSigs binder_name pat_ty + = -- Need to make a new, monomorphic, Id + -- The binder_name is already being used for the polymorphic Id + newLocalId (getOccName binder_name) pat_ty loc `thenNF_Tc` \ bndr_id -> + returnTc bndr_id + where + loc = getSrcLoc binder_name +\end{code} + + +%************************************************************************ +%* * +\subsection{Typechecking patterns} +%* * +%************************************************************************ + \begin{code} -tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s) +tcPat :: (Name -> TcType -> TcM s TcId) -- How to construct a suitable (monomorphic) + -- Id for variables found in the pattern + -- The TcType is the expected type, see note below + -> RenamedPat + + -> TcType -- Expected type derived from the context + -- In the case of a function with a rank-2 signature, + -- this type might be a forall type. + -- INVARIANT: if it is, the foralls will always be visible, + -- not hidden inside a mutable type variable + + -> TcM s (TcPat, + LIE, -- Required by n+k and literal pats + 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. + LIE) -- Dicts or methods [see below] bound by the pattern + -- from existential constructor patterns \end{code} + %************************************************************************ %* * \subsection{Variables, wildcards, lazy pats, as-pats} @@ -54,34 +104,36 @@ tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s) %************************************************************************ \begin{code} -tcPat (VarPatIn name) - = tcLookupLocalValueOK "tcPat1:" name `thenNF_Tc` \ id -> - returnTc (VarPat (TcId id), emptyLIE, idType id) +tcPat tc_bndr (VarPatIn name) pat_ty + = tc_bndr name pat_ty `thenTc` \ bndr_id -> + returnTc (VarPat bndr_id, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE) -tcPat (LazyPatIn pat) - = tcPat pat `thenTc` \ (pat', lie, ty) -> - returnTc (LazyPat pat', lie, ty) +tcPat tc_bndr (LazyPatIn pat) pat_ty + = tcPat tc_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) -> + returnTc (LazyPat pat', lie_req, tvs, ids, lie_avail) -tcPat pat_in@(AsPatIn name pat) - = tcLookupLocalValueOK "tcPat2" name `thenNF_Tc` \ id -> - tcPat pat `thenTc` \ (pat', lie, ty) -> +tcPat tc_bndr pat_in@(AsPatIn name pat) pat_ty + = tc_bndr name pat_ty `thenTc` \ bndr_id -> + tcPat tc_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) -> tcAddErrCtxt (patCtxt pat_in) $ - unifyTauTy (idType id) ty `thenTc_` - returnTc (AsPat (TcId id) pat', lie, ty) + returnTc (AsPat bndr_id pat', lie_req, + tvs, (name, bndr_id) `consBag` ids, lie_avail) -tcPat WildPatIn - = newTyVarTy mkTypeKind `thenNF_Tc` \ tyvar_ty -> - returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty) +tcPat tc_bndr WildPatIn pat_ty + = returnTc (WildPat pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE) -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 tc_bndr (ParPatIn parend_pat) pat_ty + = tcPat tc_bndr parend_pat pat_ty + +tcPat tc_bndr (SigPatIn pat sig) pat_ty + = tcHsSigType sig `thenTc` \ sig_ty -> + + -- Check that the signature isn't a polymorphic one, which + -- we don't permit (at present, anyway) + checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_` -tcPat (ParPatIn parend_pat) - = tcPat parend_pat + unifyTauTy pat_ty sig_ty `thenTc_` + tcPat tc_bndr pat sig_ty \end{code} %************************************************************************ @@ -91,29 +143,21 @@ tcPat (ParPatIn parend_pat) %************************************************************************ \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_` +tcPat tc_bndr pat_in@(ListPatIn pats) pat_ty + = tcAddErrCtxt (patCtxt pat_in) $ + unifyListTy pat_ty `thenTc` \ elem_ty -> + tcPats tc_bndr pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) -> + returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail) - returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty) +tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty + = tcAddErrCtxt (patCtxt pat_in) $ -tcPat pat_in@(TuplePatIn pats) - = let - arity = length pats - in - tcPats pats `thenTc` \ (pats', lie, tys) -> - - -- Make sure we record that the tuples can only contain boxed types - newTyVarTys arity mkBoxedTypeKind `thenNF_Tc` \ tyvar_tys -> - - tcAddErrCtxt (patCtxt pat_in) $ - unifyTauTyLists tyvar_tys tys `thenTc_` + unifyTupleTy boxity arity pat_ty `thenTc` \ arg_tys -> + tcPats tc_bndr pats arg_tys `thenTc` \ (pats', lie_req, 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. @@ -121,65 +165,30 @@ 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 unmangled_result + | otherwise = unmangled_result in - returnTc (possibly_mangled_result, lie, mkTupleTy arity tys) + returnTc (possibly_mangled_result, lie_req, 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) -> - - tcAddErrCtxt (patCtxt pat_in) $ - matchConArgTys name tys `thenTc` \ (con_id, data_ty) -> - - returnTc (ConPat con_id data_ty pats', - lie, - data_ty) - -tcPat pat_in@(ConOpPatIn pat1 op _ pat2) -- in binary-op form... - = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) -> - tcPat pat2 `thenTc` \ (pat2', lie2, ty2) -> - - tcAddErrCtxt (patCtxt pat_in) $ - matchConArgTys op [ty1,ty2] `thenTc` \ (con_id, data_ty) -> +tcPat tc_bndr pat@(ConPatIn name arg_pats) pat_ty + = tcConPat tc_bndr pat name arg_pats pat_ty - returnTc (ConOpPat pat1' con_id pat2' data_ty, - lie1 `plusLIE` lie2, - data_ty) +tcPat tc_bndr pat@(ConOpPatIn pat1 op _ pat2) pat_ty + = tcConPat tc_bndr pat op [pat1, pat2] pat_ty \end{code} + %************************************************************************ %* * \subsection{Records} @@ -187,147 +196,126 @@ tcPat pat_in@(ConOpPatIn pat1 op _ pat2) -- in binary-op form... %************************************************************************ \begin{code} -tcPat pat_in@(RecPatIn name rpats) - = tcLookupGlobalValue name `thenNF_Tc` \ con_id -> - tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) -> - let - -- Ignore the con_theta; overloaded constructors only - -- behave differently when called, not when used for - -- matching. - (_, record_ty) = splitFunTys con_tau +tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty + = tcAddErrCtxt (patCtxt pat) $ - field_names = map fieldLabelName (dataConFieldLabels con_id) - bad_fields = [f | (f,_,_) <- rpats, not (f `elem` field_names)] + -- Check the constructor itself + tcConstructor pat name pat_ty `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys) -> + let + -- 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). + field_tys = zip (map fieldLabelName (dataConFieldLabels data_con)) + arg_tys in - -- Check that all the fields are from this constructor - checkTc (null bad_fields) (badFieldsCon name bad_fields) `thenTc_` - - -- Con is syntactically constrained to be a data constructor - ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty) ) - mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) -> + -- Check the fields + tc_fields field_tys rpats `thenTc` \ (rpats', lie_req, tvs, ids, lie_avail2) -> - returnTc (RecPat con_id record_ty rpats', - plusLIEs lies, - record_ty) + returnTc (RecPat data_con pat_ty ex_tvs dicts rpats', + lie_req, + listToBag ex_tvs `unionBags` tvs, + ids, + lie_avail1 `plusLIE` lie_avail2) 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 (splitFunTy_maybe tau) ) - let - -- Selector must have type RecordType -> FieldType - Just (record_ty, field_ty) = splitFunTy_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) + tc_fields field_tys [] + = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE) + + tc_fields field_tys ((field_label, rhs_pat, pun_flag) : rpats) + = tc_fields field_tys rpats `thenTc` \ (rpats', lie_req1, 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 name field_label) `thenNF_Tc_` + newTyVarTy boxedTypeKind `thenNF_Tc_` + returnTc (error "Bogus selector Id", pat_ty) + + -- The normal case, when the field comes from the right constructor + (pat_ty : extras) -> + ASSERT( null extras ) + tcLookupValue field_label `thenNF_Tc` \ sel_id -> + returnTc (sel_id, pat_ty) + ) `thenTc` \ (sel_id, pat_ty) -> + + tcPat tc_bndr rhs_pat pat_ty `thenTc` \ (rhs_pat', lie_req2, tvs2, ids2, lie_avail2) -> + + returnTc ((sel_id, rhs_pat', pun_flag) : rpats', + lie_req1 `plusLIE` lie_req2, + tvs1 `unionBags` tvs2, + ids1 `unionBags` ids2, + lie_avail1 `plusLIE` lie_avail2) \end{code} %************************************************************************ %* * -\subsection{Non-overloaded literals} +\subsection{Literals} %* * %************************************************************************ \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) - 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) +tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty + -- cf tcExpr on LitLits + = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass -> + newDicts (LitLitOrigin (_UNPK_ s)) + [mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ (dicts, _) -> + returnTc (LitPat (HsLitLit s pat_ty) pat_ty, dicts, emptyBag, emptyBag, emptyLIE) + +tcPat tc_bndr pat@(LitPatIn lit@(HsString _)) pat_ty + = unifyTauTy pat_ty stringTy `thenTc_` + tcLookupValueByKey eqStringIdKey `thenNF_Tc` \ eq_id -> + returnTc (NPat lit stringTy (HsVar eq_id `HsApp` HsLit lit), + emptyLIE, emptyBag, emptyBag, emptyLIE) + +tcPat tc_bndr (LitPatIn simple_lit) pat_ty + = unifyTauTy pat_ty (simpleHsLitTy simple_lit) `thenTc_` + returnTc (LitPat simple_lit pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE) + +tcPat tc_bndr pat@(NPatIn over_lit) pat_ty + = newOverloadedLit (PatOrigin pat) over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> + tcLookupValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id -> + newMethod origin eq_sel_id [pat_ty] `thenNF_Tc` \ (lie2, eq_id) -> + + returnTc (NPat lit' pat_ty (HsApp (HsVar eq_id) over_lit_expr), + lie1 `plusLIE` lie2, + emptyBag, emptyBag, emptyLIE) + where + origin = PatOrigin pat + lit' = case over_lit of + HsIntegral i _ -> HsInteger i + HsFractional f _ -> HsRat f pat_ty \end{code} %************************************************************************ %* * -\subsection{Overloaded patterns: int literals and \tr{n+k} patterns} +\subsection{n+k patterns} %* * %************************************************************************ \begin{code} -tcPat (LitPatIn lit@(HsInt i)) - = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty -> - newOverloadedLit origin - (OverloadedIntegral i) tyvar_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> - - 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) - over_lit_expr), - lie1 `plusLIE` lie2, - tyvar_ty) - where - origin = LiteralOrigin lit - -tcPat (LitPatIn lit@(HsFrac f)) - = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty -> - newOverloadedLit origin - (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> - - 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) - over_lit_expr), - lie1 `plusLIE` lie2, - tyvar_ty) - where - origin = LiteralOrigin lit - -tcPat (LitPatIn lit@(HsLitLit s)) --- = error "tcPat: can't handle ``literal-literal'' patterns" - = returnTc (LitPat lit intTy, emptyLIE, intTy) - -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 -> - - newOverloadedLit origin - (OverloadedIntegral i) local_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> - - 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) -> - - returnTc (NPlusKPat (TcId local) lit local_ty +tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus) pat_ty + = tc_bndr name pat_ty `thenTc` \ bndr_id -> + tcLookupValue minus `thenNF_Tc` \ minus_sel_id -> + tcLookupValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id -> + newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> + newMethod origin ge_sel_id [pat_ty] `thenNF_Tc` \ (lie2, ge_id) -> + newMethod origin minus_sel_id [pat_ty] `thenNF_Tc` \ (lie3, minus_id) -> + + returnTc (NPlusKPat bndr_id i pat_ty (SectionR (HsVar ge_id) over_lit_expr) (SectionR (HsVar minus_id) over_lit_expr), lie1 `plusLIE` lie2 `plusLIE` lie3, - local_ty) + emptyBag, unitBag (name, bndr_id), emptyLIE) where - origin = LiteralOrigin lit -- Not very good! - -tcPat (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an HsInt literal" + origin = PatOrigin pat \end{code} %************************************************************************ @@ -336,61 +324,122 @@ tcPat (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an HsInt literal" %* * %************************************************************************ -\begin{code} -tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s]) - -tcPats [] = returnTc ([], emptyLIE, []) +Helper functions -tcPats (pat:pats) - = tcPat pat `thenTc` \ (pat', lie, ty) -> - tcPats pats `thenTc` \ (pats', lie', tys) -> +\begin{code} +tcPats :: (Name -> TcType -> TcM s TcId) -- How to deal with variables + -> [RenamedPat] -> [TcType] -- Excess 'expected types' discarded + -> TcM s ([TcPat], + LIE, -- Required by n+k and literal pats + Bag TcTyVar, + Bag (Name, TcId), -- Ids bound by the pattern + LIE) -- Dicts bound by the pattern + +tcPats tc_bndr [] tys = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE) + +tcPats tc_bndr (ty:tys) (pat:pats) + = tcPat tc_bndr ty pat `thenTc` \ (pat', lie_req1, tvs1, ids1, lie_avail1) -> + tcPats tc_bndr tys pats `thenTc` \ (pats', lie_req2, tvs2, ids2, lie_avail2) -> + + returnTc (pat':pats', lie_req1 `plusLIE` lie_req2, + tvs1 `unionBags` tvs2, ids1 `unionBags` ids2, + lie_avail1 `plusLIE` lie_avail2) +\end{code} - returnTc (pat':pats', plusLIE lie lie', ty:tys) +------------------------------------------------------ +\begin{code} +simpleHsLitTy :: HsLit -> TcType +simpleHsLitTy (HsCharPrim c) = charPrimTy +simpleHsLitTy (HsStringPrim s) = addrPrimTy +simpleHsLitTy (HsInt i) = intTy +simpleHsLitTy (HsInteger i) = integerTy +simpleHsLitTy (HsIntPrim i) = intPrimTy +simpleHsLitTy (HsFloatPrim f) = floatPrimTy +simpleHsLitTy (HsDoublePrim d) = doublePrimTy +simpleHsLitTy (HsChar c) = charTy +simpleHsLitTy (HsString str) = stringTy \end{code} -@matchConArgTys@ grabs the signature of the data constructor, and -unifies the actual args against the expected ones. +------------------------------------------------------ \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 +tcConstructor pat con_name pat_ty + = -- Check that it's a constructor + tcLookupValue con_name `thenNF_Tc` \ con_id -> + case isDataConWrapId_maybe con_id of { + Nothing -> failWithTc (badCon con_id); + Just data_con -> + + -- Instantiate it + let + (tvs, _, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con + -- Ignore the theta; overloaded constructors only -- behave differently when called, not when used for -- matching. + in + tcInstTyVars (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) -> let - (con_args, con_result) = splitFunTys con_tau - con_arity = length con_args - no_of_args = length arg_tys + ex_theta' = substClasses tenv ex_theta + arg_tys' = map (substTy tenv) arg_tys + + n_ex_tvs = length ex_tvs + ex_tvs' = take n_ex_tvs all_tvs' + result_ty = mkTyConApp tycon (drop n_ex_tvs ty_args') + in + newClassDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ (lie_avail, dicts) -> + + -- Check overall type matches + unifyTauTy pat_ty result_ty `thenTc_` + + returnTc (data_con, ex_tvs', dicts, lie_avail, arg_tys') + } +\end{code} + +------------------------------------------------------ +\begin{code} +tcConPat tc_bndr pat con_name arg_pats pat_ty + = tcAddErrCtxt (patCtxt pat) $ + + -- Check the constructor itself + tcConstructor pat con_name pat_ty `thenTc` \ (data_con, ex_tvs', dicts, lie_avail1, arg_tys') -> + + -- Check correct arity + let + con_arity = dataConSourceArity data_con + no_of_args = length arg_pats in checkTc (con_arity == no_of_args) - (arityErr "Constructor" con_id con_arity no_of_args) `thenTc_` + (arityErr "Constructor" data_con con_arity no_of_args) `thenTc_` + + -- Check arguments + tcPats tc_bndr arg_pats arg_tys' `thenTc` \ (arg_pats', lie_req, tvs, ids, lie_avail2) -> - unifyTauTyLists con_args arg_tys `thenTc_` - returnTc (con_id, con_result) + returnTc (ConPat data_con pat_ty ex_tvs' dicts arg_pats', + lie_req, + listToBag ex_tvs' `unionBags` tvs, + ids, + lie_avail1 `plusLIE` lie_avail2) \end{code} -% ================================================= -Errors and contexts -~~~~~~~~~~~~~~~~~~~ +%************************************************************************ +%* * +\subsection{Errors and contexts} +%* * +%************************************************************************ + \begin{code} patCtxt pat = hang (ptext SLIT("In the pattern:")) 4 (ppr pat) -recordLabel field_label - = hang (hcat [ptext SLIT("When matching record field"), ppr field_label]) - 4 (hcat [ptext SLIT("with its immediately enclosing constructor")]) - -recordRhs field_label pat - = hang (ptext SLIT("In the record field pattern")) - 4 (sep [ppr field_label, char '=', ppr pat]) - -badFieldsCon :: Name -> [Name] -> SDoc -badFieldsCon con fields +badFieldCon :: Name -> Name -> SDoc +badFieldCon con field = hsep [ptext SLIT("Constructor") <+> quotes (ppr con), - ptext SLIT("does not have field(s):"), pprQuotedList fields] + ptext SLIT("does not have field"), quotes (ppr field)] + +polyPatSig :: TcType -> SDoc +polyPatSig sig_ty + = hang (ptext SLIT("Illegal polymorphic type signature in pattern:")) + 4 (ppr sig_ty) \end{code}