X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=9242f1918cd6f284e0fcc05fc3c17dc15ed145be;hb=4e6d0831f8260f6cf1f8b9f118123d2c4fb86ee1;hp=5ec7d7c0cc96aae22889ed5d5d64cd2600077dcb;hpb=9dd6e1c216993624a2cd74b62ca0f0569c02c26b;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 5ec7d7c..9242f19 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -1,53 +1,109 @@ % -% (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 ) where +module TcPat ( tcPat, tcVarPat, badFieldCon, polyPatSig ) where #include "HsVersions.h" -import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsExpr(..) ) +import {-# SOURCE #-} TcExpr( tcExpr ) + +import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsExpr(..), Sig(..) ) import RnHsSyn ( RenamedPat ) -import TcHsSyn ( TcPat ) +import TcHsSyn ( TcPat, TcId ) import TcMonad import Inst ( Inst, OverloadedLit(..), InstOrigin(..), - emptyLIE, plusLIE, plusLIEs, LIE, - newMethod, newOverloadedLit + emptyLIE, plusLIE, LIE, + newMethod, newMethodWithGivenTy, newOverloadedLit, + newDicts, instToIdBndr + ) +import Name ( Name, getOccName, getSrcLoc ) +import FieldLabel ( fieldLabelName ) +import TcEnv ( tcLookupValue, + tcLookupValueByKey, newLocalId, badCon ) -import Name ( Name {- instance Outputable -} ) -import TcEnv ( TcIdOcc(..), tcLookupGlobalValue, tcLookupGlobalValueByKey, - tcLookupLocalValueOK, tcInstId +import TcType ( TcType, TcTyVar, tcInstTyVars ) +import TcMonoType ( tcHsType ) +import TcUnify ( unifyTauTy, unifyListTy, + unifyTupleTy, unifyUnboxedTupleTy ) -import TcType ( TcType, TcMaybe, newTyVarTy, newTyVarTys ) -import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) import Bag ( Bag ) import CmdLineOpts ( opt_IrrefutableTuples ) -import Id ( GenId, idType, Id ) -import Kind ( Kind, mkBoxedTypeKind, mkTypeKind ) -import Maybes ( maybeToBool ) -import PprType ( GenType, GenTyVar ) -import Type ( splitFunTys, splitRhoTy, splitSigmaTy, mkTyVarTys, - splitFunTy_maybe, splitAlgTyConApp_maybe, - Type, GenType - ) -import TyVar ( GenTyVar ) +import DataCon ( DataCon, dataConSig, dataConFieldLabels, dataConSourceArity ) +import Id ( Id, mkUserId, idType, isDataConId_maybe ) +import Type ( Type, isTauTy, substTopTy, substTopTheta, mkTyConApp ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) -import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, addrTy ) -import Unique ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey ) -import Util ( assertPanic, panic ) +import TysWiredIn ( charTy, stringTy, intTy ) +import SrcLoc ( SrcLoc ) +import Unique ( eqClassOpKey, geClassOpKey, minusClassOpKey ) +import Bag +import Util ( zipEqual ) import Outputable \end{code} + +%************************************************************************ +%* * +\subsection{Variable patterns} +%* * +%************************************************************************ + +\begin{code} +tcVarPat :: (Name -> Maybe TcId) -- Info about signatures; gives the *monomorphic* + -- Id for variables with a type signature + -> Name + + -> 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 TcId -- The monomorphic Id; this is put in the pattern itself + +tcVarPat sig_fn binder_name pat_ty + = case sig_fn binder_name of + Nothing -> newLocalId (getOccName binder_name) pat_ty `thenNF_Tc` \ bndr_id -> + returnTc bndr_id + + Just bndr_id -> tcAddSrcLoc (getSrcLoc binder_name) $ + unifyTauTy (idType bndr_id) pat_ty `thenTc_` + returnTc bndr_id +\end{code} + + +%************************************************************************ +%* * +\subsection{Typechecking patterns} +%* * +%************************************************************************ + \begin{code} -tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s) +tcPat :: (Name -> Maybe TcId) -- Info about signatures; gives the *monomorphic* + -- Id for variables with a type signature + -> RenamedPat + -> TcType -- Expected type; see invariant in tcVarPat + -> 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} @@ -55,34 +111,43 @@ 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 sig_fn (VarPatIn name) pat_ty + = tcVarPat sig_fn 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 sig_fn (LazyPatIn pat) pat_ty + = tcPat sig_fn 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 sig_fn pat_in@(AsPatIn name pat) pat_ty + = tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id -> + tcPat sig_fn 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 sig_fn WildPatIn pat_ty + = returnTc (WildPat pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE) -tcPat (NegPatIn pat) - = tcPat (negate_lit pat) +tcPat sig_fn (NegPatIn pat) pat_ty + = tcPat sig_fn (negate_lit pat) pat_ty 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 sig_fn (ParPatIn parend_pat) pat_ty + = tcPat sig_fn parend_pat pat_ty + +tcPat sig_fn (SigPatIn pat sig) pat_ty + = tcHsType 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_` + + unifyTauTy pat_ty sig_ty `thenTc_` + tcPat sig_fn pat sig_ty \end{code} %************************************************************************ @@ -92,29 +157,24 @@ 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 sig_fn pat_in@(ListPatIn pats) pat_ty + = tcAddErrCtxt (patCtxt pat_in) $ + unifyListTy pat_ty `thenTc` \ elem_ty -> + tcPats sig_fn 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 sig_fn pat_in@(TuplePatIn pats boxed) pat_ty + = tcAddErrCtxt (patCtxt pat_in) $ -tcPat pat_in@(TuplePatIn pats) - = let - arity = length pats - in - tcPats pats `thenTc` \ (pats', lie, tys) -> + (if boxed + then unifyTupleTy arity pat_ty + else unifyUnboxedTupleTy arity pat_ty) `thenTc` \ arg_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_` + tcPats sig_fn 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' boxed -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) -- so that we can experiment with lazy tuple-matching. @@ -122,65 +182,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 && boxed = 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 sig_fn pat@(ConPatIn name arg_pats) pat_ty + = tcConPat sig_fn pat name arg_pats pat_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) -> - - returnTc (ConOpPat pat1' con_id pat2' data_ty, - lie1 `plusLIE` lie2, - data_ty) +tcPat sig_fn pat@(ConOpPatIn pat1 op _ pat2) pat_ty + = tcConPat sig_fn pat op [pat1, pat2] pat_ty \end{code} + %************************************************************************ %* * \subsection{Records} @@ -188,44 +213,50 @@ 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) -> +tcPat sig_fn pat@(RecPatIn name rpats) pat_ty + = tcAddErrCtxt (patCtxt pat) $ + + -- Check the constructor itself + tcConstructor pat name pat_ty `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys) -> let - -- Ignore the con_theta; overloaded constructors only - -- behave differently when called, not when used for - -- matching. - (_, record_ty) = splitFunTys con_tau + field_tys = zipEqual "tcPat" + (map fieldLabelName (dataConFieldLabels data_con)) + arg_tys in - -- 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) + | null matching_fields + = addErrTc (badFieldCon name field_label) `thenNF_Tc_` + tc_fields field_tys rpats + + | otherwise + = ASSERT( null extras ) + tc_fields field_tys rpats `thenTc` \ (rpats', lie_req1, tvs1, ids1, lie_avail1) -> + + tcLookupValue field_label `thenNF_Tc` \ sel_id -> + tcPat sig_fn rhs_pat rhs_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) + where + matching_fields = [ty | (f,ty) <- field_tys, f == field_label] + (rhs_ty : extras) = matching_fields \end{code} %************************************************************************ @@ -235,28 +266,15 @@ tcPat pat_in@(RecPatIn name rpats) %************************************************************************ \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 sig_fn (LitPatIn lit@(HsChar _)) pat_ty = tcSimpleLitPat lit charTy pat_ty +tcPat sig_fn (LitPatIn lit@(HsIntPrim _)) pat_ty = tcSimpleLitPat lit intPrimTy pat_ty +tcPat sig_fn (LitPatIn lit@(HsCharPrim _)) pat_ty = tcSimpleLitPat lit charPrimTy pat_ty +tcPat sig_fn (LitPatIn lit@(HsStringPrim _)) pat_ty = tcSimpleLitPat lit addrPrimTy pat_ty +tcPat sig_fn (LitPatIn lit@(HsFloatPrim _)) pat_ty = tcSimpleLitPat lit floatPrimTy pat_ty +tcPat sig_fn (LitPatIn lit@(HsDoublePrim _)) pat_ty = tcSimpleLitPat lit doublePrimTy pat_ty + +tcPat sig_fn (LitPatIn lit@(HsLitLit s)) pat_ty = tcSimpleLitPat lit intTy pat_ty + -- This one looks weird! \end{code} %************************************************************************ @@ -266,62 +284,44 @@ tcPat (LitPatIn lit@(HsDoublePrim _)) %************************************************************************ \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 sig_fn pat@(LitPatIn lit@(HsString str)) pat_ty + = unifyTauTy pat_ty stringTy `thenTc_` + tcLookupValueByKey eqClassOpKey `thenNF_Tc` \ sel_id -> + newMethod (PatOrigin pat) 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, emptyBag, emptyBag, emptyLIE) -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) -> +tcPat sig_fn pat@(LitPatIn lit@(HsInt i)) pat_ty + = tcOverloadedLitPat pat lit (OverloadedIntegral i) pat_ty - returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id) - over_lit_expr), - lie1 `plusLIE` lie2, - tyvar_ty) - where - origin = LiteralOrigin lit +tcPat sig_fn pat@(LitPatIn lit@(HsFrac f)) pat_ty + = tcOverloadedLitPat pat lit (OverloadedFractional f) pat_ty -tcPat (LitPatIn lit@(HsLitLit s)) - = error "tcPat: can't handle ``literal-literal'' patterns" -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 -> +tcPat sig_fn pat@(NPlusKPatIn name lit@(HsInt i)) pat_ty + = tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id -> + tcLookupValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id -> + tcLookupValueByKey minusClassOpKey `thenNF_Tc` \ minus_sel_id -> newOverloadedLit origin - (OverloadedIntegral i) local_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> + (OverloadedIntegral i) pat_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) -> + 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 (TcId local) lit local_ty + returnTc (NPlusKPat bndr_id lit 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! + origin = PatOrigin pat -tcPat (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an HsInt literal" +tcPat sig_fn (NPlusKPatIn pat other) pat_ty + = panic "TcPat:NPlusKPat: not an HsInt literal" \end{code} %************************************************************************ @@ -330,47 +330,115 @@ tcPat (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an HsInt literal" %* * %************************************************************************ +Helper functions + +\begin{code} +tcPats :: (Name -> Maybe TcId) -- Info about signatures + -> [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 sig_fn [] tys = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE) + +tcPats sig_fn (ty:tys) (pat:pats) + = tcPat sig_fn ty pat `thenTc` \ (pat', lie_req1, tvs1, ids1, lie_avail1) -> + tcPats sig_fn 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} + +------------------------------------------------------ \begin{code} -tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s]) +tcSimpleLitPat lit lit_ty pat_ty + = unifyTauTy pat_ty lit_ty `thenTc_` + returnTc (LitPat lit lit_ty, emptyLIE, emptyBag, emptyBag, emptyLIE) -tcPats [] = returnTc ([], emptyLIE, []) -tcPats (pat:pats) - = tcPat pat `thenTc` \ (pat', lie, ty) -> - tcPats pats `thenTc` \ (pats', lie', tys) -> +tcOverloadedLitPat pat lit 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 (pat':pats', plusLIE lie lie', ty:tys) + returnTc (NPat lit pat_ty (HsApp (HsVar eq_id) + over_lit_expr), + lie1 `plusLIE` lie2, + emptyBag, emptyBag, emptyLIE) + where + origin = PatOrigin pat \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 isDataConId_maybe con_id of { + Nothing -> failWithTc (badCon con_id); + Just data_con -> + + -- Instantiate it + let + (tvs, theta, 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' = substTopTheta tenv ex_theta + arg_tys' = map (substTopTy 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 + newDicts (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 sig_fn 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 sig_fn 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} -% ================================================= +%************************************************************************ +%* * +\subsection{Errors and contexts} +%* * +%************************************************************************ -Errors and contexts -~~~~~~~~~~~~~~~~~~~ \begin{code} patCtxt pat = hang (ptext SLIT("In the pattern:")) 4 (ppr pat) @@ -382,4 +450,15 @@ recordLabel field_label recordRhs field_label pat = hang (ptext SLIT("In the record field pattern")) 4 (sep [ppr field_label, char '=', ppr pat]) + +badFieldCon :: Name -> Name -> SDoc +badFieldCon con field + = hsep [ptext SLIT("Constructor") <+> quotes (ppr con), + ptext SLIT("does not have field"), quotes (ppr field)] + +polyPatSig :: TcType -> SDoc +polyPatSig sig_ty + = hang (ptext SLIT("Polymorphic type signature in pattern")) + 4 (ppr sig_ty) \end{code} +