[project @ 2003-12-30 16:29:17 by simonpj]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreLint.lhs

diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index 7470294..52b330c 100644 (file)
--- 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}