From 2f6d1e5ed861d3ece3e51050d7cd11b2f48330bf Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Tue, 12 Jul 2005 13:38:08 +0000
Subject: [PATCH] [project @ 2005-07-12 13:38:08 by simonpj] Check for an
 unboxed tuple binding 	f = (# True, False #)

A fairly recent change, that treats specially non-recursive bindings of a
single variable, failed to take this into account.

tcfail141 tests this case.  (Was simpl008.)
-
---
 ghc/compiler/typecheck/TcBinds.lhs |   25 +++++++++++++++++++------
 1 file changed, 19 insertions(+), 6 deletions(-)

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index b846c0a..26e5fc5 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -20,10 +20,10 @@ import HsSyn		( HsExpr(..), HsBind(..), LHsBinds, Sig(..),
 			  LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds,
 			  collectHsBindBinders, collectPatBinders, pprPatBind
 			)
-import TcHsSyn		( TcId, TcDictBinds, zonkId, mkHsLet )
+import TcHsSyn		( zonkId, mkHsLet )
 
 import TcRnMonad
-import Inst		( InstOrigin(..), newDictsAtLoc, newIPDict, instToId )
+import Inst		( newDictsAtLoc, newIPDict, instToId )
 import TcEnv		( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, 
 			  newLocalName, tcLookupLocalIds, pprBinders,
 			  tcGetGlobalTyVars )
@@ -37,9 +37,9 @@ import TcHsType		( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars,
 import TcPat		( tcPat, PatCtxt(..) )
 import TcSimplify	( bindInstsOfLocalFuns )
 import TcMType		( newTyFlexiVarTy, zonkQuantifiedTyVar, 
-			  tcInstSigType, zonkTcTypes, zonkTcTyVar )
+			  tcInstSigType, zonkTcType, zonkTcTypes, zonkTcTyVar )
 import TcType		( TcTyVar, SkolemInfo(SigSkol), 
-			  TcTauType, TcSigmaType, 
+			  TcTauType, TcSigmaType, isUnboxedTupleType,
 			  mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, 
 			  mkForAllTy, isUnLiftedType, tcGetTyVar, 
 			  mkTyVarTys, tidyOpenTyVar )
@@ -121,7 +121,7 @@ tcHsBootSigs [HsBindGroup binds sigs _]
       = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
 	   ; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) }
 	-- Notice that we make GlobalIds, not LocalIds
-tcHsBootSits groups = pprPanic "tcHsBootSigs" (ppr groups)
+tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
 
 badBootDeclErr :: Message
 badBootDeclErr = ptext SLIT("Illegal declarations in an hs-boot file")
@@ -467,8 +467,16 @@ tcMonoBinds binds lookup_sig is_rec
 	-- 	We want to infer a higher-rank type for f
     setSrcSpan b_loc  	$
     do	{ (matches', rhs_ty) <- tcInfer (tcMatchesFun name matches)
+		-- Check for an unboxed tuple type
+		--	f = (# True, False #)
+		-- Zonk first just in case it's hidden inside a meta type variable
+		-- (This shows up as a (more obscure) kind error 
+		--  in the 'otherwise' case of tcMonoBinds.)
+	; zonked_rhs_ty <- zonkTcType rhs_ty
+	; checkTc (not (isUnboxedTupleType zonked_rhs_ty))
+		  (unboxedTupleErr name zonked_rhs_ty)
 	; mono_name <- newLocalName name
-	; let mono_id = mkLocalId mono_name rhs_ty
+	; let mono_id = mkLocalId mono_name zonked_rhs_ty
 	; return (unitBag (L b_loc (FunBind (L nm_loc mono_id) inf matches')),
 		  [(name, Nothing, mono_id)]) }
 
@@ -920,6 +928,11 @@ unliftedBindErr flavour mbind
 	 4 (ppr mbind)
 
 -----------------------------------------------
+unboxedTupleErr name ty
+  = hang (ptext SLIT("Illegal binding of unboxed tuple"))
+	 4 (ppr name <+> dcolon <+> ppr ty)
+
+-----------------------------------------------
 existentialExplode mbinds
   = hang (vcat [text "My brain just exploded.",
 	        text "I can't handle pattern bindings for existentially-quantified constructors.",
-- 
1.7.10.4