import TcType
import InstEnv
import FamInstEnv
+import PrelNames ( iNTERACTIVE )
import Var
import Id
initTc hsc_env hsc_src keep_rn_syntax mod do_this
= do { errs_var <- newIORef (emptyBag, emptyBag) ;
+ meta_var <- newIORef initTyVarUnique ;
tvs_var <- newIORef emptyVarSet ;
- dfuns_var <- newIORef emptyNameSet ;
- keep_var <- newIORef emptyNameSet ;
+ keep_var <- newIORef emptyNameSet ;
used_rdr_var <- newIORef Set.empty ;
th_var <- newIORef False ;
- lie_var <- newIORef emptyBag ;
+ lie_var <- newIORef emptyWC ;
dfun_n_var <- newIORef emptyOccSet ;
type_env_var <- case hsc_type_env_var hsc_env of {
Just (_mod, te_var) -> return te_var ;
gbl_env = TcGblEnv {
tcg_mod = mod,
tcg_src = hsc_src,
- tcg_rdr_env = hsc_global_rdr_env hsc_env,
+ tcg_rdr_env = emptyGlobalRdrEnv,
tcg_fix_env = emptyNameEnv,
tcg_field_env = RecFields emptyNameEnv emptyNameSet,
tcg_default = Nothing,
- tcg_type_env = hsc_global_type_env hsc_env,
+ tcg_type_env = emptyNameEnv,
tcg_type_env_var = type_env_var,
tcg_inst_env = emptyInstEnv,
tcg_fam_inst_env = emptyFamInstEnv,
- tcg_inst_uses = dfuns_var,
- tcg_th_used = th_var,
+ tcg_th_used = th_var,
tcg_exports = [],
tcg_imports = emptyImportAvails,
tcg_used_rdrnames = used_rdr_var,
tcg_rn_exports = maybe_rn_syntax [],
tcg_rn_decls = maybe_rn_syntax emptyRnGroup,
- tcg_binds = emptyLHsBinds,
- tcg_ev_binds = emptyBag,
- tcg_warns = NoWarnings,
- tcg_anns = [],
- tcg_insts = [],
- tcg_fam_insts= [],
- tcg_rules = [],
- tcg_fords = [],
- tcg_dfun_n = dfun_n_var,
- tcg_keep = keep_var,
- tcg_doc_hdr = Nothing,
- tcg_hpc = False,
- tcg_main = Nothing
+ tcg_binds = emptyLHsBinds,
+ tcg_imp_specs = [],
+ tcg_sigs = emptyNameSet,
+ tcg_ev_binds = emptyBag,
+ tcg_warns = NoWarnings,
+ tcg_anns = [],
+ tcg_insts = [],
+ tcg_fam_insts = [],
+ tcg_rules = [],
+ tcg_fords = [],
+ tcg_dfun_n = dfun_n_var,
+ tcg_keep = keep_var,
+ tcg_doc_hdr = Nothing,
+ tcg_hpc = False,
+ tcg_main = Nothing
} ;
lcl_env = TcLclEnv {
tcl_errs = errs_var,
tcl_env = emptyNameEnv,
tcl_tyvars = tvs_var,
tcl_lie = lie_var,
- tcl_untch = emptyVarSet
+ tcl_meta = meta_var,
+ tcl_untch = initTyVarUnique
} ;
} ;
-- Check for unsolved constraints
lie <- readIORef lie_var ;
- if isEmptyBag lie
+ if isEmptyWC lie
then return ()
else pprPanic "initTc: unsolved constraints"
(pprWantedsWithLocs lie) ;
-> Module
-> TcM r
-> IO (Messages, Maybe r)
-initTcPrintErrors env mod todo = do
- (msgs, res) <- initTc env HsSrcFile False mod todo
- return (msgs, res)
+
+initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo
\end{code}
%************************************************************************
setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
- env { env_top = top { hsc_dflags = xopt_set_flattened (hsc_dflags top) flag}} )
+ env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} )
unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
%************************************************************************
\begin{code}
+newMetaUnique :: TcM Unique
+-- The uniques for TcMetaTyVars are allocated specially
+-- in guaranteed linear order, starting at zero for each module
+newMetaUnique
+ = do { env <- getLclEnv
+ ; let meta_var = tcl_meta env
+ ; uniq <- readMutVar meta_var
+ ; writeMutVar meta_var (incrUnique uniq)
+ ; return uniq }
+
newUnique :: TcRnIf gbl lcl Unique
newUnique
= do { env <- getEnv ;
- let { u_var = env_us env } ;
- us <- readMutVar u_var ;
- case splitUniqSupply us of { (us1,_) -> do {
- writeMutVar u_var us1 ;
- return $! uniqFromSupply us }}}
+ let { u_var = env_us env } ;
+ us <- readMutVar u_var ;
+ case takeUniqFromSupply us of { (uniq, us') -> do {
+ writeMutVar u_var us' ;
+ return $! uniq }}}
-- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
-- a chain of unevaluated supplies behind.
-- NOTE 2: we use the uniq in the supply from the MutVar directly, and
newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
= do { env <- getEnv ;
- let { u_var = env_us env } ;
- us <- readMutVar u_var ;
+ let { u_var = env_us env } ;
+ us <- readMutVar u_var ;
case splitUniqSupply us of { (us1,us2) -> do {
- writeMutVar u_var us1 ;
- return us2 }}}
+ writeMutVar u_var us1 ;
+ return us2 }}}
newLocalName :: Name -> TcRnIf gbl lcl Name
newLocalName name -- Make a clone
setModule :: Module -> TcRn a -> TcRn a
setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
+getIsGHCi :: TcRn Bool
+getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) }
+
tcIsHsBoot :: TcRn Bool
tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
(warns, errs) <- readTcRef errs_var ;
writeTcRef errs_var (warns, errs `snocBag` err) }
+
+dumpDerivingInfo :: SDoc -> TcM ()
+dumpDerivingInfo doc
+ = do { dflags <- getDOpts
+ ; when (dopt Opt_D_dump_deriv dflags) $ do
+ { rdr_env <- getGlobalRdrEnv
+ ; let unqual = mkPrintUnqualified dflags rdr_env
+ ; liftIO (putMsgWith dflags unqual doc) } }
\end{code}
-- for the thing is propagated only if there are no errors
-- Hence it's restricted to the type-check monad
tryTcLIE thing_inside
- = do { ((msgs, mb_res), lie) <- getConstraints (tryTcErrs thing_inside) ;
+ = do { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
; case mb_res of
Nothing -> return (msgs, Nothing)
Just val -> do { emitConstraints lie; return (msgs, Just val) }
emitConstraints :: WantedConstraints -> TcM ()
emitConstraints ct
= do { lie_var <- getConstraintVar ;
- updTcRef lie_var (`andWanteds` ct) }
+ updTcRef lie_var (`andWC` ct) }
+
+emitFlat :: WantedEvVar -> TcM ()
+emitFlat ct
+ = do { lie_var <- getConstraintVar ;
+ updTcRef lie_var (`addFlats` unitBag ct) }
-emitConstraint :: WantedConstraint -> TcM ()
-emitConstraint ct
+emitFlats :: Bag WantedEvVar -> TcM ()
+emitFlats ct
= do { lie_var <- getConstraintVar ;
- updTcRef lie_var (`extendWanteds` ct) }
+ updTcRef lie_var (`addFlats` ct) }
-getConstraints :: TcM a -> TcM (a, WantedConstraints)
--- (getConstraints m) runs m, and returns the type constraints it generates
-getConstraints thing_inside
- = do { lie_var <- newTcRef emptyWanteds ;
+emitImplication :: Implication -> TcM ()
+emitImplication ct
+ = do { lie_var <- getConstraintVar ;
+ updTcRef lie_var (`addImplics` unitBag ct) }
+
+emitImplications :: Bag Implication -> TcM ()
+emitImplications ct
+ = do { lie_var <- getConstraintVar ;
+ updTcRef lie_var (`addImplics` ct) }
+
+captureConstraints :: TcM a -> TcM (a, WantedConstraints)
+-- (captureConstraints m) runs m, and returns the type constraints it generates
+captureConstraints thing_inside
+ = do { lie_var <- newTcRef emptyWC ;
res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
thing_inside ;
lie <- readTcRef lie_var ;
return (res, lie) }
-setUntouchables :: TcTyVarSet -> TcM a -> TcM a
-setUntouchables untch_tvs thing_inside
- = updLclEnv (\ env -> env { tcl_untch = untch_tvs }) thing_inside
-
-getUntouchables :: TcM TcTyVarSet
-getUntouchables
- = do { env <- getLclEnv; return (tcl_untch env) }
+captureUntouchables :: TcM a -> TcM (a, Untouchables)
+captureUntouchables thing_inside
+ = do { env <- getLclEnv
+ ; low_meta <- readTcRef (tcl_meta env)
+ ; res <- setLclEnv (env { tcl_untch = low_meta })
+ thing_inside
+ ; high_meta <- readTcRef (tcl_meta env)
+ ; return (res, TouchableRange low_meta high_meta) }
isUntouchable :: TcTyVar -> TcM Bool
-isUntouchable tv = do { env <- getLclEnv; return (tv `elemVarSet` tcl_untch env) }
+isUntouchable tv = do { env <- getLclEnv
+ ; return (varUnique tv < tcl_untch env) }
getLclTypeEnv :: TcM (NameEnv TcTyThing)
getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }