X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLint.lhs;h=407882098075a12181eb4ecda46aea2d492f7252;hp=929d40d27e3668329298552d65bc6d66125b82f4;hb=2f51f1402e6869c0f049ffbe7b019bf6ab80558f;hpb=c49d51f812da9b1c2ceca7e0dad8f2a3626041a9

diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index 929d40d..4078820 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -16,7 +16,7 @@ import Ubiq
 import CoreSyn
 
 import Bag
-import Kind		( Kind{-instance-} )
+import Kind		( isSubKindOf, Kind{-instance-} )
 import Literal		( literalType, Literal{-instance-} )
 import Id		( idType, isBottomingId,
 			  dataConArgTys, GenId{-instances-}
@@ -32,12 +32,12 @@ import PrimOp		( primOpType, PrimOp(..) )
 import PrimRep		( PrimRep(..) )
 import SrcLoc		( SrcLoc )
 import Type		( mkFunTy,getFunTy_maybe,mkForAllTy,getForAllTy_maybe,
-			  isPrimType,getTypeKind,instantiateTy,
+			  isPrimType,typeKind,instantiateTy,
 			  mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
 			  maybeAppDataTyCon, eqTy
 			)
 import TyCon		( isPrimTyCon, tyConFamilySize )
-import TyVar		( getTyVarKind, GenTyVar{-instances-} )
+import TyVar		( tyVarKind, GenTyVar{-instances-} )
 import UniqSet		( emptyUniqSet, mkUniqSet, intersectUniqSets,
 			  unionUniqSets, elementOfUniqSet, UniqSet(..)
 			)
@@ -274,10 +274,14 @@ lintCoreArg checkTyApp e ty a@(TyArg arg_ty)
     checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a)
     `seqL`
     case (getForAllTy_maybe ty) of
-      Just (tyvar,body) | (getTyVarKind tyvar == getTypeKind arg_ty) ->
-	returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
-	| pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug (getTyVarKind tyvar), ppr PprDebug (getTypeKind arg_ty)]) False -> panic "impossible"
-      _ -> addErrL (mkTyAppMsg ty arg_ty e) `seqL` returnL Nothing
+      Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
+
+      Just (tyvar,body) ->
+	if (tyVarKind tyvar `isSubKindOf` typeKind arg_ty) then
+	    returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
+	else
+	    pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug (tyVarKind tyvar), ppr PprDebug (typeKind arg_ty)]) $
+	    addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing
 	
 lintCoreArg _ e ty (UsageArg u)
   = -- ToDo: Check that usage has no unbound usage variables
@@ -569,9 +573,9 @@ mkAppMsg fun arg expr sty
 	      ppHang (ppStr "Arg type:") 4 (ppr sty arg),
 	      ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
 
-mkTyAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
-mkTyAppMsg ty arg expr sty
-  = ppAboves [ppStr "Illegal type application:",
+mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg
+mkTyAppMsg msg ty arg expr sty
+  = ppAboves [ppCat [ppPStr msg, ppStr "type application:"],
 	      ppHang (ppStr "Exp type:")   4 (ppr sty ty),
 	      ppHang (ppStr "Arg type:")   4 (ppr sty arg),
 	      ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]