[project @ 2001-08-23 15:05:52 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 5a215ab..90de0ee 100644 (file)
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -42,7 +42,7 @@ import HscTypes               ( AvailEnv, lookupType,
                          PersistentRenamerState(..), Avails,
                          DeclsMap, IfaceInsts, IfaceRules, 
                          HomeSymbolTable, TyThing,
-                         PersistentCompilerState(..), GlobalRdrEnv,
+                         PersistentCompilerState(..), GlobalRdrEnv, LocalRdrEnv,
                          HomeIfaceTable, PackageIfaceTable,
                          RdrAvailInfo )
 import BasicTypes      ( Version, defaultFixity )
@@ -58,13 +58,14 @@ import Name         ( Name, OccName, NamedThing(..),
                          nameOccName,
                          decode, mkLocalName, mkKnownKeyGlobal
                        )
-import Name            ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList )
+import NameEnv         ( NameEnv, lookupNameEnv, emptyNameEnv, extendNameEnvList )
 import Module          ( Module, ModuleName, ModuleSet, emptyModuleSet )
 import NameSet         
 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_`
@@ -172,6 +169,9 @@ data RnMode = SourceMode            -- Renaming source code
 
 isInterfaceMode InterfaceMode = True
 isInterfaceMode _ = False
+
+isCmdLineMode CmdLineMode = True
+isCmdLineMode _ = False
 \end{code}
 
 %===================================================
@@ -180,7 +180,6 @@ isInterfaceMode _ = False
 
 \begin{code}
 --------------------------------
-type LocalRdrEnv    = RdrNameEnv Name
 type LocalFixityEnv = NameEnv RenamedFixitySig
        -- We keep the whole fixity sig so that we
        -- can report line-number info when there is a duplicate
@@ -277,6 +276,12 @@ data Ifaces = Ifaces {
        iSlurp :: NameSet,
                -- All the names (whether "big" or "small", whether wired-in or not,
                -- whether locally defined or not) that have been slurped in so far.
+               --
+               -- It's used for two things:
+               --      a) To record what we've already slurped, so
+               --         we can no-op if we try to slurp it again
+               --      b) As the 'gates' for importing rules.  We import a rule
+               --         if all its LHS free vars have been slurped
 
        iVSlurp :: (ModuleSet, NameSet)
                -- The Names are all the (a) non-wired-in
@@ -364,21 +369,21 @@ initRn dflags hit hst pcs mod do_rn
        
        return (new_pcs, (warns, errs), res)
 
-initRnMS :: GlobalRdrEnv -> LocalFixityEnv -> RnMode
+initRnMS :: GlobalRdrEnv -> LocalRdrEnv -> LocalFixityEnv -> RnMode
         -> RnMS a -> RnM d a
 
-initRnMS rn_env fixity_env mode thing_inside rn_down g_down
+initRnMS rn_env 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 = emptyRdrEnv, 
+       s_down = SDown { rn_genv = rn_env, 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 emptyLocalFixityEnv InterfaceMode $
+  = initRnMS emptyRdrEnv emptyRdrEnv emptyLocalFixityEnv InterfaceMode $
     setModuleRn mod thing_inside
 \end{code}
 
@@ -547,6 +552,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
 
@@ -570,6 +590,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
@@ -600,6 +625,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}
 
 %================