X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnMonad.lhs;h=90de0eed710cf4861de56a807274b068696242fb;hb=f62fd70df7695286af55854911dad8a28eecb5e1;hp=9f3bb3ec71750eb4bf8d3a79777e008d54813fb5;hpb=1c62b517711ac232a8024d91fd4b317a6804d28e;p=ghc-hetmet.git

diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 9f3bb3e..90de0ee 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -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}
 
 %===================================================
@@ -276,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
@@ -546,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
 
@@ -569,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
@@ -599,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}
 
 %================