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 ;
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
} ;
} ;
getDOpts :: TcRnIf gbl lcl DynFlags
getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
-doptM :: DOpt d => d -> TcRnIf gbl lcl Bool
+xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool
+xoptM flag = do { dflags <- getDOpts; return (xopt flag dflags) }
+
+doptM :: DynFlag -> TcRnIf gbl lcl Bool
doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
-- XXX setOptM and unsetOptM operate on different types. One should be renamed.
setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
- env { env_top = top { hsc_dflags = lopt_set_flattened (hsc_dflags top) flag}} )
+ env { env_top = top { hsc_dflags = xopt_set_flattened (hsc_dflags top) flag}} )
unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )
-- | Do it flag is true
-ifOptM :: DOpt d => d -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
-ifOptM flag thing_inside = do { b <- doptM flag;
+ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+ifDOptM flag thing_inside = do { b <- doptM flag;
+ if b then thing_inside else return () }
+
+ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+ifXOptM flag thing_inside = do { b <- xoptM flag;
if b then thing_inside else return () }
getGhcMode :: TcRnIf gbl lcl GhcMode
%************************************************************************
\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 ;
traceOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything
-traceOptIf flag doc = ifOptM flag $
+traceOptIf flag doc = ifDOptM flag $
liftIO (printForUser stderr alwaysQualify doc)
traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
-- Output the message, with current location if opt_PprStyle_Debug
-traceOptTcRn flag doc = ifOptM flag $ do
+traceOptTcRn flag doc = ifDOptM flag $ do
{ loc <- getSrcSpanM
; let real_doc
| opt_PprStyle_Debug = mkLocMessage loc doc
| otherwise = dumpTcRn doc
dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
-dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
+dumpOptTcRn flag doc = ifDOptM flag (dumpTcRn 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) }
= do { lie_var <- getConstraintVar ;
updTcRef lie_var (`extendWanteds` ct) }
-getConstraints :: TcM a -> TcM (a, WantedConstraints)
--- (getConstraints m) runs m, and returns the type constraints it generates
-getConstraints thing_inside
+captureConstraints :: TcM a -> TcM (a, WantedConstraints)
+-- (captureConstraints m) runs m, and returns the type constraints it generates
+captureConstraints thing_inside
= do { lie_var <- newTcRef emptyWanteds ;
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) }
-- Bleat about errors in the forked thread, if -ddump-if-trace is on
-- Otherwise we silently discard errors. Errors can legitimately
-- happen when compiling interface signatures (see tcInterfaceSigs)
- ifOptM Opt_D_dump_if_trace
+ ifDOptM Opt_D_dump_if_trace
(print_errs (hang (text "forkM failed:" <+> doc)
2 (text (show exn))))
projects / ghc-hetmet.git / blobdiff