[project @ 2003-05-14 09:13:52 by simonmar]

[ghc-hetmet.git] / ghc / compiler / stgSyn / StgLint.lhs

diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index 3692e06..28b02a9 100644 (file)
--- 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,12 +18,12 @@ 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 Util            ( zipEqual )
+import TyCon           ( TyCon, isAlgTyCon, isNewTyCon, tyConDataCons )
+import Util            ( zipEqual, equalLength )
 import Outputable
 
 infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
@@ -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,14 +254,15 @@ 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
                -- This almost certainly does not work for existential constructors
         in
         checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
-        checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
+        checkL (equalLength arg_tys args) (mkAlgAltMsg3 con args)
                                                                 `thenL_`
         mapL check (zipEqual "lintAlgAlt:stg" arg_tys args)     `thenL_`
         returnL ()
@@ -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)