[project @ 2000-10-05 16:04:36 by simonpj]

Add a test to reject things like:

	instance Ord a => Ord (forall s. T s a)

	g :: T s (forall b.b)

The for-alls are illegal in type arguments!

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 89f6c5b..13aabab 100644 (file)
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -46,7 +46,7 @@ import Type           ( Type, Kind, PredType(..), ThetaType, UsageAnn(..),
                          mkArrowKinds, getTyVar_maybe, getTyVar, splitFunTy_maybe,
                          tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars,
                          tyVarsOfType, tyVarsOfPred, mkForAllTys,
-                         classesOfPreds, isUnboxedTupleType
+                         classesOfPreds, isUnboxedTupleType, isForAllTy
                        )
 import PprType         ( pprType, pprPred )
 import Subst           ( mkTopTyVarSubst, substTy )
@@ -332,11 +332,11 @@ tcHsType ty@(HsTyVar name)
   = tc_app ty []
 
 tcHsType (HsListTy ty)
-  = tcHsType ty                `thenTc` \ tau_ty ->
+  = tcHsArgType ty             `thenTc` \ tau_ty ->
     returnTc (mkListTy tau_ty)
 
 tcHsType (HsTupleTy (HsTupCon _ boxity) tys)
-  = mapTc tcHsType tys `thenTc` \ tau_tys ->
+  = mapTc tcHsArgType tys      `thenTc` \ tau_tys ->
     returnTc (mkTupleTy boxity (length tys) tau_tys)
 
 tcHsType (HsFunTy ty1 ty2)
@@ -348,10 +348,10 @@ tcHsType (HsNumTy n)
   = ASSERT(n== 1)
     returnTc (mkTyConApp genUnitTyCon [])
 
-tcHsType (HsOpTy ty1 op ty2) =
-  tcHsType ty1 `thenTc` \ tau_ty1 ->
-  tcHsType ty2 `thenTc` \ tau_ty2 ->
-  tc_fun_type op [tau_ty1,tau_ty2]
+tcHsType (HsOpTy ty1 op ty2)
+  = tcHsArgType ty1 `thenTc` \ tau_ty1 ->
+    tcHsArgType ty2 `thenTc` \ tau_ty2 ->
+    tc_fun_type op [tau_ty1,tau_ty2]
 
 tcHsType (HsAppTy ty1 ty2)
   = tc_app ty1 [ty2]
@@ -457,7 +457,7 @@ tc_app (HsAppTy ty1 ty2) tys
 
 tc_app ty tys
   = tcAddErrCtxt (appKindCtxt pp_app)  $
-    mapTc tcHsType tys                 `thenTc` \ arg_tys ->
+    mapTc tcHsArgType tys              `thenTc` \ arg_tys ->
     case ty of
        HsTyVar fun -> tc_fun_type fun arg_tys
        other       -> tcHsType ty              `thenTc` \ fun_ty ->
@@ -465,6 +465,13 @@ tc_app ty tys
   where
     pp_app = ppr ty <+> sep (map pprParendHsType tys)
 
+tcHsArgType arg_ty     -- Check that the argument of a type appplication
+                       -- isn't a for-all type
+  = tcHsType arg_ty                            `thenTc` \ arg_ty' ->
+    checkTc (not (isForAllTy arg_ty'))
+           (argTyErr arg_ty)                   `thenTc_`
+    returnTc arg_ty'
+
 -- (tc_fun_type ty arg_tys) returns (mkAppTys ty arg_tys)
 -- But not quite; for synonyms it checks the correct arity, and builds a SynTy
 --     hence the rather strange functionality.
@@ -508,7 +515,7 @@ tcContext context = mapTc (tcClassAssertion False) context
 
 tcClassAssertion ccall_ok assn@(HsPClass class_name tys)
   = tcAddErrCtxt (appKindCtxt (ppr assn))      $
-    mapTc tcHsType tys                         `thenTc` \ arg_tys ->
+    mapTc tcHsArgType tys                      `thenTc` \ arg_tys ->
     tcLookupTy class_name                      `thenTc` \ thing ->
     case thing of
        AClass clas -> checkTc (arity == n_tys) err                             `thenTc_`
@@ -921,4 +928,6 @@ freeErr pred ty
 
 unboxedTupleErr ty
   = sep [ptext (SLIT("Illegal unboxed tuple as a function or contructor argument:")), nest 4 (ppr ty)]
+
+argTyErr ty = ptext SLIT("Illegal polymorphic type as argument:") <+> ppr ty
 \end{code}

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index ef37be2..5043f88 100644 (file)
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -43,7 +43,7 @@ module Type (
         mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy, 
 
        mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, 
-       applyTy, applyTys, hoistForAllTys,
+       applyTy, applyTys, hoistForAllTys, isForAllTy,
 
        TauType, RhoType, SigmaType, PredType(..), ThetaType,
        ClassPred, ClassContext, mkClassPred,
@@ -565,6 +565,11 @@ mkForAllTys tyvars ty = case splitUsgTy_maybe ty of
                                                   (foldr ForAllTy ty' tyvars)
                           Nothing        -> foldr ForAllTy ty tyvars
 
+isForAllTy :: Type -> Bool
+isForAllTy (NoteTy _ ty)  = isForAllTy ty
+isForAllTy (ForAllTy _ _) = True
+isForAllTy other_ty      = False
+
 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
 splitForAllTy_maybe ty = case splitUsgTy_maybe ty of
                            Just (usg,ty') -> do (tyvar,ty'') <- splitFAT_m ty'