X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=f816b7c181321ea77c9f10105c5af2a01a504bf2;hb=b085ee40c7f265a5977ea6ec1c415e573be5ff8c;hp=7d5e823f91d6ad8c0502119ec7e6c182deba044f;hpb=0fe14834f10717e06efca4cef07d0640a99ff0a7;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 7d5e823..f816b7c 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -17,30 +17,29 @@ import TcHsSyn ( TcPat, TcId, simpleHsLitTy ) import TcMonad import Inst ( InstOrigin(..), emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, isEmptyLIE, - newMethod, newOverloadedLit, newDicts + newMethod, newMethodFromName, newOverloadedLit, newDicts, tcInstDataCon ) import Id ( mkLocalId, mkSysLocal ) import Name ( Name ) import FieldLabel ( fieldLabelName ) 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 TcMType ( newTyVarTy, zapToType ) +import TcType ( TcType, TcTyVar, TcSigmaType, + mkClassPred, liftedTypeKind ) +import TcUnify ( tcSubOff, TcHoleType, + unifyTauTy, unifyListTy, unifyPArrTy, unifyTupleTy, + mkCoercion, idCoercion, isIdCoercion, + (<$>), PatCoFn ) import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) import TysWiredIn ( stringTy ) import CmdLineOpts ( opt_IrrefutableTuples ) -import DataCon ( dataConSig, dataConFieldLabels, - dataConSourceArity - ) -import Subst ( substTy, substTheta ) +import DataCon ( dataConFieldLabels, dataConSourceArity ) import PrelNames ( eqStringName, eqName, geName, cCallableClassName ) import BasicTypes ( isBoxed ) import Bag import Outputable +import FastString \end{code} @@ -68,8 +67,7 @@ tcMonoPatBndr :: BinderChecker -- so there's no polymorphic guy to worry about tcMonoPatBndr binder_name pat_ty - | Just tv <- tcGetTyVar_maybe pat_ty, - isHoleTyVar tv + = zapToType pat_ty `thenNF_Tc` \ 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* @@ -78,14 +76,8 @@ tcMonoPatBndr binder_name pat_ty -- 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) + + returnTc (idCoercion, emptyLIE, mkLocalId binder_name pat_ty') \end{code} @@ -99,7 +91,7 @@ tcMonoPatBndr binder_name pat_ty tcPat :: BinderChecker -> RenamedPat - -> TcSigmaType -- Expected type derived from the context + -> TcHoleType -- Expected type derived from the context -- In the case of a function with a rank-2 signature, -- this type might be a forall type. @@ -144,13 +136,17 @@ tcPat tc_bndr pat_in@(AsPatIn name pat) pat_ty tvs, (name, bndr_id) `consBag` ids, lie_avail) tcPat tc_bndr WildPatIn pat_ty - = returnTc (WildPat pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE) + = zapToType pat_ty `thenNF_Tc` \ pat_ty' -> + -- We might have an incoming 'hole' type variable; no annotation + -- so zap it to a type. Rather like tcMonoPatBndr. + returnTc (WildPat pat_ty', emptyLIE, emptyBag, emptyBag, emptyLIE) tcPat tc_bndr (ParPatIn parend_pat) pat_ty = tcPat tc_bndr parend_pat pat_ty -tcPat tc_bndr (SigPatIn pat sig) pat_ty - = tcHsSigType PatSigCtxt sig `thenTc` \ sig_ty -> +tcPat tc_bndr pat_in@(SigPatIn pat sig) pat_ty + = tcAddErrCtxt (patCtxt pat_in) $ + 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) @@ -159,7 +155,7 @@ tcPat tc_bndr (SigPatIn pat sig) pat_ty %************************************************************************ %* * -\subsection{Explicit lists and tuples} +\subsection{Explicit lists, parallel arrays, and tuples} %* * %************************************************************************ @@ -170,6 +166,12 @@ tcPat tc_bndr pat_in@(ListPatIn pats) pat_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) +tcPat tc_bndr pat_in@(PArrPatIn pats) pat_ty + = tcAddErrCtxt (patCtxt pat_in) $ + unifyPArrTy pat_ty `thenTc` \ elem_ty -> + tcPats tc_bndr pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) -> + returnTc (PArrPat elem_ty pats', lie_req, tvs, ids, lie_avail) + tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty = tcAddErrCtxt (patCtxt pat_in) $ @@ -222,7 +224,10 @@ 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) -> + tcConstructor pat name `thenTc` \ (data_con, lie_req1, ex_tvs, ex_dicts, lie_avail1, arg_tys, con_res_ty) -> + + -- Check overall type matches (c.f. tcConPat) + tcSubPat con_res_ty pat_ty `thenTc` \ (co_fn, lie_req2) -> let -- Don't use zipEqual! If the constructor isn't really a record, then -- dataConFieldLabels will be empty (and each field in the pattern @@ -232,10 +237,10 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty in -- Check the fields - tc_fields field_tys rpats `thenTc` \ (rpats', lie_req, tvs, ids, lie_avail2) -> + tc_fields field_tys rpats `thenTc` \ (rpats', lie_req3, tvs, ids, lie_avail2) -> - returnTc (RecPat data_con pat_ty ex_tvs dicts rpats', - lie_req, + returnTc (RecPat data_con pat_ty ex_tvs ex_dicts rpats', + lie_req1 `plusLIE` lie_req2 `plusLIE` lie_req3, listToBag ex_tvs `unionBags` tvs, ids, lie_avail1 `plusLIE` lie_avail2) @@ -287,7 +292,7 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty -- cf tcExpr on LitLits = tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass -> - newDicts (LitLitOrigin (_UNPK_ s)) + newDicts (LitLitOrigin (unpackFS s)) [mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ dicts -> returnTc (LitPat (HsLitLit s pat_ty) pat_ty, mkLIE dicts, emptyBag, emptyBag, emptyLIE) @@ -302,9 +307,8 @@ tcPat tc_bndr (LitPatIn simple_lit) pat_ty 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 -> + = newOverloadedLit origin over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> + newMethodFromName origin pat_ty eqName `thenNF_Tc` \ eq -> returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) over_lit_expr), lie1 `plusLIE` unitLIE eq, @@ -325,11 +329,11 @@ tcPat tc_bndr pat@(NPatIn over_lit) pat_ty \begin{code} tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty = tc_bndr name pat_ty `thenTc` \ (co_fn, lie1, bndr_id) -> + newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie2) -> + newMethodFromName origin pat_ty geName `thenNF_Tc` \ ge -> + -- 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 @@ -371,32 +375,14 @@ tcPats tc_bndr (ty:tys) (pat:pats) ------------------------------------------------------ \begin{code} -tcConstructor pat con_name pat_ty +tcConstructor pat con_name = -- Check that it's a constructor tcLookupDataCon con_name `thenNF_Tc` \ 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 - 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` \ dicts -> - - -- Check overall type matches - unifyTauTy pat_ty result_ty `thenTc_` + tcInstDataCon (PatOrigin pat) data_con `thenNF_Tc` \ (_, ex_dicts, arg_tys, result_ty, lie_req, ex_lie, ex_tvs) -> - returnTc (data_con, ex_tvs', map instToId dicts, mkLIE dicts, arg_tys') + returnTc (data_con, lie_req, ex_tvs, ex_dicts, ex_lie, arg_tys, result_ty) \end{code} ------------------------------------------------------ @@ -405,7 +391,12 @@ 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') -> + tcConstructor pat con_name `thenTc` \ (data_con, lie_req1, ex_tvs, ex_dicts, lie_avail1, arg_tys, con_res_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 `thenTc` \ (co_fn, lie_req2) -> -- Check correct arity let @@ -416,11 +407,11 @@ tcConPat tc_bndr pat con_name arg_pats pat_ty (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) -> + tcPats tc_bndr arg_pats arg_tys `thenTc` \ (arg_pats', lie_req3, tvs, ids, lie_avail2) -> - returnTc (ConPat data_con pat_ty ex_tvs' dicts arg_pats', - lie_req, - listToBag ex_tvs' `unionBags` tvs, + returnTc (co_fn <$> ConPat data_con pat_ty ex_tvs ex_dicts arg_pats', + lie_req1 `plusLIE` lie_req2 `plusLIE` lie_req3, + listToBag ex_tvs `unionBags` tvs, ids, lie_avail1 `plusLIE` lie_avail2) \end{code} @@ -448,10 +439,10 @@ tcSubPat does the work (forall a. a->a in the example) \begin{code} -tcSubPat :: TcSigmaType -> TcSigmaType -> TcM (PatCoFn, LIE) +tcSubPat :: TcSigmaType -> TcHoleType -> TcM (PatCoFn, LIE) tcSubPat sig_ty exp_ty - = tcSub exp_ty sig_ty `thenTc` \ (co_fn, lie) -> + = tcSubOff sig_ty exp_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 @@ -460,7 +451,7 @@ tcSubPat sig_ty exp_ty else tcGetUnique `thenNF_Tc` \ uniq -> let - arg_id = mkSysLocal SLIT("sub") uniq exp_ty + arg_id = mkSysLocal FSLIT("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 @@ -475,7 +466,7 @@ tcSubPat sig_ty exp_ty %************************************************************************ \begin{code} -patCtxt pat = hang (ptext SLIT("In the pattern:")) +patCtxt pat = hang (ptext SLIT("When checking the pattern:")) 4 (ppr pat) badFieldCon :: Name -> Name -> SDoc