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
(\ 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_`
isInterfaceMode InterfaceMode = True
isInterfaceMode _ = False
+
+isCmdLineMode CmdLineMode = True
+isCmdLineMode _ = False
\end{code}
%===================================================
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
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
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
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}
%================