X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Ftypecheck%2FTcPat.lhs;h=ecca2496c3611beb2a6885521e9944ca1a4586f8;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hp=064067534d434e8e99ec2259149948d97bf7f2d5;hpb=a6fdf61f392cde7fdcb35bdb28250e99754d27eb;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 0640675..ecca249 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -18,7 +18,7 @@ module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit, #include "HsVersions.h" -import {-# SOURCE #-} TcExpr( tcSyntaxOp ) +import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho) import HsSyn import TcHsSyn @@ -63,7 +63,7 @@ import FastString \begin{code} tcLetPat :: (Name -> Maybe TcRhoType) -> LPat Name -> BoxySigmaType - -> TcM a + -> TcM a -> TcM (LPat TcId, a) tcLetPat sig_fn pat pat_ty thing_inside = do { let init_state = PS { pat_ctxt = LetPat sig_fn, @@ -210,6 +210,7 @@ bindInstsOfPatId id thing_inside ------------------- unBoxPatBndrType ty name = unBoxArgType ty (ptext SLIT("The variable") <+> quotes (ppr name)) unBoxWildCardType ty = unBoxArgType ty (ptext SLIT("A wild-card pattern")) +unBoxViewPatType ty pat = unBoxArgType ty (ptext SLIT("The view pattern") <+> ppr pat) unBoxArgType :: BoxyType -> SDoc -> TcM TcType -- In addition to calling unbox, unBoxArgType ensures that the type is of ArgTypeKind; @@ -312,11 +313,12 @@ tc_lpat (L span pat) pat_ty pstate thing_inside -------------------- tc_pat :: PatState - -> Pat Name -> BoxySigmaType -- Fully refined result type - -> (PatState -> TcM a) -- Thing inside - -> TcM (Pat TcId, -- Translated pattern - [TcTyVar], -- Existential binders - a) -- Result of thing inside + -> Pat Name + -> BoxySigmaType -- Fully refined result type + -> (PatState -> TcM a) -- Thing inside + -> TcM (Pat TcId, -- Translated pattern + [TcTyVar], -- Existential binders + a) -- Result of thing inside tc_pat pstate (VarPat name) pat_ty thing_inside = do { id <- tcPatBndr pstate name pat_ty @@ -394,6 +396,32 @@ tc_pat pstate (AsPat (L nm_loc name) pat) pat_ty thing_inside -- If you fix it, don't forget the bindInstsOfPatIds! ; return (AsPat (L nm_loc bndr_id) pat', tvs, res) } +tc_pat pstate (orig@(ViewPat expr pat _)) overall_pat_ty thing_inside + = do { -- morally, expr must have type + -- `forall a1...aN. OPT' -> B` + -- where overall_pat_ty is an instance of OPT'. + -- Here, we infer a rho type for it, + -- which replaces the leading foralls and constraints + -- with fresh unification variables. + (expr',expr'_inferred) <- tcInferRho expr + -- next, we check that expr is coercible to `overall_pat_ty -> pat_ty` + ; let expr'_expected = \ pat_ty -> (mkFunTy overall_pat_ty pat_ty) + -- tcSubExp: expected first, offered second + -- returns coercion + -- + -- NOTE: this forces pat_ty to be a monotype (because we use a unification + -- variable to find it). this means that in an example like + -- (view -> f) where view :: _ -> forall b. b + -- we will only be able to use view at one instantation in the + -- rest of the view + ; (expr_coerc, pat_ty) <- tcInfer (\ pat_ty -> tcSubExp (expr'_expected pat_ty) expr'_inferred) + -- pattern must have pat_ty + ; (pat', tvs, res) <- tc_lpat pat pat_ty pstate thing_inside + -- this should get zonked later on, but we unBox it here + -- so that we do the same checks as above + ; annotation_ty <- unBoxViewPatType overall_pat_ty orig + ; return (ViewPat (mkLHsWrap expr_coerc expr') pat' annotation_ty, tvs, res) } + -- Type signatures in patterns -- See Note [Pattern coercions] below tc_pat pstate (SigPatIn pat sig_ty) pat_ty thing_inside @@ -408,20 +436,21 @@ 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 <- boxySplitListTy pat_ty + = do { (elt_ty, coi) <- boxySplitListTy pat_ty ; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty) pats pstate thing_inside - ; return (ListPat pats' elt_ty, pats_tvs, res) } + ; return (mkCoPatCoI coi (ListPat pats' elt_ty) pat_ty, pats_tvs, res) } tc_pat pstate (PArrPat pats _) pat_ty thing_inside - = do { [elt_ty] <- boxySplitTyConApp parrTyCon pat_ty + = do { (elt_ty, coi) <- boxySplitPArrTy pat_ty ; (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 (PArrPat pats' elt_ty, pats_tvs, res) } + ; ifM (null pats) (zapToMonotype pat_ty) -- c.f. ExplicitPArr in TcExpr + ; return (mkCoPatCoI coi (PArrPat pats' elt_ty) pat_ty, pats_tvs, res) } tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside - = do { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length pats)) pat_ty + = do { let tc = tupleTyCon boxity (length pats) + ; (arg_tys, coi) <- boxySplitTyConApp tc pat_ty ; (pats', pats_tvs, res) <- tcMultiple tc_lpat_pr (pats `zip` arg_tys) pstate thing_inside @@ -429,13 +458,17 @@ tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside -- so that we can experiment with lazy tuple-matching. -- This is a pretty odd place to make the switch, but -- it was easy to do. - ; let unmangled_result = TuplePat pats' boxity pat_ty + ; let pat_ty' = mkTyConApp tc arg_tys + -- pat_ty /= pat_ty iff coi /= IdCo + unmangled_result = TuplePat pats' boxity pat_ty' possibly_mangled_result - | opt_IrrefutableTuples && isBoxed boxity = LazyPat (noLoc unmangled_result) - | otherwise = unmangled_result + | opt_IrrefutableTuples && + isBoxed boxity = LazyPat (noLoc unmangled_result) + | otherwise = unmangled_result - ; ASSERT( length arg_tys == length pats ) -- Syntactically enforced - return (possibly_mangled_result, pats_tvs, res) } + ; ASSERT( length arg_tys == length pats ) -- Syntactically enforced + return (mkCoPatCoI coi possibly_mangled_result pat_ty, pats_tvs, res) + } ------------------------ -- Data constructors @@ -455,11 +488,12 @@ 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 (wrapPatCoI (mkSymCoI coi) (LitPat simple_lit) pat_ty, [], res) } + ; returnM (mkCoPatCoI (mkSymCoI coi) (LitPat simple_lit) pat_ty, + [], res) } ------------------------ -- Overloaded patterns: n, and n+k -tc_pat pstate pat@(NPat over_lit mb_neg eq _) pat_ty thing_inside +tc_pat pstate pat@(NPat over_lit mb_neg eq) pat_ty thing_inside = do { let orig = LiteralOrigin over_lit ; lit' <- tcOverloadedLit orig over_lit pat_ty ; eq' <- tcSyntaxOp orig eq (mkFunTys [pat_ty, pat_ty] boolTy) @@ -470,7 +504,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' pat_ty, [], res) } + ; returnM (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) @@ -571,7 +605,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside origin = SigOrigin skol_info -- Instantiate the constructor type variables [a->ty] - ; ctxt_res_tys <- boxySplitTyConAppWithFamily tycon pat_ty + ; (ctxt_res_tys, coi) <- boxySplitTyConAppWithFamily tycon pat_ty ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs -- Get location from monad, -- not from ex_tvs ; let tenv = zipTopTvSubst (univ_tvs ++ ex_tvs) @@ -581,7 +615,9 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside arg_tys' = substTys tenv arg_tys ; 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!") ; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $ tcConArgs data_con arg_tys' arg_pats pstate' thing_inside @@ -593,13 +629,16 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside ; addDataConStupidTheta data_con ctxt_res_tys - ; return - (unwrapFamInstScrutinee tycon ctxt_res_tys $ - 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 }, + ; 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, + 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) } where @@ -610,10 +649,10 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside case tyConFamInst_maybe tycon of Nothing -> boxySplitTyConApp tycon pat_ty Just (fam_tycon, instTys) -> - do { scrutinee_arg_tys <- boxySplitTyConApp fam_tycon pat_ty + do { (scrutinee_arg_tys, coi) <- boxySplitTyConApp fam_tycon pat_ty ; (_, freshTvs, subst) <- tcInstTyVars (tyConTyVars tycon) ; boxyUnifyList (substTys subst instTys) scrutinee_arg_tys - ; return freshTvs + ; return (freshTvs, coi) } where traceMsg = sep [ text "tcConPat:boxySplitTyConAppWithFamily:" <+> @@ -800,7 +839,7 @@ tcOverloadedLit :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsOverLit TcId) -tcOverloadedLit orig lit@(HsIntegral i fi) res_ty +tcOverloadedLit orig lit@(HsIntegral i fi _) res_ty | not (fi `isHsVar` fromIntegerName) -- Do not generate a LitInst for rebindable syntax. -- Reason: If we do, tcSimplify will call lookupInst, which -- will call tcSyntaxName, which does unification, @@ -808,16 +847,16 @@ tcOverloadedLit orig lit@(HsIntegral i fi) res_ty -- ToDo: noLoc sadness = do { integer_ty <- tcMetaTy integerTyConName ; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty res_ty) - ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty)))) } + ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty))) res_ty) } | Just expr <- shortCutIntLit i res_ty - = return (HsIntegral i expr) + = return (HsIntegral i expr res_ty) | otherwise = do { expr <- newLitInst orig lit res_ty - ; return (HsIntegral i expr) } + ; return (HsIntegral i expr res_ty) } -tcOverloadedLit orig lit@(HsFractional r fr) res_ty +tcOverloadedLit orig lit@(HsFractional r fr _) res_ty | not (fr `isHsVar` fromRationalName) -- c.f. HsIntegral case = do { rat_ty <- tcMetaTy rationalTyConName ; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty res_ty) @@ -825,27 +864,27 @@ tcOverloadedLit orig lit@(HsFractional r fr) res_ty -- we're instantiating an overloaded function here, -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2 -- However this'll be picked up by tcSyntaxOp if necessary - ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty)))) } + ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty))) res_ty) } | Just expr <- shortCutFracLit r res_ty - = return (HsFractional r expr) + = return (HsFractional r expr res_ty) | otherwise = do { expr <- newLitInst orig lit res_ty - ; return (HsFractional r expr) } + ; return (HsFractional r expr res_ty) } -tcOverloadedLit orig lit@(HsIsString s fr) res_ty +tcOverloadedLit orig lit@(HsIsString s fr _) res_ty | not (fr `isHsVar` fromStringName) -- c.f. HsIntegral case = do { str_ty <- tcMetaTy stringTyConName ; fr' <- tcSyntaxOp orig fr (mkFunTy str_ty res_ty) - ; return (HsIsString s (HsApp (noLoc fr') (nlHsLit (HsString s)))) } + ; return (HsIsString s (HsApp (noLoc fr') (nlHsLit (HsString s))) res_ty) } | Just expr <- shortCutStringLit s res_ty - = return (HsIsString s expr) + = return (HsIsString s expr res_ty) | otherwise = do { expr <- newLitInst orig lit res_ty - ; return (HsIsString s expr) } + ; return (HsIsString s expr res_ty) } newLitInst :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsExpr TcId) newLitInst orig lit res_ty -- Make a LitInst @@ -992,9 +1031,3 @@ nonRigidResult res_ty inaccessibleAlt msg = hang (ptext SLIT("Inaccessible case alternative:")) 2 msg \end{code} - -\begin{code} -wrapPatCoI :: CoercionI -> Pat a -> TcType -> Pat a -wrapPatCoI IdCo pat ty = pat -wrapPatCoI (ACo co) pat ty = CoPat (WpCo co) pat ty -\end{code}