X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLint.lhs;h=52b330c730b08d0c12d7303850db19e8081b555b;hb=f714e6b642fd614a9971717045ae47c3d871275e;hp=7470294d1c204144efeaee9547cca22f79b32a18;hpb=3fe27db88139e65f2a153c91b323cb43fd52185e;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index 7470294..52b330c 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -25,21 +25,25 @@ import Subst		( substTyWith )
 import Name		( getSrcLoc )
 import PprCore
 import ErrUtils		( dumpIfSet_core, ghcExit, Message, showPass,
-			  addErrLocHdrLine )
-import SrcLoc		( SrcLoc, noSrcLoc )
+			  mkLocMessage )
+import SrcLoc		( SrcLoc, noSrcLoc, mkSrcSpan )
 import Type		( Type, tyVarsOfType, eqType,
 			  splitFunTy_maybe, mkTyVarTy,
 			  splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
 			  isUnLiftedType, typeKind, 
 			  isUnboxedTupleType,
-			  hasMoreBoxityInfo
+			  isSubKind
 			)
 import TyCon		( isPrimTyCon )
 import BasicTypes	( RecFlag(..), isNonRec )
 import CmdLineOpts
-import Maybe
 import Outputable
 
+#ifdef DEBUG
+import Util             ( notNull )
+#endif
+
+import Maybe
 import IO		( hPutStrLn, stderr )
 
 infixr 9 `thenL`, `seqL`
@@ -329,7 +333,7 @@ lintTyApp ty arg_ty
 	    tyvar_kind = tyVarKind tyvar
 	    argty_kind = typeKind arg_ty
 	in
-	if argty_kind `hasMoreBoxityInfo` tyvar_kind
+	if argty_kind `isSubKind` tyvar_kind
 		-- Arg type might be boxed for a function with an uncommitted
 		-- tyvar; notably this is used so that we can give
 		-- 	error :: forall a:*. String -> a
@@ -402,8 +406,8 @@ lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
 lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
   = addLoc (CaseAlt alt) (
 
-    mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
-			(mkUnboxedTupleMsg arg)) args `seqL`
+    mapL (\arg -> checkL (not (isId arg && isUnboxedTupleType (idType arg)))
+			 (mkUnboxedTupleMsg arg)) args `seqL`
 
     addInScopeVars args (
 
@@ -517,7 +521,7 @@ addErr errs_so_far msg locs
    context     | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
 	       | otherwise	    = cxt1
  
-   mk_msg msg = addErrLocHdrLine loc context msg
+   mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
 addLoc extra_loc m loc scope errs
@@ -525,7 +529,7 @@ addLoc extra_loc m loc scope errs
 
 addInScopeVars :: [Var] -> LintM a -> LintM a
 addInScopeVars ids m loc scope errs
-  = m loc (scope `unionVarSet` mkVarSet ids) errs
+  = m loc (extendVarSetList scope ids) errs
 \end{code}
 
 \begin{code}