X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FStgLint.lhs;h=28b02a9a4c9efe858e941edd6b9bc62d3058cc2e;hb=1cfc9faaa059b9b090971399e4eb8ae9d364335c;hp=b36c5b035dfcd487b73f1c7c84774fe5a956dea3;hpb=9e93335020e64a811dbbb223e1727c76933a93ae;p=ghc-hetmet.git

diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index b36c5b0..28b02a9 100644
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -10,7 +10,7 @@ module StgLint ( lintStgBindings ) where
 
 import StgSyn
 
-import Bag		( Bag, emptyBag, isEmptyBag, snocBag )
+import Bag		( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
 import Id		( Id, idType, isLocalId )
 import VarSet
 import DataCon		( DataCon, dataConArgTys, dataConRepType )
@@ -18,11 +18,11 @@ import PrimOp		( primOpType )
 import Literal		( literalType, Literal )
 import Maybes		( catMaybes )
 import Name		( getSrcLoc )
-import ErrUtils		( ErrMsg, Message, addErrLocHdrLine, pprBagOfErrors, dontAddErrLoc )
+import ErrUtils		( Message, addErrLocHdrLine )
 import Type		( mkFunTys, splitFunTys, splitTyConApp_maybe,
-			  isUnLiftedType, isTyVarTy, splitForAllTys, Type
+			  isUnLiftedType, isTyVarTy, dropForAlls, Type
 			)
-import TyCon		( TyCon, isDataTyCon, tyConDataCons )
+import TyCon		( TyCon, isAlgTyCon, isNewTyCon, tyConDataCons )
 import Util		( zipEqual, equalLength )
 import Outputable
 
@@ -89,11 +89,11 @@ lintStgVar v  = checkInScope v	`thenL_`
 
 \begin{code}
 lintStgBinds :: StgBinding -> LintM [Id]		-- Returns the binders
-lintStgBinds (StgNonRec _srt binder rhs)
+lintStgBinds (StgNonRec binder rhs)
   = lint_binds_help (binder,rhs) 	`thenL_`
     returnL [binder]
 
-lintStgBinds (StgRec _srt pairs)
+lintStgBinds (StgRec pairs)
   = addInScopeVars binders (
 	mapL lint_binds_help pairs `thenL_`
 	returnL binders
@@ -127,10 +127,10 @@ lint_binds_help (binder, rhs)
 \begin{code}
 lintStgRhs :: StgRhs -> LintM (Maybe Type)
 
-lintStgRhs (StgRhsClosure _ _ _ _ [] expr)
+lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr)
   = lintStgExpr expr
 
-lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
+lintStgRhs (StgRhsClosure _ _ _ _ _ binders expr)
   = addLoc (LambdaBodyOf binders) (
     addInScopeVars binders (
 	lintStgExpr expr   `thenMaybeL` \ body_ty ->
@@ -254,7 +254,8 @@ lintStgAlts alts scrut_ty
 
 lintAlgAlt scrut_ty (con, args, _, rhs)
   = (case splitTyConApp_maybe scrut_ty of
-      Just (tycon, tys_applied) | isDataTyCon tycon ->
+      Just (tycon, tys_applied) | isAlgTyCon tycon && 
+				  not (isNewTyCon tycon) ->
 	 let
 	   cons    = tyConDataCons tycon
 	   arg_tys = dataConArgTys con tys_applied
@@ -298,8 +299,8 @@ lintDeflt deflt@(StgBindDefault rhs) scrut_ty = lintStgExpr rhs
 \begin{code}
 type LintM a = [LintLocInfo] 	-- Locations
 	    -> IdSet		-- Local vars in scope
-	    -> Bag ErrMsg	-- Error messages so far
-	    -> (a, Bag ErrMsg)	-- Result and error messages (if any)
+	    -> Bag Message	-- Error messages so far
+	    -> (a, Bag Message)	-- Result and error messages (if any)
 
 data LintLocInfo
   = RhsOf Id		-- The variable bound
@@ -330,7 +331,7 @@ initL m
     if isEmptyBag errs then
 	Nothing
     else
-	Just (pprBagOfErrors errs)
+	Just (vcat (punctuate (text "") (bagToList errs)))
     }
 
 returnL :: a -> LintM a
@@ -382,13 +383,14 @@ checkL False msg loc scope errs = ((), addErr errs msg loc)
 addErrL :: Message -> LintM ()
 addErrL msg loc scope errs = ((), addErr errs msg loc)
 
-addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
+addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
 
 addErr errs_so_far msg locs
   = errs_so_far `snocBag` mk_msg locs
   where
-    mk_msg (loc:_) = let (l,hdr) = dumpLoc loc in addErrLocHdrLine l hdr msg
-    mk_msg []      = dontAddErrLoc msg
+    mk_msg (loc:_) = let (l,hdr) = dumpLoc loc 
+		     in addErrLocHdrLine l hdr msg
+    mk_msg []      = msg
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
 addLoc extra_loc m loc scope errs
@@ -426,8 +428,7 @@ checkFunApp :: Type 		    -- The function type
 checkFunApp fun_ty arg_tys msg loc scope errs
   = cfa res_ty expected_arg_tys arg_tys
   where
-    (_, de_forall_ty) 	       = splitForAllTys fun_ty
-    (expected_arg_tys, res_ty) = splitFunTys de_forall_ty
+    (expected_arg_tys, res_ty) = splitFunTys (dropForAlls fun_ty)
 
     cfa res_ty expected []	-- Args have run out; that's fine
       = (Just (mkFunTys expected res_ty), errs)