X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=14a1d6d390aac606e6e5122917804958212847a2;hb=fc867aa70e3bc8753287cf1f5e9a5adb05c38dc6;hp=fa0e419aed2200816f1e08da6456224cf9c40b5c;hpb=a2fcf3aa210edff15c5f4603ac267171f89366f0;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index fa0e419..14a1d6d 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -129,6 +129,9 @@ tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExpr expr res_ty tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty ; returnM (HsSCC lbl expr') } +tcExpr (HsTickPragma info expr) res_ty + = do { expr' <- tcMonoExpr expr res_ty + ; returnM (HsTickPragma info expr') } tcExpr (HsCoreAnn lbl expr) res_ty -- hdaume: core annotation = do { expr' <- tcMonoExpr expr res_ty @@ -291,10 +294,19 @@ tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty where tc_elt elt_ty expr = tcPolyExpr expr elt_ty +-- For tuples, take care to preserve rigidity +-- E.g. case (x,y) of .... +-- The scrutinee should have a rigid type if x,y do +-- The general scheme is the same as in tcIdApp tcExpr (ExplicitTuple exprs boxity) res_ty - = do { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length exprs)) res_ty - ; exprs' <- tcPolyExprs exprs arg_tys - ; return (ExplicitTuple exprs' boxity) } + = do { tvs <- newBoxyTyVars [argTypeKind | e <- exprs] + ; let tup_tc = tupleTyCon boxity (length exprs) + tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs) + ; arg_tys <- preSubType tvs (mkVarSet tvs) tup_res_ty res_ty + ; exprs' <- tcPolyExprs exprs arg_tys + ; arg_tys' <- mapM refineBox arg_tys + ; co_fn <- tcFunResTy (tyConName tup_tc) (mkTyConApp tup_tc arg_tys') res_ty + ; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) } tcExpr (HsProc pat cmd) res_ty = do { (pat', cmd') <- tcProc pat cmd res_ty @@ -370,7 +382,7 @@ tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty -- don't know how to do the update otherwise. -tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty +tcExpr expr@(RecordUpd record_expr hrbinds@(HsRecordBinds rbinds) _ _ _) res_ty = -- STEP 0 -- Check that the field names are really field names ASSERT( notNull rbinds ) @@ -392,10 +404,12 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty -- Figure out the tycon and data cons from the first field name let -- It's OK to use the non-tc splitters here (for a selector) - upd_field_lbls = recBindFields rbinds + upd_field_lbls = recBindFields hrbinds sel_id : _ = sel_ids (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if - data_cons = tyConDataCons tycon -- it's not a field label + data_cons = tyConDataCons tycon -- it's not a field label + -- NB: for a data type family, the tycon is the instance tycon + relevant_cons = filter is_relevant data_cons is_relevant con = all (`elem` dataConFieldLabels con) upd_field_lbls in @@ -404,7 +418,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty -- Check that at least one constructor has all the named fields -- i.e. has an empty set of bad fields returned by badFields checkTc (not (null relevant_cons)) - (badFieldsUpd rbinds) `thenM_` + (badFieldsUpd hrbinds) `thenM_` -- Check that all relevant data cons are vanilla. Doing record updates on -- GADTs and/or existentials is more than my tiny brain can cope with today @@ -420,12 +434,11 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty let -- A constructor is only relevant to this process if -- it contains *all* the fields that are being updated - con1 = head relevant_cons -- A representative constructor - con1_tyvars = dataConUnivTyVars con1 - con1_flds = dataConFieldLabels con1 - con1_arg_tys = dataConOrigArgTys con1 - common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys - , not (fld `elem` upd_field_lbls) ] + con1 = ASSERT( not (null relevant_cons) ) head relevant_cons -- A representative constructor + (con1_tyvars, theta, con1_arg_tys, con1_res_ty) = dataConSig con1 + con1_flds = dataConFieldLabels con1 + common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys + , not (fld `elem` upd_field_lbls) ] is_common_tv tv = tv `elemVarSet` common_tyvars @@ -433,43 +446,49 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty | is_common_tv tv = returnM result_inst_ty -- Same as result type | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind in - tcInstTyVars con1_tyvars `thenM` \ (_, result_inst_tys, inst_env) -> - zipWithM mk_inst_ty con1_tyvars result_inst_tys `thenM` \ inst_tys -> + ASSERT( null theta ) -- Vanilla datacon + tcInstTyVars con1_tyvars `thenM` \ (_, result_inst_tys, result_inst_env) -> + zipWithM mk_inst_ty con1_tyvars result_inst_tys `thenM` \ scrut_inst_tys -> - -- STEP 3 - -- Typecheck the update bindings. - -- (Do this after checking for bad fields in case there's a field that - -- doesn't match the constructor.) + -- STEP 3: Typecheck the update bindings. + -- Do this after checking for bad fields in case + -- there's a field that doesn't match the constructor. let - result_record_ty = mkTyConApp tycon result_inst_tys - con1_arg_tys' = map (substTy inst_env) con1_arg_tys + result_ty = substTy result_inst_env con1_res_ty + con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys in - tcSubExp result_record_ty res_ty `thenM` \ co_fn -> - tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ rbinds' -> + tcSubExp result_ty res_ty `thenM` \ co_fn -> + tcRecordBinds con1 con1_arg_tys' hrbinds `thenM` \ rbinds' -> - -- STEP 5 - -- Typecheck the expression to be updated + -- STEP 5: Typecheck the expression to be updated let - record_ty = ASSERT( length inst_tys == tyConArity tycon ) - mkTyConApp tycon inst_tys + scrut_inst_env = zipTopTvSubst con1_tyvars scrut_inst_tys + scrut_ty = substTy scrut_inst_env con1_res_ty -- This is one place where the isVanilla check is important - -- So that inst_tys matches the tycon + -- So that inst_tys matches the con1_tyvars in - tcMonoExpr record_expr record_ty `thenM` \ record_expr' -> + tcMonoExpr record_expr scrut_ty `thenM` \ record_expr' -> - -- STEP 6 - -- Figure out the LIE we need. We have to generate some - -- dictionaries for the data type context, since we are going to - -- do pattern matching over the data cons. + -- STEP 6: Figure out the LIE we need. + -- We have to generate some dictionaries for the data type context, + -- since we are going to do pattern matching over the data cons. -- - -- What dictionaries do we need? The tyConStupidTheta tells us. + -- What dictionaries do we need? The dataConStupidTheta tells us. let - theta' = substTheta inst_env (tyConStupidTheta tycon) + theta' = substTheta scrut_inst_env (dataConStupidTheta con1) in instStupidTheta RecordUpdOrigin theta' `thenM_` + -- Step 7: make a cast for the scrutinee, in the case that it's from a type family + let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon + = WpCo $ mkTyConApp co_con scrut_inst_tys + | otherwise + = idHsWrapper + scrut_ty = mkTyConApp tycon scrut_inst_tys -- Type of pattern, the result of the cast + in -- Phew! - returnM (mkHsWrap co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty)) + returnM (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds' + relevant_cons scrut_inst_tys result_inst_tys)) \end{code} @@ -746,7 +765,7 @@ instFun orig fun subst tv_theta_prs ; go True fun ty_theta_prs' } where subst_pr (tvs, theta) - = (map (substTyVar subst) tvs, substTheta subst theta) + = (substTyVars subst tvs, substTheta subst theta) go _ fun [] = return fun @@ -844,6 +863,7 @@ tcArgs fun args qtvs qtys arg_tys ; qtys' <- mapM refineBox qtys -- Exploit new info ; (qtys'', args') <- go (n+1) qtys' args arg_tys ; return (qtys'', arg':args') } + go n qtys args arg_tys = panic "tcArgs" tcArg :: LHsExpr Name -- The function -> Int -- and arg number (for error messages) @@ -909,7 +929,7 @@ tagToEnumError tys %************************************************************************ %* * -\subsection{@tcId@ typchecks an identifier occurrence} +\subsection{@tcId@ typechecks an identifier occurrence} %* * %************************************************************************ @@ -1037,9 +1057,9 @@ tcRecordBinds -> HsRecordBinds Name -> TcM (HsRecordBinds TcId) -tcRecordBinds data_con arg_tys rbinds +tcRecordBinds data_con arg_tys (HsRecordBinds rbinds) = do { mb_binds <- mappM do_bind rbinds - ; return (catMaybes mb_binds) } + ; return (HsRecordBinds (catMaybes mb_binds)) } where flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys do_bind (L loc field_lbl, rhs) @@ -1119,7 +1139,8 @@ predCtxt expr = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr) nonVanillaUpd tycon - = vcat [ptext SLIT("Record update for the non-Haskell-98 data type") <+> quotes (ppr tycon) + = vcat [ptext SLIT("Record update for the non-Haskell-98 data type") + <+> quotes (pprSourceTyCon tycon) <+> ptext SLIT("is not (yet) supported"), ptext SLIT("Use pattern-matching instead")] badFieldsUpd rbinds @@ -1150,8 +1171,7 @@ missingFields con fields = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:") <+> pprWithCommas ppr fields -callCtxt fun args - = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args)) +-- callCtxt fun args = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args)) #ifdef GHCI polySpliceErr :: Id -> SDoc