X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLint.lhs;h=e2c826997eb80f1282348993cb649d050f617743;hb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1;hp=dc2b61ae2001fd5212b89a924daa260bc98ecbd3;hpb=b4255f2c320f852d7dfb0afc0bc9f64765aece0c;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index dc2b61a..e2c8269 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -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(..)
 			)
@@ -184,6 +184,9 @@ lintCoreExpr :: CoreExpr -> LintM (Maybe Type)	-- Nothing if error found
 lintCoreExpr (Var var) = checkInScope var `seqL` returnL (Just (idType var))
 lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
 lintCoreExpr (SCC _ expr) = lintCoreExpr expr
+lintCoreExpr (Coerce _ ty expr)
+  = _trace "lintCoreExpr:Coerce" $
+    lintCoreExpr expr `seqL` returnL (Just ty)
 
 lintCoreExpr (Let binds body)
   = lintCoreBinding binds `thenL` \binders ->
@@ -218,14 +221,11 @@ lintCoreExpr (Lam (ValBinder var) expr)
 lintCoreExpr (Lam (TyBinder tyvar) expr)
   = lintCoreExpr expr `thenMaybeL` \ty ->
     returnL (Just(mkForAllTy tyvar ty))
-    -- TODO: Should add in-scope type variable at this point
+    -- ToDo: Should add in-scope type variable at this point
 
 lintCoreExpr e@(Case scrut alts)
  = lintCoreExpr scrut `thenMaybeL` \ty ->
-   -- Check that it is a data type
-   case maybeAppDataTyCon ty of
-     Nothing -> addErrL (mkCaseDataConMsg e) `seqL` returnL Nothing
-     Just(tycon, _, _) -> lintCoreAlts alts ty tycon
+   lintCoreAlts alts ty
 \end{code}
 
 %************************************************************************
@@ -270,19 +270,31 @@ lintCoreArg _ e ty (VarArg v)
       _ -> addErrL (mkAppMsg ty (idType v) e) `seqL` returnL Nothing
 
 lintCoreArg checkTyApp e ty a@(TyArg arg_ty)
-  = -- TODO: Check that ty is well-kinded and has no unbound tyvars
+  = -- ToDo: Check that ty is well-kinded and has no unbound tyvars
     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))
-      _ -> addErrL (mkTyAppMsg ty arg_ty e) `seqL` returnL Nothing
+      Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
+
+      Just (tyvar,body) ->
+	let
+	    tyvar_kind = tyVarKind tyvar
+	    argty_kind = typeKind arg_ty
+	in
+	if tyvar_kind == argty_kind
+-- SUSPICIOUS!	(tyvar_kind `isSubKindOf` argty_kind
+--		 || argty_kind `isSubKindOf` tyvar_kind)
+	 then
+	    returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
+	else
+	    pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $
+	    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
+  = -- ToDo: Check that usage has no unbound usage variables
     case (getForAllUsageTy ty) of
       Just (uvar,bounds,body) ->
-        -- TODO Check argument satisfies bounds
+        -- ToDo: Check argument satisfies bounds
         returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
       _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
 \end{code}
@@ -296,20 +308,20 @@ lintCoreArg _ e ty (UsageArg u)
 \begin{code}
 lintCoreAlts :: CoreCaseAlts
 	     -> Type  			-- Type of scrutinee
-	     -> TyCon			-- TyCon pinned on the case
+--	     -> TyCon			-- TyCon pinned on the case
 	     -> LintM (Maybe Type)	-- Type of alternatives
 
-lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon
+lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
   = -- Check tycon is not a primitive tycon
-    addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
-    `seqL`
+--    addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
+--    `seqL`
     -- Check we are scrutinising a proper datatype
     -- (ToDo: robustify)
-    addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
-    `seqL`
+--    addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
+--    `seqL`
     lintDeflt deflt ty
     `thenL` \maybe_deflt_ty ->
-    mapL (lintAlgAlt ty tycon) alts
+    mapL (lintAlgAlt ty {-tycon-}) alts
     `thenL` \maybe_alt_tys ->
     -- Check the result types
     case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
@@ -320,10 +332,10 @@ lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon
 	where
 	  check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
 
-lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon
+lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
   = -- Check tycon is a primitive tycon
-    addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
-    `seqL`
+--    addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
+--    `seqL`
     mapL (lintPrimAlt ty) alts
     `thenL` \maybe_alt_tys ->
     lintDeflt deflt ty
@@ -337,7 +349,7 @@ lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon
 	where
 	  check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
 
-lintAlgAlt scrut_ty tycon{-ToDo: use it!-} (con,args,rhs)
+lintAlgAlt scrut_ty {-tycon-ToDo: use it!-} (con,args,rhs)
   = (case maybeAppDataTyCon scrut_ty of
       Nothing ->
 	 addErrL (mkAlgAltMsg1 scrut_ty)
@@ -568,9 +580,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)]