[project @ 2001-08-14 16:28:00 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index cd26d59..d2d052b 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
@@ -819,19 +831,19 @@ freeErr pred
         nest 4 (ptext SLIT("At least one must be universally quantified here"))
     ]
 
-forAllTyErr     ty = ptext SLIT("Illegal polymorphic type:") <+> ppr ty
-usageTyErr      ty = ptext SLIT("Illegal usage type:") <+> ppr ty
-unliftedArgErr  ty = ptext SLIT("Illegal unlifted type argument:") <+> ppr ty
-ubxArgTyErr     ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr ty
+forAllTyErr     ty = ptext SLIT("Illegal polymorphic type:") <+> ppr_ty ty
+usageTyErr      ty = ptext SLIT("Illegal usage type:") <+> ppr_ty ty
+unliftedArgErr  ty = ptext SLIT("Illegal unlifted type argument:") <+> ppr_ty ty
+ubxArgTyErr     ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr_ty ty
 badSourceTyErr sty = ptext SLIT("Illegal constraint") <+> pprSourceType sty
 predTyVarErr pred  = ptext SLIT("Non-type variables in constraint:") <+> pprPred pred
 kindErr kind       = ptext SLIT("Expecting an ordinary type, but found a type of kind") <+> ppr kind
 dupPredWarn dups   = ptext SLIT("Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)
 
 checkTypeCtxt ctxt ty
-  = vcat [ptext SLIT("In the type:") <+> ppr_ty,
+  = vcat [ptext SLIT("In the type:") <+> ppr_ty ty,
          ptext SLIT("While checking") <+> pprUserTypeCtxt ctxt ]
-  where  
+
        -- Hack alert.  If there are no tyvars, (ppr sigma_ty) will print
        -- something strange like {Eq k} -> k -> k, because there is no
        -- ForAll at the top of the type.  Since this is going to the user
@@ -840,9 +852,10 @@ checkTypeCtxt ctxt ty
        -- This shows up in the complaint about
        --      case C a where
        --        op :: Eq a => a -> a
-    ppr_ty | null forall_tyvars = pprTheta theta <+> ptext SLIT("=>") <+> ppr tau
-          | otherwise          = ppr ty
-    (forall_tyvars, theta, tau) = tcSplitSigmaTy ty
+ppr_ty ty | null forall_tvs && not (null theta) = pprTheta theta <+> ptext SLIT("=>") <+> ppr tau
+          | otherwise                       = ppr ty
+          where
+           (forall_tvs, theta, tau) = tcSplitSigmaTy ty
 
 checkThetaCtxt ctxt theta
   = vcat [ptext SLIT("In the context:") <+> pprTheta theta,