X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=94c2d25b60074cb093bd89266d0a43c3e3caa64e;hb=e6ca2d4ac1e3d86bd93e5884fbae03151c708862;hp=525ba0d29ac3fc74bd6fde1c5323c6fe8b3da003;hpb=296058a1cafa80dec0b3f998348bce7c65f668b0;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 525ba0d..94c2d25 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -415,7 +415,7 @@ occurCheckErr ty containingTy
 newCoVars :: [(TcType,TcType)] -> TcM [CoVar]
 newCoVars spec
   = do	{ us <- newUniqueSupply 
-	; return [ mkCoVar (mkSysTvName uniq (fsLit "co"))
+	; return [ mkCoVar (mkSysTvName uniq (fsLit "co_kv"))
 			   (mkCoKind ty1 ty2)
 		 | ((ty1,ty2), uniq) <- spec `zip` uniqsFromSupply us] }
 
@@ -1059,11 +1059,13 @@ checkValidType ctxt ty = do
 
 		 ForSigCtxt _	-> gen_rank 1
 		 SpecInstCtxt   -> gen_rank 1
+		 ThBrackCtxt    -> gen_rank 1
 
 	actual_kind = typeKind ty
 
 	kind_ok = case ctxt of
 			TySynCtxt _  -> True -- Any kind will do
+			ThBrackCtxt  -> True -- Any kind will do
 			ResSigCtxt   -> isSubOpenTypeKind actual_kind
 			ExprSigCtxt  -> isSubOpenTypeKind actual_kind
 			GenPatCtxt   -> isLiftedTypeKind actual_kind
@@ -1073,6 +1075,7 @@ checkValidType ctxt ty = do
 	ubx_tup = case ctxt of
 	              TySynCtxt _ | unboxed -> UT_Ok
 	              ExprSigCtxt | unboxed -> UT_Ok
+	              ThBrackCtxt | unboxed -> UT_Ok
 	              _                     -> UT_NotOk
 
 	-- Check that the thing has kind Type, and is lifted if necessary
@@ -1223,13 +1226,14 @@ check_arg_type :: Rank -> Type -> TcM ()
 
 check_arg_type rank ty 
   = do	{ impred <- doptM Opt_ImpredicativeTypes
-	; let rank' = if impred then ArbitraryRank  -- Arg of tycon can have arby rank, regardless
-	              else case rank of 	    -- Predictive => must be monotype
-	      	        MustBeMonoType -> MustBeMonoType 
-			_	       -> TyConArgMonoType
+	; let rank' = case rank of 	    -- Predictive => must be monotype
+	      	        MustBeMonoType     -> MustBeMonoType  -- Monotype, regardless
+			_other | impred    -> ArbitraryRank
+			       | otherwise -> TyConArgMonoType
 			-- Make sure that MustBeMonoType is propagated, 
 			-- so that we don't suggest -XImpredicativeTypes in
 			--    (Ord (forall a.a)) => a -> a
+			-- and so that if it Must be a monotype, we check that it is!
 
 	; check_type rank' UT_NotOk ty
 	; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) }
@@ -1888,8 +1892,16 @@ sizeType (ForAllTy _ ty)   = sizeType ty
 sizeTypes :: [Type] -> Int
 sizeTypes xs               = sum (map sizeType xs)
 
+-- Size of a predicate
+--
+-- Equalities are a special case.  The equality itself doesn't contribute to the
+-- size and as we do not count class predicates, we have to start with one less.
+-- This is easy to see considering that, given
+--   class C a b | a -> b
+--   type family F a
+-- constraints (C a b) and (F a ~ b) are equivalent in size.
 sizePred :: PredType -> Int
 sizePred (ClassP _ tys')   = sizeTypes tys'
 sizePred (IParam _ ty)     = sizeType ty
-sizePred (EqPred ty1 ty2)  = sizeType ty1 + sizeType ty2
+sizePred (EqPred ty1 ty2)  = sizeType ty1 + sizeType ty2 - 1
 \end{code}