[project @ 1997-12-22 13:56:55 by simonm]

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

diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 86b2d4b..bd51090 100644 (file)
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -42,13 +42,18 @@ import Name         ( Name, Provenance, ExportFlag(..), isLocallyDefined,
                          nameModule, pprModule, pprOccName, nameOccName
                        )
 import TysWiredIn      ( unitTyCon, intTyCon, doubleTyCon )
-import PrelInfo                ( ioTyCon_NAME, primIoTyCon_NAME )
 import TyCon           ( TyCon )
 import PrelMods                ( mAIN, gHC_MAIN )
-import ErrUtils                ( SYN_IE(Error), SYN_IE(Warning) )
+import PrelInfo                ( ioTyCon_NAME )
+import ErrUtils                ( SYN_IE(Error), SYN_IE(Warning), pprBagOfErrors, 
+                         doIfSet, dumpIfSet, ghcExit
+                       )
 import FiniteMap       ( emptyFM, eltsFM, fmToList, addToFM, FiniteMap )
 import Pretty
-import Outputable      ( Outputable(..), PprStyle(..) )
+import Outputable      ( Outputable(..), PprStyle(..), 
+                         pprErrorsStyle, pprDumpStyle, printErrs
+                       )
+import Bag             ( isEmptyBag )
 import Util            ( cmpPString, equivClasses, panic, assertPanic, pprTrace )
 #if __GLASGOW_HASKELL__ >= 202
 import UniqSupply
@@ -60,24 +65,46 @@ import UniqSupply
 \begin{code}
 renameModule :: UniqSupply
             -> RdrNameHsModule
-            -> IO (Maybe                       -- Nothing <=> everything up to date;
-                                               -- no ned to recompile any further
-                         (RenamedHsModule,     -- Output, after renaming
+            -> IO (Maybe (RenamedHsModule,     -- Output, after renaming
                           InterfaceDetails,    -- Interface; for interface file generatino
                           RnNameSupply,        -- Final env; for renaming derivings
-                          [Module]),           -- Imported modules; for profiling
-                   Bag Error, 
-                   Bag Warning
-                  )
-\end{code} 
+                          [Module]))           -- Imported modules; for profiling
 
-
-\begin{code}
 renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_decls loc)
-  =    -- INITIALISE THE RENAMER MONAD
-    initRn mod_name us (mkSearchPath opt_HiMap) loc $
+  =    -- Initialise the renamer monad
+    initRn mod_name us (mkSearchPath opt_HiMap) loc
+          (rename this_mod)                            >>=
+       \ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) ->
+
+       -- Check for warnings
+    doIfSet (not (isEmptyBag rn_warns_bag))
+           (print_errs rn_warns_bag)                   >>
+
+       -- Check for errors; exit if so
+    doIfSet (not (isEmptyBag rn_errs_bag))
+           (print_errs rn_errs_bag      >>
+            ghcExit 1
+           )                                            >>
+
+       -- Dump output, if any
+    (case maybe_rn_stuff of
+       Nothing  -> return ()
+       Just results@(rn_mod, _, _, _)
+                -> dumpIfSet opt_D_dump_rn "Renamer:"
+                             (ppr pprDumpStyle rn_mod)
+    )                                                  >>
+
+       -- Return results
+    return maybe_rn_stuff
+
+
+print_errs errs = printErrs (pprBagOfErrors pprErrorsStyle errs)
+\end{code}
+
 
-       -- FIND THE GLOBAL NAME ENVIRONMENT
+\begin{code}
+rename this_mod@(HsModule mod_name vers exports imports fixities local_decls loc)
+  =    -- FIND THE GLOBAL NAME ENVIRONMENT
     getGlobalNames this_mod                    `thenRn` \ global_name_info ->
 
     case global_name_info of {
@@ -151,12 +178,12 @@ addImplicits mod_name
        -- are the types to which ambigious type variables may be defaulted by
        -- the type checker; so they won't every appear explicitly.
        -- [The () one is a GHC extension for defaulting CCall results.]
-    default_tys = [getName intTyCon, getName doubleTyCon, getName unitTyCon]
+    default_tys = [getName intTyCon, getName doubleTyCon, getName unitTyCon ]
 
        -- Add occurrences for IO or PrimIO
-    implicit_main | mod_name == mAIN     = [ioTyCon_NAME]
-                 | mod_name == gHC_MAIN = [primIoTyCon_NAME]
-                 | otherwise            = []
+    implicit_main |  mod_name == mAIN
+                 || mod_name == gHC_MAIN = [ioTyCon_NAME]
+                 |  otherwise            = []
 \end{code}
 
 
@@ -278,9 +305,8 @@ rnStats all_decls
         | opt_D_show_rn_trace || 
          opt_D_show_rn_stats ||
          opt_D_dump_rn 
-       = getRnStats all_decls                  `thenRn` \ msg ->
-         ioToRnMG (hPutStr stderr (show msg) >> 
-                   hPutStr stderr "\n")        `thenRn_`
+       = getRnStats all_decls          `thenRn` \ msg ->
+         ioToRnMG (printErrs msg)      `thenRn_`
          returnRn ()
 
        | otherwise = returnRn ()