module IOEnv
) where
+#include "HsVersions.h"
+
import TcRnTypes -- Re-export all
import IOEnv -- Re-export all
import System.IO
import Data.IORef
+import qualified Data.Set as Set
import Control.Monad
\end{code}
tvs_var <- newIORef emptyVarSet ;
dfuns_var <- newIORef emptyNameSet ;
keep_var <- newIORef emptyNameSet ;
+ used_rdrnames_var <- newIORef Set.empty ;
th_var <- newIORef False ;
dfun_n_var <- newIORef 1 ;
type_env_var <- case hsc_type_env_var hsc_env of {
tcg_th_used = th_var,
tcg_exports = [],
tcg_imports = emptyImportAvails,
+ tcg_used_rdrnames = used_rdrnames_var,
tcg_dus = emptyDUs,
- tcg_rn_imports = maybe_rn_syntax [],
+ tcg_rn_imports = [],
tcg_rn_exports = maybe_rn_syntax [],
tcg_rn_decls = maybe_rn_syntax emptyRnGroup,
tcg_binds = emptyLHsBinds,
- tcg_warns = NoWarnings,
+ tcg_warns = NoWarnings,
+ tcg_anns = [],
tcg_insts = [],
tcg_fam_insts= [],
tcg_rules = [],
tcl_arrow_ctxt = NoArrowCtxt,
tcl_env = emptyNameEnv,
tcl_tyvars = tvs_var,
- tcl_lie = panic "initTc:LIE" -- LIE only valid inside a getLIE
+ tcl_lie = panic "initTc:LIE", -- only valid inside getLIE
+ tcl_tybinds = panic "initTc:tybinds"
+ -- only valid inside a getTyBinds
} ;
} ;
; dumpTcRn real_doc }
dumpTcRn :: SDoc -> TcRn ()
-dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
- dflags <- getDOpts ;
- liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
+dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv
+ ; dflags <- getDOpts
+ ; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
debugDumpTcRn :: SDoc -> TcRn ()
debugDumpTcRn doc | opt_NoDebugOutput = return ()
| otherwise = return ()
\end{code}
- %************************************************************************
+%************************************************************************
%* *
Type constraints (the so-called LIE)
%* *
%************************************************************************
%* *
+ Meta type variable bindings
+%* *
+%************************************************************************
+
+\begin{code}
+getTcTyVarBindsVar :: TcM (TcRef TcTyVarBinds)
+getTcTyVarBindsVar = do { env <- getLclEnv; return (tcl_tybinds env) }
+
+getTcTyVarBinds :: TcM a -> TcM (a, TcTyVarBinds)
+getTcTyVarBinds thing_inside
+ = do { tybinds_var <- newMutVar emptyBag
+ ; res <- updLclEnv (\ env -> env { tcl_tybinds = tybinds_var })
+ thing_inside
+ ; tybinds <- readMutVar tybinds_var
+ ; return (res, tybinds)
+ }
+
+bindMetaTyVar :: TcTyVar -> TcType -> TcM ()
+bindMetaTyVar tv ty
+ = do { ASSERTM2( do { details <- readMutVar (metaTvRef tv)
+ ; return (isFlexi details) }, ppr tv )
+ ; tybinds_var <- getTcTyVarBindsVar
+ ; tybinds <- readMutVar tybinds_var
+ ; writeMutVar tybinds_var (tybinds `snocBag` TcTyVarBind tv ty)
+ }
+
+getTcTyVarBindsRelation :: TcM [(TcTyVar, TcTyVarSet)]
+getTcTyVarBindsRelation
+ = do { tybinds_var <- getTcTyVarBindsVar
+ ; tybinds <- readMutVar tybinds_var
+ ; return $ map freeTvs (bagToList tybinds)
+ }
+ where
+ freeTvs (TcTyVarBind tv ty) = (tv, tyVarsOfType ty)
+\end{code}
+
+%************************************************************************
+%* *
Template Haskell context
%* *
%************************************************************************