X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=e8f108da88fa25e830d422deddf2a1d52b4e20e1;hb=78ec7aabf27eae748efdc56583ec4e5a6d136ba8;hp=9c845b6555342e72d45134a23f26220f6fc924ba;hpb=1d1c3c727617630beacacaf33022e1daba06a0bb;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 9c845b6..e8f108d 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -51,6 +51,7 @@ import Util import Maybes import Outputable import FastString +import Monad \end{code} @@ -129,7 +130,7 @@ tc_lam_pats ctxt pat_ty_prs (reft, res_ty) thing_inside ; let tys = map snd pat_ty_prs ; tcCheckExistentialPat pats' ex_tvs tys res_ty - ; returnM (pats', res) } + ; return (pats', res) } ----------------- @@ -385,6 +386,9 @@ tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside ; return (LazyPat pat', [], res) } +tc_pat _ p@(QuasiQuotePat _) _ _ + = pprPanic "Should never see QuasiQuotePat in type checker" (ppr p) + tc_pat pstate (WildPat _) pat_ty thing_inside = do { pat_ty' <- unBoxWildCardType pat_ty -- Make sure it's filled in with monotypes ; res <- thing_inside pstate @@ -446,20 +450,25 @@ tc_pat pstate pat@(TypePat ty) pat_ty thing_inside -- Lists, tuples, arrays tc_pat pstate (ListPat pats _) pat_ty thing_inside = do { (elt_ty, coi) <- boxySplitListTy pat_ty + ; let scoi = mkSymCoI coi ; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty) pats pstate thing_inside - ; return (mkCoPatCoI coi (ListPat pats' elt_ty) pat_ty, pats_tvs, res) } + ; return (mkCoPatCoI scoi (ListPat pats' elt_ty) pat_ty, pats_tvs, res) + } tc_pat pstate (PArrPat pats _) pat_ty thing_inside = do { (elt_ty, coi) <- boxySplitPArrTy pat_ty + ; let scoi = mkSymCoI coi ; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty) pats pstate thing_inside - ; ifM (null pats) (zapToMonotype pat_ty) -- c.f. ExplicitPArr in TcExpr - ; return (mkCoPatCoI coi (PArrPat pats' elt_ty) pat_ty, pats_tvs, res) } + ; when (null pats) (zapToMonotype pat_ty >> return ()) -- c.f. ExplicitPArr in TcExpr + ; return (mkCoPatCoI scoi (PArrPat pats' elt_ty) pat_ty, pats_tvs, res) + } tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside = do { let tc = tupleTyCon boxity (length pats) ; (arg_tys, coi) <- boxySplitTyConApp tc pat_ty + ; let scoi = mkSymCoI coi ; (pats', pats_tvs, res) <- tcMultiple tc_lpat_pr (pats `zip` arg_tys) pstate thing_inside @@ -476,7 +485,7 @@ tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside | otherwise = unmangled_result ; ASSERT( length arg_tys == length pats ) -- Syntactically enforced - return (mkCoPatCoI coi possibly_mangled_result pat_ty, pats_tvs, res) + return (mkCoPatCoI scoi possibly_mangled_result pat_ty, pats_tvs, res) } ------------------------ @@ -497,7 +506,7 @@ tc_pat pstate (LitPat simple_lit) pat_ty thing_inside -- pattern coercions have to -- be of kind: pat_ty ~ lit_ty -- hence, sym coi - ; returnM (mkCoPatCoI (mkSymCoI coi) (LitPat simple_lit) pat_ty, + ; return (mkCoPatCoI (mkSymCoI coi) (LitPat simple_lit) pat_ty, [], res) } ------------------------ @@ -513,7 +522,7 @@ tc_pat pstate pat@(NPat over_lit mb_neg eq) pat_ty thing_inside do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty pat_ty) ; return (Just neg') } ; res <- thing_inside pstate - ; returnM (NPat lit' mb_neg' eq', [], res) } + ; return (NPat lit' mb_neg' eq', [], res) } tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside = do { bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty) @@ -531,7 +540,7 @@ tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside ; instStupidTheta orig [mkClassPred icls [pat_ty']] ; res <- tcExtendIdEnv1 name bndr_id (thing_inside pstate) - ; returnM (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) } + ; return (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) } tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut, VarPatOut \end{code} @@ -609,59 +618,82 @@ tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon -> HsConPatDetails Name -> (PatState -> TcM a) -> 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 + = 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 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 + -- 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 + ; let sym_coi = mkSymCoI coi -- boxy split coercion oriented wrongly + pat_ty' = mkTyConApp tycon ctxt_res_tys + -- pat_ty' /= pat_ty iff coi /= IdCo + + wrap_res_pat res_pat = mkCoPatCoI sym_coi uwScrut pat_ty + where + uwScrut = unwrapFamInstScrutinee tycon ctxt_res_tys res_pat + + ; traceTc $ case sym_coi of + IdCo -> text "sym_coi:IdCo" + ACo co -> text "sym_coi: ACoI" <+> ppr co -- 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 + ; 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') 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]) + 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 + 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' } + 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 + else do -- The general case, with existential, and local equality + -- constraints + { let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec] + theta' = substTheta tenv (eq_preds ++ full_theta) + -- order is *important* as we generate the list of + -- dictionary binders from 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") - ; pstate' <- refineAlt data_con pstate ex_tvs' co_vars pat_ty - ; traceTc (text "tcConPat: refineAlt done!") - + + -- Need to test for rigidity if *any* constraints in theta as class + -- constraints may have superclass equality constraints. However, + -- we don't want to check for rigidity if we got here only because + -- ex_tvs was non-null. +-- ; unless (null theta') $ + -- FIXME: AT THE MOMENT WE CHEAT! We only perform the rigidity test + -- if we explicit or implicit (by a GADT def) have equality + -- constraints. + ; unless (all (not . isEqPred) theta') $ + checkTc (isRigidTy pat_ty) (nonRigidMatch data_con) + ; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $ - tcConArgs data_con arg_tys' arg_pats pstate' thing_inside + tcConArgs data_con arg_tys' arg_pats pstate thing_inside ; loc <- getInstLoc origin ; dicts <- newDictBndrs loc theta' - ; dict_binds <- tcSimplifyCheckPat loc co_vars (pat_reft pstate') + ; dict_binds <- tcSimplifyCheckPat loc [] emptyRefinement ex_tvs' dicts lie_req ; let res_pat = ConPatOut { pat_con = L con_span data_con, - pat_tvs = ex_tvs' ++ co_vars, + pat_tvs = ex_tvs', pat_dicts = map instToVar dicts, pat_binds = dict_binds, pat_args = arg_pats', pat_ty = pat_ty' } @@ -838,11 +870,8 @@ refineAlt con pstate ex_tvs [] pat_ty = return pstate -- Common case: no equational constraints refineAlt con pstate ex_tvs co_vars pat_ty - = do { opt_gadt <- doptM Opt_GADTs -- No type-refinement unless GADTs are on - ; if (not opt_gadt) then return pstate - else do - - { checkTc (isRigidTy pat_ty) (nonRigidMatch con) + = -- See Note [Flags and equational constraints] + do { checkTc (isRigidTy pat_ty) (nonRigidMatch con) -- We are matching against a GADT constructor with non-trivial -- constraints, but pattern type is wobbly. For now we fail. -- We can make sense of this, however: @@ -870,9 +899,20 @@ refineAlt con pstate ex_tvs co_vars pat_ty vcat [ ppr con <+> ppr ex_tvs, ppr [(v, tyVarKind v) | v <- co_vars], ppr reft] - } } } + } } \end{code} +Note [Flags and equational constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If there are equational constraints, we take account of them +regardless of flag settings; -XGADTs etc applies only to the +*definition* of a data type. + +An alternative would be also to reject a program that *used* +constructors with equational constraints. But want we should avoid at +all costs is simply to *ignore* the constraints, since that gives +incomprehensible errors (Trac #2004). + %************************************************************************ %* * @@ -1078,11 +1118,11 @@ lazyPatErr pat tvs nonRigidMatch con = hang (ptext SLIT("GADT pattern match in non-rigid context for") <+> quotes (ppr con)) - 2 (ptext SLIT("Tell GHC HQ if you'd like this to unify the context")) + 2 (ptext SLIT("Solution: add a type signature")) nonRigidResult res_ty = hang (ptext SLIT("GADT pattern match with non-rigid result type") <+> quotes (ppr res_ty)) - 2 (ptext SLIT("Tell GHC HQ if you'd like this to unify the context")) + 2 (ptext SLIT("Solution: add a type signature")) inaccessibleAlt msg = hang (ptext SLIT("Inaccessible case alternative:")) 2 msg