[project @ 2001-08-14 15:37:55 by simonpj]

Wibbles to the checking-types commit

diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index cd26d59..df60bee 100644 (file)
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -546,15 +546,17 @@ data UserTypeCtxt
   | ResSigCtxt         -- Result type sig
                        --      f x :: t = ....
   | ForSigCtxt Name    -- Foreign inport or export signature
-
-pprUserTypeCtxt (FunSigCtxt n) = ptext SLIT("the type signature for") <+> quotes (ppr n)
-pprUserTypeCtxt ExprSigCtxt    = ptext SLIT("an expression type signature")
-pprUserTypeCtxt (ConArgCtxt c) = ptext SLIT("the type of constructor") <+> quotes (ppr c)
-pprUserTypeCtxt (TySynCtxt c)  = ptext SLIT("the RHS of a type synonym declaration") <+> quotes (ppr c)
-pprUserTypeCtxt GenPatCtxt     = ptext SLIT("the type pattern of a generic definition")
-pprUserTypeCtxt PatSigCtxt     = ptext SLIT("a pattern type signature")
-pprUserTypeCtxt ResSigCtxt     = ptext SLIT("a result type signature")
-pprUserTypeCtxt (ForSigCtxt n) = ptext SLIT("the foreign signature for") <+> quotes (ppr n)
+  | RuleSigCtxt Name   -- Signature on a forall'd variable in a RULE
+
+pprUserTypeCtxt (FunSigCtxt n)         = ptext SLIT("the type signature for") <+> quotes (ppr n)
+pprUserTypeCtxt ExprSigCtxt            = ptext SLIT("an expression type signature")
+pprUserTypeCtxt (ConArgCtxt c)         = ptext SLIT("the type of constructor") <+> quotes (ppr c)
+pprUserTypeCtxt (TySynCtxt c)          = ptext SLIT("the RHS of a type synonym declaration") <+> quotes (ppr c)
+pprUserTypeCtxt GenPatCtxt             = ptext SLIT("the type pattern of a generic definition")
+pprUserTypeCtxt PatSigCtxt             = ptext SLIT("a pattern type signature")
+pprUserTypeCtxt ResSigCtxt             = ptext SLIT("a result type signature")
+pprUserTypeCtxt (ForSigCtxt n)         = ptext SLIT("the foreign signature for") <+> quotes (ppr n)
+pprUserTypeCtxt (RuleSigCtxt n) = ptext SLIT("the type signature on") <+> quotes (ppr n)
 \end{code}
 
 \begin{code}
@@ -575,6 +577,7 @@ checkValidType ctxt ty
                 TySynCtxt _  | gla_exts  -> 1
                              | otherwise -> 0
                 ForSigCtxt _             -> 1
+                RuleSigCtxt _            -> 1
 
        actual_kind = typeKind ty
 
@@ -666,9 +669,18 @@ check_tau_type rank ubx_tup_ok (NoteTy note ty)
   = check_note note `thenTc_` check_tau_type rank ubx_tup_ok ty
 
 check_tau_type rank ubx_tup_ok ty@(TyConApp tc tys)
-  = mapTc_ check_arg_type tys                                          `thenTc_`
-    checkTc (not (isSynTyCon tc)         || syn_arity_ok) arity_msg    `thenTc_`
-    checkTc (not (isUnboxedTupleTyCon tc) || ubx_tup_ok)   ubx_tup_msg
+  | isSynTyCon tc
+  = checkTc syn_arity_ok arity_msg     `thenTc_`
+    mapTc_ check_arg_type tys
+    
+  | isUnboxedTupleTyCon tc
+  = checkTc ubx_tup_ok ubx_tup_msg     `thenTc_`
+    mapTc_ (check_tau_type 0 True) tys         -- Args are allowed to be unlifted, or
+                                               -- more unboxed tuples, so can't use check_arg_ty
+
+  | otherwise
+  = mapTc_ check_arg_type tys
+
   where
     syn_arity_ok = tc_arity <= n_args
                -- It's OK to have an *over-applied* type synonym

diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs
index 1566e44..d041fc9 100644 (file)
--- a/ghc/compiler/typecheck/TcRules.lhs
+++ b/ghc/compiler/typecheck/TcRules.lhs
@@ -133,9 +133,9 @@ tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc)
   where
     sig_tys = [t | RuleBndrSig _ t <- vars]
 
-    new_id (RuleBndr var)         = newTyVarTy openTypeKind            `thenNF_Tc` \ ty ->
+    new_id (RuleBndr var)         = newTyVarTy openTypeKind                    `thenNF_Tc` \ ty ->
                                     returnNF_Tc (mkLocalId var ty)
-    new_id (RuleBndrSig var rn_ty) = tcHsSigType PatSigCtxt rn_ty      `thenTc` \ ty ->
+    new_id (RuleBndrSig var rn_ty) = tcHsSigType (RuleSigCtxt var) rn_ty       `thenTc` \ ty ->
                                     returnNF_Tc (mkLocalId var ty)
 
 ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>