Make HsRecordBinds a data type instead of a synonym.

[ghc-hetmet.git] / compiler / typecheck / TcExpr.lhs

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index fa0e419..4151e0d 100644 (file)
--- 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,7 +404,7 @@ 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
@@ -404,7 +416,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
@@ -445,7 +457,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
        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
@@ -746,7 +758,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
 
@@ -909,7 +921,7 @@ tagToEnumError tys
 
 %************************************************************************
 %*                                                                     *
-\subsection{@tcId@ typchecks an identifier occurrence}
+\subsection{@tcId@ typechecks an identifier occurrence}
 %*                                                                     *
 %************************************************************************
 
@@ -1037,9 +1049,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)