[project @ 2000-11-13 10:25:00 by simonmar]

[ghc-hetmet.git] / ghc / compiler / rename / RnMonad.lhs

diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 0d562d3..6b2fa19 100644 (file)
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -46,13 +46,14 @@ import HscTypes             ( AvailEnv, lookupType,
                          RdrAvailInfo )
 import BasicTypes      ( Version, defaultFixity )
 import ErrUtils                ( addShortErrLocLine, addShortWarnLocLine,
-                         pprBagOfErrors, ErrMsg, WarnMsg, Message
+                         pprBagOfErrors, Message, Messages, errorsFound,
+                         printErrorsAndWarnings
                        )
 import RdrName         ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc,
                          RdrNameEnv, emptyRdrEnv, extendRdrEnv, 
                          addListToRdrEnv, rdrEnvToList, rdrEnvElts
                        )
-import Name            ( Name, OccName, NamedThing(..), getSrcLoc,
+import Name            ( Name, OccName, NamedThing(..), 
                          nameOccName,
                          decode, mkLocalName, mkKnownKeyGlobal
                        )
@@ -67,7 +68,6 @@ import Bag            ( Bag, emptyBag, isEmptyBag, snocBag )
 import UniqSupply
 import Outputable
 import PrelNames       ( mkUnboundName )
-import ErrUtils                ( printErrorsAndWarnings )
 
 infixr 9 `thenRn`, `thenRn_`
 \end{code}
@@ -96,8 +96,13 @@ traceRn msg
    = doptRn Opt_D_dump_rn_trace `thenRn` \b ->
      if b then putDocRn msg else returnRn ()
 
+traceHiDiffsRn :: SDoc -> RnM d ()
+traceHiDiffsRn msg
+   = doptRn Opt_D_dump_hi_diffs `thenRn` \b ->
+     if b then putDocRn msg else returnRn ()
+
 putDocRn :: SDoc -> RnM d ()
-putDocRn msg = ioToRnM (printErrs msg) `thenRn_`
+putDocRn msg = ioToRnM (printDump msg) `thenRn_`
               returnRn ()
 \end{code}
 
@@ -134,7 +139,7 @@ data RnDown
                        -- The Name passed to rn_done is guaranteed to be a Global,
                        -- so it has a Module, so it can be looked up
 
-       rn_errs    :: IORef (Bag WarnMsg, Bag ErrMsg),
+       rn_errs    :: IORef Messages,
 
        -- The second and third components are a flattened-out OrigNameEnv
        rn_ns      :: IORef (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv),
@@ -259,10 +264,9 @@ data Ifaces = Ifaces {
     -- EPHEMERAL FIELDS
     -- These fields persist during the compilation of a single module only
        iImpModInfo :: ImportedModuleInfo,
-                       -- Modules this one depends on: that is, the union 
-                       -- of the modules its *direct* imports depend on.
-                       -- NB: The direct imports have .hi files that enumerate *all* the
-                       -- dependencies (direct or not) of the imported module.
+                       -- Modules that we know something about, because they are mentioned
+                       -- in interface files, BUT which we have not loaded yet.  
+                       -- No module is both in here and in the PIT
 
        iSlurp :: NameSet,
                -- All the names (whether "big" or "small", whether wired-in or not,
@@ -296,13 +300,18 @@ type ImportedModuleInfo = FiniteMap ModuleName (WhetherHasOrphans, IsBootInterfa
 %************************************************************************
 
 \begin{code}
+runRn dflags hit hst pcs mod do_rn
+  = do { (pcs, msgs, r) <- initRn dflags hit hst pcs mod do_rn ;
+        printErrorsAndWarnings alwaysQualify msgs ;
+        return (pcs, errorsFound msgs, r)
+    }
+
 initRn :: DynFlags
        -> HomeIfaceTable -> HomeSymbolTable
        -> PersistentCompilerState
        -> Module
        -> RnMG t
-       -> IO (PersistentCompilerState, Bool, t)        
-               -- True <=> found errors
+       -> IO (PersistentCompilerState, Messages, t)    
 
 initRn dflags hit hst pcs mod do_rn
   = do 
@@ -354,10 +363,7 @@ initRn dflags hit hst pcs mod do_rn
        let new_pcs = pcs { pcs_PIT = iPIT new_ifaces, 
                            pcs_PRS = new_prs }
        
-       -- Check for warnings
-       printErrorsAndWarnings (warns, errs) ;
-
-       return (new_pcs, not (isEmptyBag errs), res)
+       return (new_pcs, (warns, errs), res)
 
 initRnMS rn_env fixity_env mode thing_inside rn_down g_down
        -- The fixity_env appears in both the rn_fixenv field
@@ -445,7 +451,8 @@ mapRn    :: (a -> RnM d b) -> [a] -> RnM d [b]
 mapRn_   :: (a -> RnM d b) -> [a] -> RnM d ()
 mapMaybeRn :: (a -> RnM d (Maybe b)) -> [a] -> RnM d [b]
 flatMapRn  :: (a -> RnM d [b])       -> [a] -> RnM d [b]
-sequenceRn :: [RnM d a] -> RnM d [a]
+sequenceRn  :: [RnM d a] -> RnM d [a]
+sequenceRn_ :: [RnM d a] -> RnM d ()
 foldlRn :: (b  -> a -> RnM d b) -> b -> [a] -> RnM d b
 mapAndUnzipRn :: (a -> RnM d (b,c)) -> [a] -> RnM d ([b],[c])
 fixRn    :: (a -> RnM d a) -> RnM d a
@@ -461,9 +468,12 @@ andRn combiner m1 m2 gdown ldown
 
 sequenceRn []     = returnRn []
 sequenceRn (m:ms) =  m                 `thenRn` \ r ->
-                    sequenceRn ms      `thenRn` \ rs ->
+                    sequenceRn ms      `thenRn` \ rs ->
                     returnRn (r:rs)
 
+sequenceRn_ []     = returnRn ()
+sequenceRn_ (m:ms) = m `thenRn_` sequenceRn_ ms
+
 mapRn f []     = returnRn []
 mapRn f (x:xs)
   = f x                `thenRn` \ r ->