[project @ 2001-12-20 11:19:05 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 71db387..809e3f6 100644 (file)
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -36,7 +36,7 @@ import IO             ( hPutStr, stderr )
 import HsSyn           
 import RdrHsSyn
 import RnHsSyn         ( RenamedFixitySig )
-import HscTypes                ( AvailEnv, lookupType,
+import HscTypes                ( AvailEnv, emptyAvailEnv, lookupType,
                          NameSupply(..), 
                          ImportedModuleInfo, WhetherHasOrphans, ImportVersion, 
                          PersistentRenamerState(..), Avails,
@@ -65,6 +65,7 @@ import CmdLineOpts    ( DynFlags, DynFlag(..), dopt )
 import SrcLoc          ( SrcLoc, generatedSrcLoc, noSrcLoc )
 import Unique          ( Unique )
 import FiniteMap       ( FiniteMap )
+import Maybes          ( seqMaybe )
 import Bag             ( Bag, emptyBag, isEmptyBag, snocBag )
 import UniqSupply
 import Outputable
@@ -93,14 +94,10 @@ ioToRnM_no_fail io rn_down g_down
      (\ err -> panic "ioToRnM_no_fail: the I/O operation failed!")
            
 traceRn :: SDoc -> RnM d ()
-traceRn msg
-   = doptRn Opt_D_dump_rn_trace `thenRn` \b ->
-     if b then putDocRn msg else returnRn ()
+traceRn msg = ifOptRn Opt_D_dump_rn_trace (putDocRn msg)
 
 traceHiDiffsRn :: SDoc -> RnM d ()
-traceHiDiffsRn msg
-   = doptRn Opt_D_dump_hi_diffs `thenRn` \b ->
-     if b then putDocRn msg else returnRn ()
+traceHiDiffsRn msg = ifOptRn Opt_D_dump_hi_diffs (putDocRn msg)
 
 putDocRn :: SDoc -> RnM d ()
 putDocRn msg = ioToRnM (printErrs alwaysQualify msg)   `thenRn_`
@@ -151,6 +148,13 @@ data SDown = SDown {
 
                  rn_genv :: GlobalRdrEnv,      -- Top level environment
 
+                 rn_avails :: AvailEnv,        
+                       -- Top level AvailEnv; contains all the things that
+                       -- are nameable in the top-level scope, regardless of
+                       -- *how* they can be named (qualified, unqualified...)
+                       -- It is used only to map a Class to its class ops, and 
+                       -- hence to resolve the binders in an instance decl
+
                  rn_lenv :: LocalRdrEnv,       -- Local name envt
                        --   Does *not* include global name envt; may shadow it
                        --   Includes both ordinary variables and type variables;
@@ -172,6 +176,9 @@ data RnMode = SourceMode            -- Renaming source code
 
 isInterfaceMode InterfaceMode = True
 isInterfaceMode _ = False
+
+isCmdLineMode CmdLineMode = True
+isCmdLineMode _ = False
 \end{code}
 
 %===================================================
@@ -195,14 +202,6 @@ lookupLocalFixity env name
        Nothing                  -> defaultFixity
 \end{code}
 
-\begin{code}
-type ExportAvails = (FiniteMap ModuleName Avails,
-       -- Used to figure out "module M" export specifiers
-       -- Includes avails only from *unqualified* imports
-       -- (see 1.4 Report Section 5.1.1)
-
-                    AvailEnv)  -- Used to figure out all other export specifiers.
-\end{code}
 
 %===================================================
 \subsubsection{                INTERFACE FILE STUFF}
@@ -369,22 +368,24 @@ initRn dflags hit hst pcs mod do_rn
        
        return (new_pcs, (warns, errs), res)
 
-initRnMS :: GlobalRdrEnv -> LocalRdrEnv -> LocalFixityEnv -> RnMode
+initRnMS :: GlobalRdrEnv -> AvailEnv -> LocalRdrEnv -> LocalFixityEnv -> RnMode
         -> RnMS a -> RnM d a
 
-initRnMS rn_env local_env fixity_env mode thing_inside rn_down g_down
+initRnMS rn_env avails local_env fixity_env mode thing_inside rn_down g_down
        -- The fixity_env appears in both the rn_fixenv field
        -- and in the HIT.  See comments with RnHiFiles.lookupFixityRn
   = let
-       s_down = SDown { rn_genv = rn_env, rn_lenv = local_env, 
-                        rn_fixenv = fixity_env, rn_mode = mode }
+       s_down = SDown { rn_genv = rn_env, rn_avails = avails, 
+                        rn_lenv = local_env, rn_fixenv = fixity_env, 
+                        rn_mode = mode }
     in
     thing_inside rn_down s_down
 
 initIfaceRnMS :: Module -> RnMS r -> RnM d r
 initIfaceRnMS mod thing_inside 
-  = initRnMS emptyRdrEnv emptyRdrEnv emptyLocalFixityEnv InterfaceMode $
-    setModuleRn mod thing_inside
+  = initRnMS emptyRdrEnv emptyAvailEnv emptyRdrEnv 
+            emptyLocalFixityEnv InterfaceMode
+            (setModuleRn mod thing_inside)
 \end{code}
 
 @renameDerivedCode@ is used to rename stuff ``out-of-line'';
@@ -420,8 +421,9 @@ renameDerivedCode dflags mod prs thing_inside
                                 rn_hit    = bogus "rn_hit",
                                 rn_ifaces = bogus "rn_ifaces"
                               }
-       ; let s_down = SDown { rn_mode = InterfaceMode,
+       ; let s_down = SDown { rn_mode = InterfaceMode, 
                               -- So that we can refer to PrelBase.True etc
+                              rn_avails = emptyAvailEnv,
                               rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv,
                               rn_fixenv = emptyLocalFixityEnv }
 
@@ -552,6 +554,21 @@ warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down
   where
     warn = addShortWarnLocLine loc msg
 
+tryRn :: RnM d a -> RnM d (Either Messages a)
+tryRn try_this down@(RnDown {rn_errs = errs_var}) l_down
+  = do current_msgs <- readIORef errs_var
+       writeIORef errs_var (emptyBag,emptyBag)
+       a <- try_this down l_down
+       (warns, errs) <- readIORef errs_var
+       writeIORef errs_var current_msgs
+       if (isEmptyBag errs)
+         then return (Right a)
+         else return (Left (warns,errs))
+
+setErrsRn :: Messages -> RnM d ()
+setErrsRn msgs down@(RnDown {rn_errs = errs_var}) l_down
+  = do writeIORef errs_var msgs; return ()
+
 addErrRn :: Message -> RnM d ()
 addErrRn err = failWithRn () err
 
@@ -575,6 +592,11 @@ doptRn :: DynFlag -> RnM d Bool
 doptRn dflag (RnDown { rn_dflags = dflags}) l_down
    = return (dopt dflag dflags)
 
+ifOptRn :: DynFlag -> RnM d a -> RnM d ()
+ifOptRn dflag thing_inside down@(RnDown { rn_dflags = dflags}) l_down
+  | dopt dflag dflags = thing_inside down l_down >> return ()
+  | otherwise        = return ()
+
 getDOptsRn :: RnM d DynFlags
 getDOptsRn (RnDown { rn_dflags = dflags}) l_down
    = return dflags
@@ -605,6 +627,11 @@ getHomeIfaceTableRn down l_down = return (rn_hit down)
 
 getTypeEnvRn :: RnM d (Name -> Maybe TyThing)
 getTypeEnvRn down l_down = return (rn_done down)
+
+extendTypeEnvRn :: NameEnv TyThing -> RnM d a -> RnM d a
+extendTypeEnvRn env inside down l_down
+  = inside down{rn_done=new_rn_done} l_down
+  where new_rn_done = \nm -> lookupNameEnv env nm `seqMaybe` rn_done down nm
 \end{code}
 
 %================
@@ -664,6 +691,10 @@ getGlobalNameEnv :: RnMS GlobalRdrEnv
 getGlobalNameEnv rn_down (SDown {rn_genv = global_env})
   = return global_env
 
+getGlobalAvails :: RnMS AvailEnv
+getGlobalAvails  rn_down (SDown {rn_avails = avails})
+  = return avails
+
 setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a
 setLocalNameEnv local_env' m rn_down l_down
   = m rn_down (l_down {rn_lenv = local_env'})