X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=482baba4af0021510ee3451fe20f408a588a0ae4;hb=58521c72cec262496dabf5fffb057d25ab17a0f7;hp=784d466bde1ea9eca0e34cb5e358c84db3f3aff3;hpb=97a8fe8780307e95829034117efa98d2e27109cd;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 784d466..482baba 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -280,6 +280,33 @@ tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
 	     ; qtys' <- mapM refineBox qtys	-- c.f. tcArgs 
 	     ; return (qtys', arg2') }
     tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR"
+
+-- 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 in_expr@(ExplicitTuple tup_args boxity) res_ty
+  = do { let kind = case boxity of { Boxed   -> liftedTypeKind
+                                   ; Unboxed -> argTypeKind }
+             arity = length tup_args
+             tup_tc = tupleTyCon boxity arity
+             mk_tup_res_ty arg_tys 
+                 = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args]
+                            (mkTyConApp tup_tc arg_tys)
+
+       ; checkWiredInTyCon tup_tc       -- Ensure instances are available
+       ; tvs <- newBoxyTyVars (replicate arity kind)
+       ; let arg_tys1 = map mkTyVarTy tvs
+       ; arg_tys2 <- preSubType tvs (mkVarSet tvs) (mk_tup_res_ty arg_tys1) res_ty
+       
+       ; let go (Missing _,    arg_ty) = return (Missing arg_ty)
+             go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
+			                    ; return (Present expr') }
+       ; tup_args' <- mapM go (tup_args `zip` arg_tys2)
+       
+       ; arg_tys3 <- mapM refineBox arg_tys2
+       ; co_fn <- tcSubExp TupleOrigin (mk_tup_res_ty arg_tys3) res_ty
+       ; return (mkHsWrap co_fn (ExplicitTuple tup_args' boxity)) }
 \end{code}
 
 \begin{code}
@@ -344,23 +371,6 @@ 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	{ let kind = case boxity of { Boxed   -> liftedTypeKind
-				    ; Unboxed -> argTypeKind }
-	; tvs <- newBoxyTyVars [kind | e <- exprs]
-	; let tup_tc     = tupleTyCon boxity (length exprs)
-	      tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs)
-	; checkWiredInTyCon tup_tc	-- Ensure instances are available
-	; arg_tys  <- preSubType tvs (mkVarSet tvs) tup_res_ty res_ty
-	; exprs'   <- tcPolyExprs exprs arg_tys
-	; arg_tys' <- mapM refineBox arg_tys
-	; co_fn    <- tcSubExp TupleOrigin (mkTyConApp tup_tc arg_tys') res_ty
-	; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) }
-
 tcExpr (HsProc pat cmd) res_ty
   = do	{ (pat', cmd', coi) <- tcProc pat cmd res_ty
 	; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
@@ -457,12 +467,22 @@ field isn't part of the existential. For example, this should be ok.
   data T a where { MkT { f1::a, f2::b->b } :: T a }
   f :: T a -> b -> T b
   f t b = t { f1=b }
+
 The criterion we use is this:
 
   The types of the updated fields
   mention only the universally-quantified type variables
   of the data constructor
 
+NB: this is not (quite) the same as being a "naughty" record selector
+(See Note [Naughty record selectors]) in TcTyClsDecls), at least 
+in the case of GADTs. Consider
+   data T a where { MkT :: { f :: a } :: T [a] }
+Then f is not "naughty" because it has a well-typed record selector.
+But we don't allow updates for 'f'.  (One could consider trying to
+allow this, but it makes my head hurt.  Badly.  And no one has asked
+for it.)
+
 In principle one could go further, and allow
   g :: T a -> T a
   g t = t { f2 = \x -> x }
@@ -529,7 +549,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
 	      con1_flds = dataConFieldLabels con1
 	      con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
    	      
-	-- STEP 2
+	-- Step 2
 	-- 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)