X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=fca172f3e39cd68bf6bf0a15c1929c6ac61f3ad8;hb=e9efdf979386e596394aee9984593d518866fe41;hp=ecca2496c3611beb2a6885521e9944ca1a4586f8;hpb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index ecca249..fca172f 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -13,7 +13,7 @@ TcPat: Typechecking patterns -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit, +module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcProcPat, tcOverloadedLit, addDataConStupidTheta, badFieldCon, polyPatSig ) where #include "HsVersions.h" @@ -96,24 +96,29 @@ tcLamPats :: [LPat Name] -- Patterns, -- 5. Check that no existentials escape tcLamPats pats tys res_ty thing_inside - = tc_lam_pats (zipEqual "tcLamPats" pats tys) + = tc_lam_pats LamPat (zipEqual "tcLamPats" pats tys) (emptyRefinement, res_ty) thing_inside tcLamPat :: LPat Name -> BoxySigmaType -> (Refinement,BoxyRhoType) -- Result type -> ((Refinement,BoxyRhoType) -> TcM a) -- Checker for body, given its result type -> TcM (LPat TcId, a) -tcLamPat pat pat_ty res_ty thing_inside - = do { ([pat'],thing) <- tc_lam_pats [(pat, pat_ty)] res_ty thing_inside + +tcProcPat = tc_lam_pat ProcPat +tcLamPat = tc_lam_pat LamPat + +tc_lam_pat ctxt pat pat_ty res_ty thing_inside + = do { ([pat'],thing) <- tc_lam_pats ctxt [(pat, pat_ty)] res_ty thing_inside ; return (pat', thing) } ----------------- -tc_lam_pats :: [(LPat Name,BoxySigmaType)] +tc_lam_pats :: PatCtxt + -> [(LPat Name,BoxySigmaType)] -> (Refinement,BoxyRhoType) -- Result type -> ((Refinement,BoxyRhoType) -> TcM a) -- Checker for body, given its result type -> TcM ([LPat TcId], a) -tc_lam_pats pat_ty_prs (reft, res_ty) thing_inside - = do { let init_state = PS { pat_ctxt = LamPat, pat_reft = reft, pat_eqs = False } +tc_lam_pats ctxt pat_ty_prs (reft, res_ty) thing_inside + = do { let init_state = PS { pat_ctxt = ctxt, pat_reft = reft, pat_eqs = False } ; (pats', ex_tvs, res) <- tcMultiple tc_lpat_pr pat_ty_prs init_state $ \ pstate' -> refineEnvironment (pat_reft pstate') (pat_eqs pstate') $ @@ -156,6 +161,8 @@ data PatState = PS { data PatCtxt = LamPat + | ProcPat -- The pattern in (proc pat -> ...) + -- see Note [Arrows and patterns] | LetPat (Name -> Maybe TcRhoType) -- Used for let(rec) bindings patSigCtxt :: PatState -> UserTypeCtxt @@ -173,18 +180,6 @@ patSigCtxt other = LamPatSigCtxt \begin{code} tcPatBndr :: PatState -> Name -> BoxySigmaType -> TcM TcId -tcPatBndr (PS { pat_ctxt = LamPat }) bndr_name pat_ty - = do { pat_ty' <- unBoxPatBndrType pat_ty bndr_name - -- We have an undecorated binder, so we do rule ABS1, - -- by unboxing the boxy type, forcing any un-filled-in - -- boxes to become monotypes - -- NB that pat_ty' can still be a polytype: - -- data T = MkT (forall a. a->a) - -- f t = case t of { MkT g -> ... } - -- Here, the 'g' must get type (forall a. a->a) from the - -- MkT context - ; return (Id.mkLocalId bndr_name pat_ty') } - tcPatBndr (PS { pat_ctxt = LetPat lookup_sig }) bndr_name pat_ty | Just mono_ty <- lookup_sig bndr_name = do { mono_name <- newLocalName bndr_name @@ -196,6 +191,18 @@ tcPatBndr (PS { pat_ctxt = LetPat lookup_sig }) bndr_name pat_ty ; mono_name <- newLocalName bndr_name ; return (Id.mkLocalId mono_name pat_ty') } +tcPatBndr (PS { pat_ctxt = _lam_or_proc }) bndr_name pat_ty + = do { pat_ty' <- unBoxPatBndrType pat_ty bndr_name + -- We have an undecorated binder, so we do rule ABS1, + -- by unboxing the boxy type, forcing any un-filled-in + -- boxes to become monotypes + -- NB that pat_ty' can still be a polytype: + -- data T = MkT (forall a. a->a) + -- f t = case t of { MkT g -> ... } + -- Here, the 'g' must get type (forall a. a->a) from the + -- MkT context + ; return (Id.mkLocalId bndr_name pat_ty') } + ------------------- bindInstsOfPatId :: TcId -> TcM a -> TcM (a, LHsBinds TcId) @@ -601,21 +608,45 @@ tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon -> TcM (Pat TcId, [TcTyVar], a) tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside = do { let (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _) = dataConFullSig data_con - skol_info = PatSkol data_con - origin = SigOrigin skol_info + skol_info = PatSkol data_con + origin = SigOrigin skol_info + full_theta = eq_theta ++ dict_theta -- Instantiate the constructor type variables [a->ty] + -- This may involve doing a family-instance coercion, and building a wrapper ; (ctxt_res_tys, coi) <- boxySplitTyConAppWithFamily tycon pat_ty + ; let pat_ty' = mkTyConApp tycon ctxt_res_tys + -- pat_ty /= pat_ty iff coi /= IdCo + wrap_res_pat res_pat + = mkCoPatCoI coi (unwrapFamInstScrutinee tycon ctxt_res_tys res_pat) pat_ty + + -- Add the stupid theta + ; addDataConStupidTheta data_con ctxt_res_tys + ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs -- Get location from monad, -- not from ex_tvs ; let tenv = zipTopTvSubst (univ_tvs ++ ex_tvs) (ctxt_res_tys ++ mkTyVarTys ex_tvs') - eq_spec' = substEqSpec tenv eq_spec - theta' = substTheta tenv (eq_theta ++ dict_theta) - arg_tys' = substTys tenv arg_tys - + arg_tys' = substTys tenv arg_tys + + ; if null ex_tvs && null eq_spec && null full_theta + then do { -- The common case; no class bindings etc (see Note [Arrows and patterns]) + (arg_pats', inner_tvs, res) <- tcConArgs data_con arg_tys' + arg_pats pstate thing_inside + ; let res_pat = ConPatOut { pat_con = L con_span data_con, + pat_tvs = [], pat_dicts = [], pat_binds = emptyLHsBinds, + pat_args = arg_pats', pat_ty = pat_ty' } + + ; return (wrap_res_pat res_pat, inner_tvs, res) } + + else do -- The general case, with existential, and local equality constraints + { let eq_spec' = substEqSpec tenv eq_spec + theta' = substTheta tenv full_theta + ctxt = pat_ctxt pstate + ; checkTc (case ctxt of { ProcPat -> False; other -> True }) + (existentialProcPat data_con) ; co_vars <- newCoVars eq_spec' -- Make coercion variables - ; traceTc (text "tcConPat: refineAlt") + ; traceTc (text "tcConPat: refineAlt") ; pstate' <- refineAlt data_con pstate ex_tvs' co_vars pat_ty ; traceTc (text "tcConPat: refineAlt done!") @@ -625,22 +656,15 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside ; loc <- getInstLoc origin ; dicts <- newDictBndrs loc theta' ; dict_binds <- tcSimplifyCheckPat loc co_vars (pat_reft pstate') - ex_tvs' dicts lie_req - - ; addDataConStupidTheta data_con ctxt_res_tys + ex_tvs' dicts lie_req - ; let pat_ty' = mkTyConApp tycon ctxt_res_tys - -- pat_ty /= pat_ty iff coi /= IdCo - res_pat = ConPatOut { pat_con = L con_span data_con, + ; let res_pat = ConPatOut { pat_con = L con_span data_con, pat_tvs = ex_tvs' ++ co_vars, pat_dicts = map instToVar dicts, pat_binds = dict_binds, pat_args = arg_pats', pat_ty = pat_ty' } - ; return - (mkCoPatCoI coi - (unwrapFamInstScrutinee tycon ctxt_res_tys res_pat) pat_ty, - ex_tvs' ++ inner_tvs, res) - } + ; return (wrap_res_pat res_pat, ex_tvs' ++ inner_tvs, res) + } } where -- Split against the family tycon if the pattern constructor -- belongs to a family instance tycon. @@ -767,6 +791,30 @@ addDataConStupidTheta data_con inst_tys inst_theta = substTheta tenv stupid_theta \end{code} +Note [Arrows and patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +(Oct 07) Arrow noation has the odd property that it involves "holes in the scope". +For example: + expr :: Arrow a => a () Int + expr = proc (y,z) -> do + x <- term -< y + expr' -< x + +Here the 'proc (y,z)' binding scopes over the arrow tails but not the +arrow body (e.g 'term'). As things stand (bogusly) all the +constraints from the proc body are gathered together, so constraints +from 'term' will be seen by the tcPat for (y,z). But we must *not* +bind constraints from 'term' here, becuase the desugarer will not make +these bindings scope over 'term'. + +The Right Thing is not to confuse these constraints together. But for +now the Easy Thing is to ensure that we do not have existential or +GADT constraints in a 'proc', and to short-cut the constraint +simplification for such vanilla patterns so that it binds no +constraints. Hence the 'fast path' in tcConPat; but it's also a good +plan for ordinary vanilla patterns to bypass the constraint +simplification step. + %************************************************************************ %* * @@ -1011,10 +1059,15 @@ badFieldCon con field polyPatSig :: TcType -> SDoc polyPatSig sig_ty = hang (ptext SLIT("Illegal polymorphic type signature in pattern:")) - 4 (ppr sig_ty) + 2 (ppr sig_ty) badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat +existentialProcPat :: DataCon -> SDoc +existentialProcPat con + = hang (ptext SLIT("Illegal constructor") <+> quotes (ppr con) <+> ptext SLIT("in a 'proc' pattern")) + 2 (ptext SLIT("Proc patterns cannot use existentials or GADTs")) + lazyPatErr pat tvs = failWithTc $ hang (ptext SLIT("A lazy (~) pattern cannot bind existential type variables"))