X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=2d5a4fd3918243ca45ddfebf26690e9de620d3aa;hb=0b86bc9b022a5965d2b35f143ff4b919f784e676;hp=11b4e3dffc9eae2983b3212b6540c332c1177818;hpb=9b8b019d635218d9b52ddf0f5ea2b168e6f69cf4;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 11b4e3d..2d5a4fd 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -38,7 +38,7 @@ import Type		( Type, tyVarsOfType, coreEqType,
 			  extendTvSubst, composeTvSubst, substTyVarBndr, isInScope,
 			  getTvSubstEnv, getTvInScope, mkTyVarTy )
 import Coercion         ( Coercion, coercionKind, coercionKindTyConApp )
-import TyCon		( isPrimTyCon )
+import TyCon		( isPrimTyCon, isNewTyCon )
 import BasicTypes	( RecFlag(..), Boxity(..), isNonRec )
 import StaticFlags	( opt_PprStyle_Debug )
 import DynFlags		( DynFlags, DynFlag(..), dopt )
@@ -396,12 +396,13 @@ lintCoreArg fun_ty a@(Type arg_ty) =
 lintCoreArg fun_ty arg = 
        -- Make sure function type matches argument
   do { arg_ty <- lintCoreExpr arg
-     ; let err = mkAppMsg fun_ty arg_ty arg
+     ; let err1 =  mkAppMsg fun_ty arg_ty arg
+           err2 = mkNonFunAppMsg fun_ty arg_ty arg
      ; case splitFunTy_maybe fun_ty of
         Just (arg,res) -> 
-          do { checkTys arg arg_ty err 
+          do { checkTys arg arg_ty err1
              ; return res }
-        _ -> addErrL err }
+        _ -> addErrL err2 }
 \end{code}
 
 \begin{code}
@@ -497,6 +498,7 @@ lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) =
     lit_ty = literalType lit
 
 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
+  | isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
   | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
   = addLoc (CaseAlt alt) $  lintBinders args $ \ args -> 
     
@@ -801,6 +803,13 @@ mkBadAltMsg scrut_ty alt
 	   text "Scrutinee type:" <+> ppr scrut_ty,
 	   text "Alternative:" <+> pprCoreAlt alt ]
 
+mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message
+mkNewTyDataConAltMsg scrut_ty alt
+  = vcat [ text "Data alternative for newtype datacon",
+	   text "Scrutinee type:" <+> ppr scrut_ty,
+	   text "Alternative:" <+> pprCoreAlt alt ]
+
+
 ------------------------------------------------------
 --	Other error messages
 
@@ -811,6 +820,13 @@ mkAppMsg fun_ty arg_ty arg
 	      hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty),
 	      hang (ptext SLIT("Arg:")) 4 (ppr arg)]
 
+mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message
+mkNonFunAppMsg fun_ty arg_ty arg
+  = vcat [ptext SLIT("Non-function type in function position"),
+	      hang (ptext SLIT("Fun type:")) 4 (ppr fun_ty),
+	      hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty),
+	      hang (ptext SLIT("Arg:")) 4 (ppr arg)]
+
 mkKindErrMsg :: TyVar -> Type -> Message
 mkKindErrMsg tyvar arg_ty
   = vcat [ptext SLIT("Kinds don't match in type application:"),