[project @ 2002-09-17 12:34:31 by simonmar]

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

diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index e5744e1..a5785ac 100644 (file)
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -7,7 +7,7 @@
 module CoreLint (
        lintCoreBindings,
        lintUnfolding, 
-       showPass, endPass, endPassWithRules
+       showPass, endPass
     ) where
 
 #include "HsVersions.h"
@@ -15,7 +15,6 @@ module CoreLint (
 import IO              ( hPutStr, hPutStrLn, stdout )
 
 import CoreSyn
-import Rules            ( RuleBase, pprRuleBase )
 import CoreFVs         ( idFreeVars )
 import CoreUtils       ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
 
@@ -24,12 +23,11 @@ import Literal              ( literalType )
 import DataCon         ( dataConRepType )
 import Var             ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
 import VarSet
-import Subst           ( mkTyVarSubst, substTy )
+import Subst           ( substTyWith )
 import Name            ( getSrcLoc )
 import PprCore
 import ErrUtils                ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass,
-                         ErrMsg, addErrLocHdrLine, pprBagOfErrors,
-                          WarnMsg, pprBagOfWarnings)
+                         addErrLocHdrLine )
 import SrcLoc          ( SrcLoc, noSrcLoc )
 import Type            ( Type, tyVarsOfType, eqType,
                          splitFunTy_maybe, mkTyVarTy,
@@ -42,6 +40,7 @@ import TyCon          ( isPrimTyCon )
 import BasicTypes      ( RecFlag(..), isNonRec )
 import CmdLineOpts
 import Maybe
+import Util            ( notNull )
 import Outputable
 
 infixr 9 `thenL`, `seqL`
@@ -49,28 +48,18 @@ infixr 9 `thenL`, `seqL`
 
 %************************************************************************
 %*                                                                     *
-\subsection{Start and end pass}
+\subsection{End pass}
 %*                                                                     *
 %************************************************************************
 
-@beginPass@ and @endPass@ don't really belong here, but it makes a convenient
+@showPass@ and @endPass@ don't really belong here, but it makes a convenient
 place for them.  They print out stuff before and after core passes,
 and do Core Lint when necessary.
 
 \begin{code}
 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
 endPass dflags pass_name dump_flag binds
-  = do  
-        (binds, _) <- endPassWithRules dflags pass_name dump_flag binds Nothing
-        return binds
-
-endPassWithRules :: DynFlags -> String -> DynFlag -> [CoreBind] 
-                -> Maybe RuleBase
-                 -> IO ([CoreBind], Maybe RuleBase)
-endPassWithRules dflags pass_name dump_flag binds rules
   = do 
-        -- ToDo: force the rules?
-
        -- Report result size if required
        -- This has the side effect of forcing the intermediate to be evaluated
        if verbosity dflags >= 2 then
@@ -79,16 +68,12 @@ endPassWithRules dflags pass_name dump_flag binds rules
           return ()
 
        -- Report verbosely, if required
-       dumpIfSet_core dflags dump_flag pass_name
-                 (pprCoreBindings binds $$ case rules of
-                                              Nothing -> empty
-                                              Just rb -> pprRuleBase rb)
+       dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
 
        -- Type check
        lintCoreBindings dflags pass_name binds
-        -- ToDo: lint the rules
 
-       return (binds, rules)
+       return binds
 \end{code}
 
 
@@ -375,7 +360,7 @@ lintTyApp ty arg_ty
                --      error :: forall a:*. String -> a
                -- and then apply it to both boxed and unboxed types.
         then
-           returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body)
+           returnL (substTyWith [tyvar] [arg_ty] body)
        else
            addErrL (mkKindErrMsg tyvar arg_ty)
 
@@ -451,6 +436,7 @@ lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
        -- Scrutinee type must be a tycon applicn; checked by caller
        -- This code is remarkably compact considering what it does!
        -- NB: args must be in scope here so that the lintCoreArgs line works.
+       -- NB: relies on existential type args coming *after* ordinary type args
     case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) ->
        lintTyApps (dataConRepType con) tycon_arg_tys   `thenL` \ con_type ->
        lintCoreArgs con_type (map mk_arg args)         `thenL` \ con_result_ty ->
@@ -494,9 +480,9 @@ lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty))     `seqL`
 \begin{code}
 type LintM a = [LintLocInfo]   -- Locations
            -> IdSet            -- Local vars in scope
-           -> Bag ErrMsg       -- Error messages so far
-            -> Bag WarnMsg      -- Warning messages so far
-           -> (Maybe a, Bag ErrMsg, Bag WarnMsg)  -- Result and error/warning messages (if any)
+           -> Bag Message      -- Error messages so far
+            -> Bag Message      -- Warning messages so far
+           -> (Maybe a, Bag Message, Bag Message)  -- Result and error/warning messages (if any)
 
 data LintLocInfo
   = RhsOf Id           -- The variable bound
@@ -511,11 +497,12 @@ data LintLocInfo
 initL :: LintM a -> (Maybe Message {- errors -}, Maybe Message {- warnings -})
 initL m
   = case m [] emptyVarSet emptyBag emptyBag of
-      (_, errs, warns) -> (ifNonEmptyBag errs  pprBagOfErrors,
-                           ifNonEmptyBag warns pprBagOfWarnings)
+      (_, errs, warns) -> (ifNonEmptyBag errs,
+                           ifNonEmptyBag warns)
   where
-    ifNonEmptyBag bag f | isEmptyBag bag = Nothing
-                        | otherwise      = Just (f bag)
+    ifNonEmptyBag bag 
+       | isEmptyBag bag = Nothing
+        | otherwise      = Just (vcat (punctuate (text "") (bagToList bag)))
 
 returnL :: a -> LintM a
 returnL r loc scope errs warns = (Just r, errs, warns)
@@ -550,10 +537,10 @@ checkL False msg = addErrL msg
 addErrL :: Message -> LintM a
 addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns)
 
-addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
+addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
 -- errors or warnings, actually... they're the same type.
 addErr errs_so_far msg locs
-  = ASSERT( not (null locs) )
+  = ASSERT( notNull locs )
     errs_so_far `snocBag` mk_msg msg
   where
    (loc, cxt1) = dumpLoc (head locs)