X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsType.lhs;h=31cf70e140d06521bd6cc85e20e1167ac6009688;hp=d90638136c2886f7190137a034f571b4bbf22b33;hb=ef10d0a708995896b085b1c13ca7c9a92adca674;hpb=1dc5c28c2370cc8254f024c5734f76d7e5827cd6

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index d906381..31cf70e 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -191,8 +191,7 @@ kcHsSigType ty 	     = kcTypeType ty
 kcHsLiftedSigType ty = kcLiftedType ty
 
 tcHsKindedType :: LHsType Name -> TcM Type
-  -- Don't do kind checking, nor validity checking, 
-  -- 	but do hoist for-alls to the top
+  -- Don't do kind checking, nor validity checking.
   -- This is used in type and class decls, where kinding is
   -- done in advance, and validity checking is done later
   -- [Validity checking done later because of knot-tying issues.]
@@ -242,15 +241,23 @@ kcCheckHsType (L span ty) exp_kind
 		-- because checkExpectedKind already mentions
 		-- 'ty' by name in any error message
 
-	; checkExpectedKind ty act_kind exp_kind
+	; checkExpectedKind (strip ty) act_kind exp_kind
 	; return (L span ty') }
   where
-	-- Wrap a context around only if we want to
-	-- show that contexts.  Omit invisble ones
-	-- and ones user's won't grok (HsPred p).
-    add_ctxt (HsPredTy p)		    	   thing = thing
-    add_ctxt (HsForAllTy Implicit tvs (L _ []) ty) thing = thing
+	-- Wrap a context around only if we want to show that contexts.  
+	-- Omit invisble ones and ones user's won't grok (HsPred p).
+    add_ctxt (HsPredTy p)		    	         thing = thing
+    add_ctxt (HsForAllTy Implicit tvs (L _ []) (L _ ty)) thing = add_ctxt ty thing
     add_ctxt other_ty thing = addErrCtxt (typeCtxt ty) thing
+
+	-- We infer the kind of the type, and then complain if it's
+	-- not right.  But we don't want to complain about
+	--	(ty) or !(ty) or forall a. ty
+	-- when the real difficulty is with the 'ty' part.
+    strip (HsParTy (L _ ty))          = strip ty
+    strip (HsBangTy _ (L _ ty))       = strip ty
+    strip (HsForAllTy _ _ _ (L _ ty)) = strip ty
+    strip ty			      = ty
 \end{code}
 
 	Here comes the main function
@@ -561,8 +568,8 @@ tcLHsConResTy res_ty
     get_largs (L _ ty) args = get_args ty args
     get_args (HsAppTy fun arg) 		  args = get_largs fun (arg:args)
     get_args (HsParTy ty)      		  args = get_largs ty  args
-    get_args (HsOpTy ty1 (L span tc) ty2) args = get_args (HsTyVar tc) (ty1:ty2:args)
-    get_args ty  	     		  args = (ty, reverse args)
+    get_args (HsOpTy ty1 (L span tc) ty2) args = (HsTyVar tc, ty1:ty2:args)
+    get_args ty  	     		  args = (ty, args)
 
 gadtResCtxt ty
   = hang (ptext SLIT("In the result type of a data constructor:"))