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
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
-- 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 )
-- 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
-- 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
con1_arg_tys' = map (substTy inst_env) con1_arg_tys
in
tcSubExp result_record_ty res_ty `thenM` \ co_fn ->
- tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ rbinds' ->
+ tcRecordBinds con1 con1_arg_tys' hrbinds `thenM` \ rbinds' ->
-- STEP 5
-- Typecheck the expression to be updated
; 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
%************************************************************************
%* *
-\subsection{@tcId@ typchecks an identifier occurrence}
+\subsection{@tcId@ typechecks an identifier occurrence}
%* *
%************************************************************************
-> 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)