getModuleDs,
newUnique,
UniqSupply, newUniqueSupply,
- getDOptsDs,
+ getDOptsDs, getGhcModeDs, doptDs,
dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
initDs hsc_env mod rdr_env type_env thing_inside
= do { msg_var <- newIORef (emptyBag, emptyBag)
- ; let (ds_gbl_env, ds_lcl_env) = mkDsEnvs mod rdr_env type_env msg_var
+ ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs mod rdr_env type_env msg_var
; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
tryM thing_inside -- Catch exceptions (= errors during desugaring)
; msg_var <- getErrsVar
; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
- ; setEnvs (mkDsEnvs this_mod rdr_env type_env msg_var) thing_inside }
+ ; ds_envs <- ioToIOEnv$ mkDsEnvs this_mod rdr_env type_env msg_var
+ ; setEnvs ds_envs thing_inside }
-mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv
- -> IORef Messages -> (DsGblEnv, DsLclEnv)
+mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
mkDsEnvs mod rdr_env type_env msg_var
- = (gbl_env, lcl_env)
- where
- if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
- if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
- gbl_env = DsGblEnv { ds_mod = mod,
- ds_if_env = (if_genv, if_lenv),
- ds_unqual = mkPrintUnqualified rdr_env,
- ds_msgs = msg_var }
- lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
- ds_loc = noSrcSpan }
+ = do
+ sites_var <- newIORef []
+ let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
+ if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
+ gbl_env = DsGblEnv { ds_mod = mod,
+ ds_if_env = (if_genv, if_lenv),
+ ds_unqual = mkPrintUnqualified rdr_env,
+ ds_msgs = msg_var}
+ lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
+ ds_loc = noSrcSpan }
+
+ return (gbl_env, lcl_env)
+
\end{code}
%************************************************************************
getDOptsDs :: DsM DynFlags
getDOptsDs = getDOpts
+doptDs :: DynFlag -> TcRnIf gbl lcl Bool
+doptDs = doptM
+
+getGhcModeDs :: DsM GhcMode
+getGhcModeDs = getDOptsDs >>= return . ghcMode
+
getModuleDs :: DsM Module
getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
dsExtendMetaEnv menv thing_inside
= updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
\end{code}
-
-