[project @ 2000-11-14 10:46:39 by simonpj]

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

diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index a1b9d77..c1c7495 100644 (file)
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -40,19 +40,20 @@ import HscTypes             ( AvailEnv, lookupType,
                          WhetherHasOrphans, ImportVersion, 
                          PersistentRenamerState(..), IsBootInterface, Avails,
                          DeclsMap, IfaceInsts, IfaceRules, 
-                         HomeSymbolTable, PackageTypeEnv,
+                         HomeSymbolTable, TyThing,
                          PersistentCompilerState(..), GlobalRdrEnv,
                          HomeIfaceTable, PackageIfaceTable,
                          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,8 +68,6 @@ import Bag            ( Bag, emptyBag, isEmptyBag, snocBag )
 import UniqSupply
 import Outputable
 import PrelNames       ( mkUnboundName )
-import Maybes          ( maybeToBool )
-import ErrUtils                ( printErrorsAndWarnings )
 
 infixr 9 `thenRn`, `thenRn_`
 \end{code}
@@ -97,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 (printErrs alwaysQualify msg)   `thenRn_`
               returnRn ()
 \end{code}
 
@@ -127,13 +131,15 @@ data RnDown
        rn_dflags  :: DynFlags,
 
        rn_hit     :: HomeIfaceTable,
-       rn_done    :: Name -> Bool,     -- Tells what things (both in the
-                                       -- home package and other packages)
-                                       -- were already available (i.e. in
-                                       -- the relevant SymbolTable) before 
-                                       -- compiling this module
+       rn_done    :: Name -> Maybe TyThing,    -- Tells what things (both in the
+                                               -- home package and other packages)
+                                               -- were already available (i.e. in
+                                               -- the relevant SymbolTable) before 
+                                               -- compiling this module
+                       -- 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),
@@ -258,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,
@@ -295,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 
@@ -330,7 +340,7 @@ initRn dflags hit hst pcs mod do_rn
        
                               rn_dflags = dflags,
                               rn_hit    = hit,
-                              rn_done   = is_done hst pte,
+                              rn_done   = lookupType hst pte,
                                             
                               rn_ns     = names_var, 
                               rn_errs   = errs_var, 
@@ -353,15 +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)
-
-is_done :: HomeSymbolTable -> PackageTypeEnv -> Name -> Bool
--- Returns True iff the name is in either symbol table
--- The name is a Global, so it has a Module
-is_done hst pte n = maybeToBool (lookupType hst pte n)
+       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
@@ -449,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
@@ -465,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 ->
@@ -589,9 +595,8 @@ getSrcLocRn down l_down
 getHomeIfaceTableRn :: RnM d HomeIfaceTable
 getHomeIfaceTableRn down l_down = return (rn_hit down)
 
-checkAlreadyAvailable :: Name -> RnM d Bool
-       -- Name is a Global name
-checkAlreadyAvailable name down l_down = return (rn_done down name)
+getTypeEnvRn :: RnM d (Name -> Maybe TyThing)
+getTypeEnvRn down l_down = return (rn_done down)
 \end{code}
 
 %================