X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=7d5e823f91d6ad8c0502119ec7e6c182deba044f;hb=0fe14834f10717e06efca4cef07d0640a99ff0a7;hp=e3749a0932205d2a2a13ec287a5ad6950c76d69b;hpb=18976e614fd90a8d81ced2c3e9cd8e38d72a1f40;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index e3749a0..7d5e823 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -4,46 +4,42 @@ \section[TcPat]{Typechecking patterns} \begin{code} -module TcPat ( tcPat, tcVarPat, badFieldCon, polyPatSig ) where +module TcPat ( tcPat, tcMonoPatBndr, tcSubPat, + badFieldCon, polyPatSig + ) where #include "HsVersions.h" -import {-# SOURCE #-} TcExpr( tcExpr ) - -import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsExpr(..), Sig(..) ) +import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsOverLit(..), HsExpr(..) ) import RnHsSyn ( RenamedPat ) -import TcHsSyn ( TcPat, TcId ) +import TcHsSyn ( TcPat, TcId, simpleHsLitTy ) import TcMonad -import Inst ( Inst, OverloadedLit(..), InstOrigin(..), - emptyLIE, plusLIE, LIE, - newMethod, newMethodWithGivenTy, newOverloadedLit, - newDicts, instToIdBndr +import Inst ( InstOrigin(..), + emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, isEmptyLIE, + newMethod, newOverloadedLit, newDicts ) -import Name ( Name, getOccName, getSrcLoc ) +import Id ( mkLocalId, mkSysLocal ) +import Name ( Name ) import FieldLabel ( fieldLabelName ) -import TcEnv ( tcLookupValue, - tcLookupValueByKey, newLocalId, badCon - ) -import TcType ( TcType, TcTyVar, tcInstTyVars ) -import TcMonoType ( tcHsType ) -import TcUnify ( unifyTauTy, unifyListTy, - unifyTupleTy, unifyUnboxedTupleTy - ) - -import Bag ( Bag ) +import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupId ) +import TcMType ( tcInstTyVars, newTyVarTy, getTcTyVar, putTcTyVar ) +import TcType ( TcType, TcTyVar, TcSigmaType, + mkTyConApp, mkClassPred, liftedTypeKind, tcGetTyVar_maybe, + isHoleTyVar, openTypeKind ) +import TcUnify ( tcSub, unifyTauTy, unifyListTy, unifyTupleTy, + mkCoercion, idCoercion, isIdCoercion, (<$>), PatCoFn ) +import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) + +import TysWiredIn ( stringTy ) import CmdLineOpts ( opt_IrrefutableTuples ) -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 DataCon ( dataConSig, dataConFieldLabels, + dataConSourceArity ) -import TysWiredIn ( charTy, stringTy, intTy ) -import SrcLoc ( SrcLoc ) -import Unique ( eqClassOpKey, geClassOpKey, minusClassOpKey ) +import Subst ( substTy, substTheta ) +import PrelNames ( eqStringName, eqName, geName, cCallableClassName ) +import BasicTypes ( isBoxed ) import Bag -import Util ( zipEqual ) import Outputable \end{code} @@ -55,30 +51,41 @@ import Outputable %************************************************************************ \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 -> -- 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 - - Just bndr_id -> tcAddSrcLoc loc $ - unifyTauTy (idType bndr_id) pat_ty `thenTc_` - returnTc bndr_id - where - loc = getSrcLoc binder_name +type BinderChecker = Name -> TcSigmaType -> TcM (PatCoFn, LIE, 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 + | Just tv <- tcGetTyVar_maybe pat_ty, + isHoleTyVar tv + -- 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. + = getTcTyVar tv `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + Just ty -> tcMonoPatBndr binder_name ty + Nothing -> newTyVarTy openTypeKind `thenNF_Tc` \ ty -> + putTcTyVar tv ty `thenNF_Tc_` + returnTc (idCoercion, emptyLIE, mkLocalId binder_name ty) + | otherwise + = returnTc (idCoercion, emptyLIE, mkLocalId binder_name pat_ty) \end{code} @@ -89,11 +96,14 @@ tcVarPat sig_fn binder_name pat_ty %************************************************************************ \begin{code} -tcPat :: (Name -> Maybe TcId) -- Info about signatures; gives the *monomorphic* - -- Id for variables with a type signature +tcPat :: BinderChecker -> RenamedPat - -> TcType -- Expected type; see invariant in tcVarPat - -> TcM s (TcPat, + + -> 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 (TcPat, LIE, -- Required by n+k and literal pats Bag TcTyVar, -- TyVars bound by the pattern -- These are just the existentially-bound ones. @@ -115,45 +125,38 @@ tcPat :: (Name -> Maybe TcId) -- Info about signatures; gives the *monomorphic* %************************************************************************ \begin{code} -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 tc_bndr pat@(TypePatIn ty) pat_ty + = failWithTc (badTypePat pat) + +tcPat tc_bndr (VarPatIn name) pat_ty + = tc_bndr name pat_ty `thenTc` \ (co_fn, lie_req, bndr_id) -> + returnTc (co_fn <$> VarPat bndr_id, lie_req, + emptyBag, unitBag (name, bndr_id), emptyLIE) -tcPat sig_fn (LazyPatIn pat) pat_ty - = tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) -> +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 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) $ - returnTc (AsPat bndr_id pat', lie_req, +tcPat tc_bndr pat_in@(AsPatIn name pat) pat_ty + = tc_bndr name pat_ty `thenTc` \ (co_fn, lie_req1, bndr_id) -> + tcPat tc_bndr pat pat_ty `thenTc` \ (pat', lie_req2, tvs, ids, lie_avail) -> + returnTc (co_fn <$> (AsPat bndr_id pat'), lie_req1 `plusLIE` lie_req2, tvs, (name, bndr_id) `consBag` ids, lie_avail) -tcPat sig_fn WildPatIn pat_ty +tcPat tc_bndr WildPatIn pat_ty = returnTc (WildPat pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE) -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 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_` +tcPat tc_bndr (ParPatIn parend_pat) pat_ty + = tcPat tc_bndr parend_pat pat_ty - unifyTauTy pat_ty sig_ty `thenTc_` - tcPat sig_fn pat sig_ty +tcPat tc_bndr (SigPatIn pat sig) pat_ty + = tcHsSigType PatSigCtxt sig `thenTc` \ sig_ty -> + tcSubPat sig_ty pat_ty `thenTc` \ (co_fn, lie_sig) -> + tcPat tc_bndr pat sig_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) -> + returnTc (co_fn <$> pat', lie_req `plusLIE` lie_sig, tvs, ids, lie_avail) \end{code} + %************************************************************************ %* * \subsection{Explicit lists and tuples} @@ -161,24 +164,21 @@ tcPat sig_fn (SigPatIn pat sig) pat_ty %************************************************************************ \begin{code} -tcPat sig_fn pat_in@(ListPatIn pats) pat_ty +tcPat tc_bndr 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) -> + 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) -tcPat sig_fn pat_in@(TuplePatIn pats boxed) pat_ty +tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty = tcAddErrCtxt (patCtxt pat_in) $ - (if boxed - then unifyTupleTy arity pat_ty - else unifyUnboxedTupleTy arity pat_ty) `thenTc` \ arg_tys -> - - tcPats sig_fn pats arg_tys `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) -> + 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' boxed + 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. @@ -186,14 +186,15 @@ tcPat sig_fn pat_in@(TuplePatIn pats boxed) pat_ty -- it was easy to do. possibly_mangled_result - | opt_IrrefutableTuples && boxed = LazyPat unmangled_result - | otherwise = unmangled_result + | opt_IrrefutableTuples && isBoxed boxity = LazyPat unmangled_result + | otherwise = unmangled_result in returnTc (possibly_mangled_result, lie_req, tvs, ids, lie_avail) where arity = length pats \end{code} + %************************************************************************ %* * \subsection{Other constructors} @@ -202,11 +203,11 @@ tcPat sig_fn pat_in@(TuplePatIn pats boxed) pat_ty %************************************************************************ \begin{code} -tcPat sig_fn pat@(ConPatIn name arg_pats) pat_ty - = tcConPat sig_fn pat name arg_pats pat_ty +tcPat tc_bndr pat@(ConPatIn name arg_pats) pat_ty + = tcConPat tc_bndr pat name arg_pats pat_ty -tcPat sig_fn pat@(ConOpPatIn pat1 op _ pat2) pat_ty - = tcConPat sig_fn pat op [pat1, pat2] pat_ty +tcPat tc_bndr pat@(ConOpPatIn pat1 op _ pat2) pat_ty + = tcConPat tc_bndr pat op [pat1, pat2] pat_ty \end{code} @@ -217,15 +218,17 @@ tcPat sig_fn pat@(ConOpPatIn pat1 op _ pat2) pat_ty %************************************************************************ \begin{code} -tcPat sig_fn pat@(RecPatIn name rpats) pat_ty +tcPat tc_bndr 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 - field_tys = zipEqual "tcPat" - (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). + field_tys = zip (map fieldLabelName (dataConFieldLabels data_con)) + arg_tys in -- Check the fields @@ -242,90 +245,100 @@ tcPat sig_fn pat@(RecPatIn name rpats) pat_ty = 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) -> + = 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 liftedTypeKind `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 ) + tcLookupGlobalId 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) - where - matching_fields = [ty | (f,ty) <- field_tys, f == field_label] - (rhs_ty : extras) = matching_fields \end{code} %************************************************************************ %* * -\subsection{Non-overloaded literals} +\subsection{Literals} %* * %************************************************************************ \begin{code} -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! +tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty + -- cf tcExpr on LitLits + = tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass -> + newDicts (LitLitOrigin (_UNPK_ s)) + [mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ dicts -> + returnTc (LitPat (HsLitLit s pat_ty) pat_ty, mkLIE dicts, emptyBag, emptyBag, emptyLIE) + +tcPat tc_bndr pat@(LitPatIn lit@(HsString _)) pat_ty + = unifyTauTy pat_ty stringTy `thenTc_` + tcLookupGlobalId eqStringName `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) -> + tcLookupGlobalId eqName `thenNF_Tc` \ eq_sel_id -> + newMethod origin eq_sel_id [pat_ty] `thenNF_Tc` \ eq -> + + returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) over_lit_expr), + lie1 `plusLIE` unitLIE eq, + 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 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 sig_fn pat@(LitPatIn lit@(HsInt i)) pat_ty - = tcOverloadedLitPat pat lit (OverloadedIntegral i) pat_ty - -tcPat sig_fn pat@(LitPatIn lit@(HsFrac f)) pat_ty - = tcOverloadedLitPat pat lit (OverloadedFractional f) pat_ty - - -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) 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 lit pat_ty - (SectionR (HsVar ge_id) over_lit_expr) - (SectionR (HsVar minus_id) over_lit_expr), - lie1 `plusLIE` lie2 `plusLIE` lie3, +tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty + = tc_bndr name pat_ty `thenTc` \ (co_fn, lie1, bndr_id) -> + -- The '-' part is re-mappable syntax + tcLookupId minus_name `thenNF_Tc` \ minus_sel_id -> + tcLookupGlobalId geName `thenNF_Tc` \ ge_sel_id -> + newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie2) -> + newMethod origin ge_sel_id [pat_ty] `thenNF_Tc` \ ge -> + newMethod origin minus_sel_id [pat_ty] `thenNF_Tc` \ minus -> + + returnTc (NPlusKPat bndr_id i pat_ty + (SectionR (HsVar (instToId ge)) over_lit_expr) + (SectionR (HsVar (instToId minus)) over_lit_expr), + lie1 `plusLIE` lie2 `plusLIE` mkLIE [ge,minus], emptyBag, unitBag (name, bndr_id), emptyLIE) where origin = PatOrigin pat - -tcPat sig_fn (NPlusKPatIn pat other) pat_ty - = panic "TcPat:NPlusKPat: not an HsInt literal" \end{code} %************************************************************************ @@ -337,19 +350,19 @@ tcPat sig_fn (NPlusKPatIn pat other) pat_ty Helper functions \begin{code} -tcPats :: (Name -> Maybe TcId) -- Info about signatures - -> [RenamedPat] -> [TcType] -- Excess 'expected types' discarded - -> TcM s ([TcPat], +tcPats :: BinderChecker -- How to deal with variables + -> [RenamedPat] -> [TcType] -- Excess 'expected types' discarded + -> TcM ([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 tc_bndr [] 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) -> +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, @@ -358,61 +371,37 @@ tcPats sig_fn (ty:tys) (pat:pats) ------------------------------------------------------ \begin{code} -tcSimpleLitPat lit lit_ty pat_ty - = unifyTauTy pat_ty lit_ty `thenTc_` - returnTc (LitPat lit lit_ty, emptyLIE, emptyBag, emptyBag, emptyLIE) - - -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 (NPat lit pat_ty (HsApp (HsVar eq_id) - over_lit_expr), - lie1 `plusLIE` lie2, - emptyBag, emptyBag, emptyLIE) - where - origin = PatOrigin pat -\end{code} - ------------------------------------------------------- -\begin{code} 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 -> + tcLookupDataCon con_name `thenNF_Tc` \ data_con -> -- Instantiate it let - (tvs, theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con + (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 - ex_theta' = substTopTheta tenv ex_theta - arg_tys' = map (substTopTy tenv) arg_tys + ex_theta' = substTheta 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 - newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ (lie_avail, dicts) -> + newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ dicts -> -- Check overall type matches unifyTauTy pat_ty result_ty `thenTc_` - returnTc (data_con, ex_tvs', dicts, lie_avail, arg_tys') - } + returnTc (data_con, ex_tvs', map instToId dicts, mkLIE dicts, arg_tys') \end{code} ------------------------------------------------------ \begin{code} -tcConPat sig_fn pat con_name arg_pats pat_ty +tcConPat tc_bndr pat con_name arg_pats pat_ty = tcAddErrCtxt (patCtxt pat) $ -- Check the constructor itself @@ -427,7 +416,7 @@ tcConPat sig_fn pat con_name arg_pats pat_ty (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) -> + tcPats tc_bndr arg_pats arg_tys' `thenTc` \ (arg_pats', lie_req, tvs, ids, lie_avail2) -> returnTc (ConPat data_con pat_ty ex_tvs' dicts arg_pats', lie_req, @@ -439,6 +428,48 @@ tcConPat sig_fn pat con_name arg_pats pat_ty %************************************************************************ %* * +\subsection{Subsumption} +%* * +%************************************************************************ + +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} +tcSubPat :: TcSigmaType -> TcSigmaType -> TcM (PatCoFn, LIE) + +tcSubPat sig_ty exp_ty + = tcSub exp_ty sig_ty `thenTc` \ (co_fn, lie) -> + -- co_fn is a coercion on *expressions*, and we + -- need to make a coercion on *patterns* + if isIdCoercion co_fn then + ASSERT( isEmptyLIE lie ) + returnNF_Tc (idCoercion, emptyLIE) + else + tcGetUnique `thenNF_Tc` \ uniq -> + let + arg_id = mkSysLocal SLIT("sub") uniq exp_ty + the_fn = DictLam [arg_id] (co_fn <$> HsVar arg_id) + pat_co_fn p = SigPat p exp_ty the_fn + in + returnNF_Tc (mkCoercion pat_co_fn, lie) +\end{code} + + +%************************************************************************ +%* * \subsection{Errors and contexts} %* * %************************************************************************ @@ -447,14 +478,6 @@ tcConPat sig_fn pat con_name arg_pats pat_ty 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]) - badFieldCon :: Name -> Name -> SDoc badFieldCon con field = hsep [ptext SLIT("Constructor") <+> quotes (ppr con), @@ -462,7 +485,9 @@ badFieldCon con field polyPatSig :: TcType -> SDoc polyPatSig sig_ty - = hang (ptext SLIT("Polymorphic type signature in pattern")) + = hang (ptext SLIT("Illegal polymorphic type signature in pattern:")) 4 (ppr sig_ty) + +badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat \end{code}