[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.)
-

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index b846c0a..26e5fc5 100644 (file)
--- 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.",