Second attempt to fix sizeExpr
[ghc.git] / compiler / typecheck / TcRnMonad.hs
1 {-
2 (c) The University of Glasgow 2006
3
4
5 Functions for working with the typechecker environment (setters, getters...).
6 -}
7
8 {-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances #-}
9 {-# OPTIONS_GHC -fno-warn-orphans #-}
10
11 module TcRnMonad(
12 -- * Initalisation
13 initTc, initTcInteractive, initTcForLookup, initTcRnIf,
14
15 -- * Simple accessors
16 discardResult,
17 getTopEnv, updTopEnv, getGblEnv, updGblEnv,
18 setGblEnv, getLclEnv, updLclEnv, setLclEnv,
19 getEnvs, setEnvs,
20 xoptM, doptM, goptM, woptM,
21 setXOptM, unsetGOptM, unsetWOptM,
22 whenDOptM, whenGOptM, whenWOptM, whenXOptM,
23 getGhcMode,
24 withDoDynamicToo,
25 getEpsVar,
26 getEps,
27 updateEps, updateEps_,
28 getHpt, getEpsAndHpt,
29
30 -- * Arrow scopes
31 newArrowScope, escapeArrowScope,
32
33 -- * Unique supply
34 newUnique, newUniqueSupply, newLocalName, newName,
35 newSysName, newSysLocalId, newSysLocalIds,
36
37 -- * Accessing input/output
38 newTcRef, readTcRef, writeTcRef, updTcRef,
39
40 -- * Debugging
41 traceTc, traceRn, traceOptTcRn, traceTcRn,
42 getPrintUnqualified,
43 printForUserTcRn,
44 debugDumpTcRn,
45 traceIf, traceHiDiffs, traceOptIf,
46 debugTc,
47
48 -- * Typechecker global environment
49 setModule, getIsGHCi, getGHCiMonad, getInteractivePrintName,
50 tcIsHsBootOrSig, tcSelfBootInfo, getGlobalRdrEnv,
51 getRdrEnvs, getImports,
52 getFixityEnv, extendFixityEnv, getRecFieldEnv,
53 getDeclaredDefaultTys,
54 addDependentFiles,
55
56 -- * Error management
57 getSrcSpanM, setSrcSpan, addLocM,
58 wrapLocM, wrapLocFstM, wrapLocSndM,
59 getErrsVar, setErrsVar,
60 addErr,
61 failWith, failAt,
62 addErrAt, addErrs,
63 checkErr,
64 addMessages,
65 discardWarnings,
66
67 -- * Shared error message stuff: renamer and typechecker
68 mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,
69 reportWarning, recoverM, mapAndRecoverM, mapAndReportM,
70 tryTc,
71 askNoErrs, discardErrs,
72 tryTcErrs, tryTcLIE, tryTcLIE_,
73 checkNoErrs, whenNoErrs,
74 ifErrsM, failIfErrsM,
75 checkTH, failTH,
76
77 -- * Context management for the type checker
78 getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
79 addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM,
80
81 -- * Error message generation (type checker)
82 addErrTc, addErrsTc,
83 addErrTcM, mkErrTcM,
84 failWithTc, failWithTcM,
85 checkTc, checkTcM,
86 failIfTc, failIfTcM,
87 warnIf, warnTc, warnTcM,
88 addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,
89 tcInitTidyEnv, tcInitOpenTidyEnv, mkErrInfo,
90
91 -- * Type constraints
92 newTcEvBinds,
93 addTcEvBind,
94 getTcEvBinds, getTcEvBindsMap,
95 chooseUniqueOccTc,
96 getConstraintVar, setConstraintVar,
97 emitConstraints, emitSimple, emitSimples,
98 emitImplication, emitImplications, emitInsoluble,
99 discardConstraints, captureConstraints,
100 pushLevelAndCaptureConstraints,
101 pushTcLevelM_, pushTcLevelM,
102 getTcLevel, setTcLevel, isTouchableTcM,
103 getLclTypeEnv, setLclTypeEnv,
104 traceTcConstraints, emitWildCardHoleConstraints,
105
106 -- * Template Haskell context
107 recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc,
108 getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage,
109
110 -- * Safe Haskell context
111 recordUnsafeInfer, finalSafeMode, fixSafeInstances,
112
113 -- * Stuff for the renamer's local env
114 getLocalRdrEnv, setLocalRdrEnv,
115
116 -- * Stuff for interface decls
117 mkIfLclEnv,
118 initIfaceTcRn,
119 initIfaceCheck,
120 initIfaceTc,
121 initIfaceLcl,
122 getIfModule,
123 failIfM,
124 forkM_maybe,
125 forkM,
126
127 -- * Types etc.
128 module TcRnTypes,
129 module IOEnv
130 ) where
131
132 #include "HsVersions.h"
133
134 import TcRnTypes -- Re-export all
135 import IOEnv -- Re-export all
136 import TcEvidence
137
138 import HsSyn hiding (LIE)
139 import HscTypes
140 import Module
141 import RdrName
142 import Name
143 import Type
144
145 import TcType
146 import InstEnv
147 import FamInstEnv
148 import PrelNames
149
150 import Id
151 import VarSet
152 import VarEnv
153 import ErrUtils
154 import SrcLoc
155 import NameEnv
156 import NameSet
157 import Bag
158 import Outputable
159 import UniqSupply
160 import DynFlags
161 import StaticFlags
162 import FastString
163 import Panic
164 import Util
165 import Annotations
166 import BasicTypes( TopLevelFlag )
167
168 import qualified GHC.LanguageExtensions as LangExt
169
170 import Control.Exception
171 import Data.IORef
172 import Control.Monad
173 import Data.Set ( Set )
174 import qualified Data.Set as Set
175
176 #ifdef GHCI
177 import qualified Data.Map as Map
178 #endif
179
180 {-
181 ************************************************************************
182 * *
183 initTc
184 * *
185 ************************************************************************
186 -}
187
188 -- | Setup the initial typechecking environment
189 initTc :: HscEnv
190 -> HscSource
191 -> Bool -- True <=> retain renamed syntax trees
192 -> Module
193 -> RealSrcSpan
194 -> TcM r
195 -> IO (Messages, Maybe r)
196 -- Nothing => error thrown by the thing inside
197 -- (error messages should have been printed already)
198
199 initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
200 = do { errs_var <- newIORef (emptyBag, emptyBag) ;
201 tvs_var <- newIORef emptyVarSet ;
202 keep_var <- newIORef emptyNameSet ;
203 used_gre_var <- newIORef [] ;
204 th_var <- newIORef False ;
205 th_splice_var<- newIORef False ;
206 th_locs_var <- newIORef Set.empty ;
207 infer_var <- newIORef (True, emptyBag) ;
208 lie_var <- newIORef emptyWC ;
209 dfun_n_var <- newIORef emptyOccSet ;
210 type_env_var <- case hsc_type_env_var hsc_env of {
211 Just (_mod, te_var) -> return te_var ;
212 Nothing -> newIORef emptyNameEnv } ;
213
214 dependent_files_var <- newIORef [] ;
215 static_wc_var <- newIORef emptyWC ;
216 #ifdef GHCI
217 th_topdecls_var <- newIORef [] ;
218 th_topnames_var <- newIORef emptyNameSet ;
219 th_modfinalizers_var <- newIORef [] ;
220 th_state_var <- newIORef Map.empty ;
221 th_remote_state_var <- newIORef Nothing ;
222 #endif /* GHCI */
223 let {
224 dflags = hsc_dflags hsc_env ;
225
226 maybe_rn_syntax :: forall a. a -> Maybe a ;
227 maybe_rn_syntax empty_val
228 | keep_rn_syntax = Just empty_val
229 | otherwise = Nothing ;
230
231 gbl_env = TcGblEnv {
232 #ifdef GHCI
233 tcg_th_topdecls = th_topdecls_var,
234 tcg_th_topnames = th_topnames_var,
235 tcg_th_modfinalizers = th_modfinalizers_var,
236 tcg_th_state = th_state_var,
237 tcg_th_remote_state = th_remote_state_var,
238 #endif /* GHCI */
239
240 tcg_mod = mod,
241 tcg_src = hsc_src,
242 tcg_sig_of = getSigOf dflags (moduleName mod),
243 tcg_impl_rdr_env = Nothing,
244 tcg_rdr_env = emptyGlobalRdrEnv,
245 tcg_fix_env = emptyNameEnv,
246 tcg_field_env = emptyNameEnv,
247 tcg_default = if moduleUnitId mod == primUnitId
248 then Just [] -- See Note [Default types]
249 else Nothing,
250 tcg_type_env = emptyNameEnv,
251 tcg_type_env_var = type_env_var,
252 tcg_inst_env = emptyInstEnv,
253 tcg_fam_inst_env = emptyFamInstEnv,
254 tcg_ann_env = emptyAnnEnv,
255 tcg_th_used = th_var,
256 tcg_th_splice_used = th_splice_var,
257 tcg_th_top_level_locs
258 = th_locs_var,
259 tcg_exports = [],
260 tcg_imports = emptyImportAvails,
261 tcg_used_gres = used_gre_var,
262 tcg_dus = emptyDUs,
263
264 tcg_rn_imports = [],
265 tcg_rn_exports = maybe_rn_syntax [],
266 tcg_rn_decls = maybe_rn_syntax emptyRnGroup,
267 tcg_tr_module = Nothing,
268 tcg_binds = emptyLHsBinds,
269 tcg_imp_specs = [],
270 tcg_sigs = emptyNameSet,
271 tcg_ev_binds = emptyBag,
272 tcg_warns = NoWarnings,
273 tcg_anns = [],
274 tcg_tcs = [],
275 tcg_insts = [],
276 tcg_fam_insts = [],
277 tcg_rules = [],
278 tcg_fords = [],
279 tcg_vects = [],
280 tcg_patsyns = [],
281 tcg_dfun_n = dfun_n_var,
282 tcg_keep = keep_var,
283 tcg_doc_hdr = Nothing,
284 tcg_hpc = False,
285 tcg_main = Nothing,
286 tcg_self_boot = NoSelfBoot,
287 tcg_safeInfer = infer_var,
288 tcg_dependent_files = dependent_files_var,
289 tcg_tc_plugins = [],
290 tcg_static_wc = static_wc_var
291 } ;
292 lcl_env = TcLclEnv {
293 tcl_errs = errs_var,
294 tcl_loc = loc, -- Should be over-ridden very soon!
295 tcl_ctxt = [],
296 tcl_rdr = emptyLocalRdrEnv,
297 tcl_th_ctxt = topStage,
298 tcl_th_bndrs = emptyNameEnv,
299 tcl_arrow_ctxt = NoArrowCtxt,
300 tcl_env = emptyNameEnv,
301 tcl_bndrs = [],
302 tcl_tidy = emptyTidyEnv,
303 tcl_tyvars = tvs_var,
304 tcl_lie = lie_var,
305 tcl_tclvl = topTcLevel
306 } ;
307 } ;
308
309 -- OK, here's the business end!
310 maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
311 do { r <- tryM do_this
312 ; case r of
313 Right res -> return (Just res)
314 Left _ -> return Nothing } ;
315
316 -- Check for unsolved constraints
317 lie <- readIORef lie_var ;
318 if isEmptyWC lie
319 then return ()
320 else pprPanic "initTc: unsolved constraints" (ppr lie) ;
321
322 -- Collect any error messages
323 msgs <- readIORef errs_var ;
324
325 let { final_res | errorsFound dflags msgs = Nothing
326 | otherwise = maybe_res } ;
327
328 return (msgs, final_res)
329 }
330
331
332 initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
333 -- Initialise the type checker monad for use in GHCi
334 initTcInteractive hsc_env thing_inside
335 = initTc hsc_env HsSrcFile False
336 (icInteractiveModule (hsc_IC hsc_env))
337 (realSrcLocSpan interactive_src_loc)
338 thing_inside
339 where
340 interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
341
342 initTcForLookup :: HscEnv -> TcM a -> IO a
343 -- The thing_inside is just going to look up something
344 -- in the environment, so we don't need much setup
345 initTcForLookup hsc_env thing_inside
346 = do { (msgs, m) <- initTcInteractive hsc_env thing_inside
347 ; case m of
348 Nothing -> throwIO $ mkSrcErr $ snd msgs
349 Just x -> return x }
350
351 {- Note [Default types]
352 ~~~~~~~~~~~~~~~~~~~~~~~
353 The Integer type is simply not available in package ghc-prim (it is
354 declared in integer-gmp). So we set the defaulting types to (Just
355 []), meaning there are no default types, rather then Nothing, which
356 means "use the default default types of Integer, Double".
357
358 If you don't do this, attempted defaulting in package ghc-prim causes
359 an actual crash (attempting to look up the Integer type).
360
361
362 ************************************************************************
363 * *
364 Initialisation
365 * *
366 ************************************************************************
367 -}
368
369 initTcRnIf :: Char -- Tag for unique supply
370 -> HscEnv
371 -> gbl -> lcl
372 -> TcRnIf gbl lcl a
373 -> IO a
374 initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
375 = do { us <- mkSplitUniqSupply uniq_tag ;
376 ; us_var <- newIORef us ;
377
378 ; let { env = Env { env_top = hsc_env,
379 env_us = us_var,
380 env_gbl = gbl_env,
381 env_lcl = lcl_env} }
382
383 ; runIOEnv env thing_inside
384 }
385
386 {-
387 ************************************************************************
388 * *
389 Simple accessors
390 * *
391 ************************************************************************
392 -}
393
394 discardResult :: TcM a -> TcM ()
395 discardResult a = a >> return ()
396
397 getTopEnv :: TcRnIf gbl lcl HscEnv
398 getTopEnv = do { env <- getEnv; return (env_top env) }
399
400 updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
401 updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->
402 env { env_top = upd top })
403
404 getGblEnv :: TcRnIf gbl lcl gbl
405 getGblEnv = do { env <- getEnv; return (env_gbl env) }
406
407 updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
408 updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
409 env { env_gbl = upd gbl })
410
411 setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
412 setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
413
414 getLclEnv :: TcRnIf gbl lcl lcl
415 getLclEnv = do { env <- getEnv; return (env_lcl env) }
416
417 updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
418 updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
419 env { env_lcl = upd lcl })
420
421 setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
422 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
423
424 getEnvs :: TcRnIf gbl lcl (gbl, lcl)
425 getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
426
427 setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
428 setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
429
430 -- Command-line flags
431
432 xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool
433 xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }
434
435 doptM :: DumpFlag -> TcRnIf gbl lcl Bool
436 doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }
437
438 goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
439 goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) }
440
441 woptM :: WarningFlag -> TcRnIf gbl lcl Bool
442 woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }
443
444 setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
445 setXOptM flag =
446 updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag})
447
448 unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
449 unsetGOptM flag =
450 updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag})
451
452 unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
453 unsetWOptM flag =
454 updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag})
455
456 -- | Do it flag is true
457 whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
458 whenDOptM flag thing_inside = do b <- doptM flag
459 when b thing_inside
460
461 whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
462 whenGOptM flag thing_inside = do b <- goptM flag
463 when b thing_inside
464
465 whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
466 whenWOptM flag thing_inside = do b <- woptM flag
467 when b thing_inside
468
469 whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
470 whenXOptM flag thing_inside = do b <- xoptM flag
471 when b thing_inside
472
473 getGhcMode :: TcRnIf gbl lcl GhcMode
474 getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
475
476 withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
477 withDoDynamicToo =
478 updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->
479 top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags })
480
481 getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
482 getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
483
484 getEps :: TcRnIf gbl lcl ExternalPackageState
485 getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
486
487 -- | Update the external package state. Returns the second result of the
488 -- modifier function.
489 --
490 -- This is an atomic operation and forces evaluation of the modified EPS in
491 -- order to avoid space leaks.
492 updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
493 -> TcRnIf gbl lcl a
494 updateEps upd_fn = do
495 traceIf (text "updating EPS")
496 eps_var <- getEpsVar
497 atomicUpdMutVar' eps_var upd_fn
498
499 -- | Update the external package state.
500 --
501 -- This is an atomic operation and forces evaluation of the modified EPS in
502 -- order to avoid space leaks.
503 updateEps_ :: (ExternalPackageState -> ExternalPackageState)
504 -> TcRnIf gbl lcl ()
505 updateEps_ upd_fn = do
506 traceIf (text "updating EPS_")
507 eps_var <- getEpsVar
508 atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
509
510 getHpt :: TcRnIf gbl lcl HomePackageTable
511 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
512
513 getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
514 getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
515 ; return (eps, hsc_HPT env) }
516
517 {-
518 ************************************************************************
519 * *
520 Arrow scopes
521 * *
522 ************************************************************************
523 -}
524
525 newArrowScope :: TcM a -> TcM a
526 newArrowScope
527 = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }
528
529 -- Return to the stored environment (from the enclosing proc)
530 escapeArrowScope :: TcM a -> TcM a
531 escapeArrowScope
532 = updLclEnv $ \ env ->
533 case tcl_arrow_ctxt env of
534 NoArrowCtxt -> env
535 ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
536 , tcl_lie = lie
537 , tcl_rdr = rdr_env }
538
539 {-
540 ************************************************************************
541 * *
542 Unique supply
543 * *
544 ************************************************************************
545 -}
546
547 newUnique :: TcRnIf gbl lcl Unique
548 newUnique
549 = do { env <- getEnv ;
550 let { u_var = env_us env } ;
551 us <- readMutVar u_var ;
552 case takeUniqFromSupply us of { (uniq, us') -> do {
553 writeMutVar u_var us' ;
554 return $! uniq }}}
555 -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
556 -- a chain of unevaluated supplies behind.
557 -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
558 -- throw away one half of the new split supply. This is safe because this
559 -- is the only place we use that unique. Using the other half of the split
560 -- supply is safer, but slower.
561
562 newUniqueSupply :: TcRnIf gbl lcl UniqSupply
563 newUniqueSupply
564 = do { env <- getEnv ;
565 let { u_var = env_us env } ;
566 us <- readMutVar u_var ;
567 case splitUniqSupply us of { (us1,us2) -> do {
568 writeMutVar u_var us1 ;
569 return us2 }}}
570
571 cloneLocalName :: Name -> TcM Name
572 -- Make a fresh Internal name with the same OccName and SrcSpan
573 cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name)
574
575 newName :: OccName -> TcM Name
576 newName occ = do { loc <- getSrcSpanM
577 ; newNameAt occ loc }
578
579 newNameAt :: OccName -> SrcSpan -> TcM Name
580 newNameAt occ span
581 = do { uniq <- newUnique
582 ; return (mkInternalName uniq occ span) }
583
584 newSysName :: OccName -> TcRnIf gbl lcl Name
585 newSysName occ
586 = do { uniq <- newUnique
587 ; return (mkSystemName uniq occ) }
588
589 newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
590 newSysLocalId fs ty
591 = do { u <- newUnique
592 ; return (mkSysLocalOrCoVar fs u ty) }
593
594 newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
595 newSysLocalIds fs tys
596 = do { us <- newUniqueSupply
597 ; return (zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys) }
598
599 instance MonadUnique (IOEnv (Env gbl lcl)) where
600 getUniqueM = newUnique
601 getUniqueSupplyM = newUniqueSupply
602
603 {-
604 ************************************************************************
605 * *
606 Accessing input/output
607 * *
608 ************************************************************************
609 -}
610
611 newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
612 newTcRef = newMutVar
613
614 readTcRef :: TcRef a -> TcRnIf gbl lcl a
615 readTcRef = readMutVar
616
617 writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
618 writeTcRef = writeMutVar
619
620 updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
621 -- Returns ()
622 updTcRef ref fn = liftIO $ do { old <- readIORef ref
623 ; writeIORef ref (fn old) }
624
625 {-
626 ************************************************************************
627 * *
628 Debugging
629 * *
630 ************************************************************************
631 -}
632
633 traceTc :: String -> SDoc -> TcRn ()
634 traceTc herald doc = traceTcN 1 (hang (text herald) 2 doc)
635
636 -- | Typechecker trace
637 traceTcN :: Int -> SDoc -> TcRn ()
638 traceTcN level doc
639 = do dflags <- getDynFlags
640 when (level <= traceLevel dflags && not opt_NoDebugOutput) $
641 traceOptTcRn Opt_D_dump_tc_trace doc
642
643 traceRn :: SDoc -> TcRn ()
644 traceRn = traceOptTcRn Opt_D_dump_rn_trace -- Renamer Trace
645
646 -- | Output a doc if the given 'DumpFlag' is set.
647 --
648 -- By default this logs to stdout
649 -- However, if the `-ddump-to-file` flag is set,
650 -- then this will dump output to a file
651 --
652 -- Just a wrapper for 'dumpSDoc'
653 traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
654 traceOptTcRn flag doc
655 = do { dflags <- getDynFlags
656 ; when (dopt flag dflags) (traceTcRn flag doc)
657 }
658
659 traceTcRn :: DumpFlag -> SDoc -> TcRn ()
660 -- ^ Unconditionally dump some trace output
661 --
662 -- The DumpFlag is used only to set the output filename
663 -- for --dump-to-file, not to decide whether or not to output
664 -- That part is done by the caller
665 traceTcRn flag doc
666 = do { real_doc <- prettyDoc doc
667 ; dflags <- getDynFlags
668 ; printer <- getPrintUnqualified dflags
669 ; liftIO $ dumpSDoc dflags printer flag "" real_doc }
670 where
671 -- Add current location if opt_PprStyle_Debug
672 prettyDoc :: SDoc -> TcRn SDoc
673 prettyDoc doc = if opt_PprStyle_Debug
674 then do { loc <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }
675 else return doc -- The full location is usually way too much
676
677
678 getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
679 getPrintUnqualified dflags
680 = do { rdr_env <- getGlobalRdrEnv
681 ; return $ mkPrintUnqualified dflags rdr_env }
682
683 -- | Like logInfoTcRn, but for user consumption
684 printForUserTcRn :: SDoc -> TcRn ()
685 printForUserTcRn doc
686 = do { dflags <- getDynFlags
687 ; printer <- getPrintUnqualified dflags
688 ; liftIO (printOutputForUser dflags printer doc) }
689
690 -- | Typechecker debug
691 debugDumpTcRn :: SDoc -> TcRn ()
692 debugDumpTcRn doc = unless opt_NoDebugOutput $
693 traceOptTcRn Opt_D_dump_tc doc
694
695 {-
696 traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
697 available. Alas, they behave inconsistently with the other stuff;
698 e.g. are unaffected by -dump-to-file.
699 -}
700
701 traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
702 traceIf = traceOptIf Opt_D_dump_if_trace
703 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
704
705
706 traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
707 traceOptIf flag doc
708 = whenDOptM flag $ -- No RdrEnv available, so qualify everything
709 do { dflags <- getDynFlags
710 ; liftIO (putMsg dflags doc) }
711
712 {-
713 ************************************************************************
714 * *
715 Typechecker global environment
716 * *
717 ************************************************************************
718 -}
719
720 setModule :: Module -> TcRn a -> TcRn a
721 setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
722
723 getIsGHCi :: TcRn Bool
724 getIsGHCi = do { mod <- getModule
725 ; return (isInteractiveModule mod) }
726
727 getGHCiMonad :: TcRn Name
728 getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
729
730 getInteractivePrintName :: TcRn Name
731 getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }
732
733 tcIsHsBootOrSig :: TcRn Bool
734 tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
735
736 tcSelfBootInfo :: TcRn SelfBootInfo
737 tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }
738
739 getGlobalRdrEnv :: TcRn GlobalRdrEnv
740 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
741
742 getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
743 getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
744
745 getImports :: TcRn ImportAvails
746 getImports = do { env <- getGblEnv; return (tcg_imports env) }
747
748 getFixityEnv :: TcRn FixityEnv
749 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
750
751 extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
752 extendFixityEnv new_bit
753 = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
754 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
755
756 getRecFieldEnv :: TcRn RecFieldEnv
757 getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
758
759 getDeclaredDefaultTys :: TcRn (Maybe [Type])
760 getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
761
762 addDependentFiles :: [FilePath] -> TcRn ()
763 addDependentFiles fs = do
764 ref <- fmap tcg_dependent_files getGblEnv
765 dep_files <- readTcRef ref
766 writeTcRef ref (fs ++ dep_files)
767
768 {-
769 ************************************************************************
770 * *
771 Error management
772 * *
773 ************************************************************************
774 -}
775
776 getSrcSpanM :: TcRn SrcSpan
777 -- Avoid clash with Name.getSrcLoc
778 getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) }
779
780 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
781 setSrcSpan (RealSrcSpan real_loc) thing_inside
782 = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside
783 -- Don't overwrite useful info with useless:
784 setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
785
786 addLocM :: (a -> TcM b) -> Located a -> TcM b
787 addLocM fn (L loc a) = setSrcSpan loc $ fn a
788
789 wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
790 wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
791
792 wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
793 wrapLocFstM fn (L loc a) =
794 setSrcSpan loc $ do
795 (b,c) <- fn a
796 return (L loc b, c)
797
798 wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
799 wrapLocSndM fn (L loc a) =
800 setSrcSpan loc $ do
801 (b,c) <- fn a
802 return (b, L loc c)
803
804 -- Reporting errors
805
806 getErrsVar :: TcRn (TcRef Messages)
807 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
808
809 setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
810 setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v })
811
812 addErr :: MsgDoc -> TcRn ()
813 addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
814
815 failWith :: MsgDoc -> TcRn a
816 failWith msg = addErr msg >> failM
817
818 failAt :: SrcSpan -> MsgDoc -> TcRn a
819 failAt loc msg = addErrAt loc msg >> failM
820
821 addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
822 -- addErrAt is mainly (exclusively?) used by the renamer, where
823 -- tidying is not an issue, but it's all lazy so the extra
824 -- work doesn't matter
825 addErrAt loc msg = do { ctxt <- getErrCtxt
826 ; tidy_env <- tcInitTidyEnv
827 ; err_info <- mkErrInfo tidy_env ctxt
828 ; addLongErrAt loc msg err_info }
829
830 addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()
831 addErrs msgs = mapM_ add msgs
832 where
833 add (loc,msg) = addErrAt loc msg
834
835 checkErr :: Bool -> MsgDoc -> TcRn ()
836 -- Add the error if the bool is False
837 checkErr ok msg = unless ok (addErr msg)
838
839 addMessages :: Messages -> TcRn ()
840 addMessages msgs1
841 = do { errs_var <- getErrsVar ;
842 msgs0 <- readTcRef errs_var ;
843 writeTcRef errs_var (unionMessages msgs0 msgs1) }
844
845 discardWarnings :: TcRn a -> TcRn a
846 -- Ignore warnings inside the thing inside;
847 -- used to ignore-unused-variable warnings inside derived code
848 discardWarnings thing_inside
849 = do { errs_var <- getErrsVar
850 ; (old_warns, _) <- readTcRef errs_var
851
852 ; result <- thing_inside
853
854 -- Revert warnings to old_warns
855 ; (_new_warns, new_errs) <- readTcRef errs_var
856 ; writeTcRef errs_var (old_warns, new_errs)
857
858 ; return result }
859
860 {-
861 ************************************************************************
862 * *
863 Shared error message stuff: renamer and typechecker
864 * *
865 ************************************************************************
866 -}
867
868 mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
869 mkLongErrAt loc msg extra
870 = do { dflags <- getDynFlags ;
871 printer <- getPrintUnqualified dflags ;
872 return $ mkLongErrMsg dflags loc printer msg extra }
873
874 mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg
875 mkErrDocAt loc errDoc
876 = do { dflags <- getDynFlags ;
877 printer <- getPrintUnqualified dflags ;
878 return $ mkErrDoc dflags loc printer errDoc }
879
880 addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
881 addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
882
883 reportErrors :: [ErrMsg] -> TcM ()
884 reportErrors = mapM_ reportError
885
886 reportError :: ErrMsg -> TcRn ()
887 reportError err
888 = do { traceTc "Adding error:" (pprLocErrMsg err) ;
889 errs_var <- getErrsVar ;
890 (warns, errs) <- readTcRef errs_var ;
891 writeTcRef errs_var (warns, errs `snocBag` err) }
892
893 reportWarning :: WarnReason -> ErrMsg -> TcRn ()
894 reportWarning reason err
895 = do { let warn = makeIntoWarning reason err
896 -- 'err' was built by mkLongErrMsg or something like that,
897 -- so it's of error severity. For a warning we downgrade
898 -- its severity to SevWarning
899
900 ; traceTc "Adding warning:" (pprLocErrMsg warn)
901 ; errs_var <- getErrsVar
902 ; (warns, errs) <- readTcRef errs_var
903 ; writeTcRef errs_var (warns `snocBag` warn, errs) }
904
905 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
906 -- Does tryM, with a debug-trace on failure
907 try_m thing
908 = do { mb_r <- tryM thing ;
909 case mb_r of
910 Left exn -> do { traceTc "tryTc/recoverM recovering from" $
911 text (showException exn)
912 ; return mb_r }
913 Right _ -> return mb_r }
914
915 -----------------------
916 recoverM :: TcRn r -- Recovery action; do this if the main one fails
917 -> TcRn r -- Main action: do this first
918 -> TcRn r
919 -- Errors in 'thing' are retained
920 recoverM recover thing
921 = do { mb_res <- try_m thing ;
922 case mb_res of
923 Left _ -> recover
924 Right res -> return res }
925
926
927 -----------------------
928 mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
929 -- Drop elements of the input that fail, so the result
930 -- list can be shorter than the argument list
931 mapAndRecoverM _ [] = return []
932 mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
933 ; rs <- mapAndRecoverM f xs
934 ; return (case mb_r of
935 Left _ -> rs
936 Right r -> r:rs) }
937
938 -- | Succeeds if applying the argument to all members of the lists succeeds,
939 -- but nevertheless runs it on all arguments, to collect all errors.
940 mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
941 mapAndReportM f xs = checkNoErrs (mapAndRecoverM f xs)
942
943 -----------------------
944 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
945 -- (tryTc m) executes m, and returns
946 -- Just r, if m succeeds (returning r)
947 -- Nothing, if m fails
948 -- It also returns all the errors and warnings accumulated by m
949 -- It always succeeds (never raises an exception)
950 tryTc m
951 = do { errs_var <- newTcRef emptyMessages ;
952 res <- try_m (setErrsVar errs_var m) ;
953 msgs <- readTcRef errs_var ;
954 return (msgs, case res of
955 Left _ -> Nothing
956 Right val -> Just val)
957 -- The exception is always the IOEnv built-in
958 -- in exception; see IOEnv.failM
959 }
960
961 -- (askNoErrs m) runs m
962 -- If m fails, (askNoErrs m) fails
963 -- If m succeeds with result r, (askNoErrs m) succeeds with result (r, b),
964 -- where b is True iff m generated no errors
965 -- Regardless of success or failure, any errors generated by m are propagated
966 askNoErrs :: TcRn a -> TcRn (a, Bool)
967 askNoErrs m
968 = do { errs_var <- newTcRef emptyMessages
969 ; res <- setErrsVar errs_var m
970 ; (warns, errs) <- readTcRef errs_var
971 ; addMessages (warns, errs)
972 ; return (res, isEmptyBag errs) }
973
974 discardErrs :: TcRn a -> TcRn a
975 -- (discardErrs m) runs m,
976 -- discarding all error messages and warnings generated by m
977 -- If m fails, discardErrs fails, and vice versa
978 discardErrs m
979 = do { errs_var <- newTcRef emptyMessages
980 ; setErrsVar errs_var m }
981
982 -----------------------
983 tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
984 -- Run the thing, returning
985 -- Just r, if m succceeds with no error messages
986 -- Nothing, if m fails, or if it succeeds but has error messages
987 -- Either way, the messages are returned;
988 -- even in the Just case there might be warnings
989 tryTcErrs thing
990 = do { (msgs, res) <- tryTc thing
991 ; dflags <- getDynFlags
992 ; let errs_found = errorsFound dflags msgs
993 ; return (msgs, case res of
994 Nothing -> Nothing
995 Just val | errs_found -> Nothing
996 | otherwise -> Just val)
997 }
998
999 -----------------------
1000 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
1001 -- Just like tryTcErrs, except that it ensures that the LIE
1002 -- for the thing is propagated only if there are no errors
1003 -- Hence it's restricted to the type-check monad
1004 tryTcLIE thing_inside
1005 = do { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
1006 ; case mb_res of
1007 Nothing -> return (msgs, Nothing)
1008 Just val -> do { emitConstraints lie; return (msgs, Just val) }
1009 }
1010
1011 -----------------------
1012 tryTcLIE_ :: TcM r -> TcM r -> TcM r
1013 -- (tryTcLIE_ r m) tries m;
1014 -- if m succeeds with no error messages, it's the answer
1015 -- otherwise tryTcLIE_ drops everything from m and tries r instead.
1016 tryTcLIE_ recover main
1017 = do { (msgs, mb_res) <- tryTcLIE main
1018 ; case mb_res of
1019 Just val -> do { addMessages msgs -- There might be warnings
1020 ; return val }
1021 Nothing -> recover -- Discard all msgs
1022 }
1023
1024 -----------------------
1025 checkNoErrs :: TcM r -> TcM r
1026 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
1027 -- If m fails then (checkNoErrsTc m) fails.
1028 -- If m succeeds, it checks whether m generated any errors messages
1029 -- (it might have recovered internally)
1030 -- If so, it fails too.
1031 -- Regardless, any errors generated by m are propagated to the enclosing context.
1032 checkNoErrs main
1033 = do { (msgs, mb_res) <- tryTcLIE main
1034 ; addMessages msgs
1035 ; case mb_res of
1036 Nothing -> failM
1037 Just val -> return val
1038 }
1039
1040 whenNoErrs :: TcM () -> TcM ()
1041 whenNoErrs thing = ifErrsM (return ()) thing
1042
1043 ifErrsM :: TcRn r -> TcRn r -> TcRn r
1044 -- ifErrsM bale_out normal
1045 -- does 'bale_out' if there are errors in errors collection
1046 -- otherwise does 'normal'
1047 ifErrsM bale_out normal
1048 = do { errs_var <- getErrsVar ;
1049 msgs <- readTcRef errs_var ;
1050 dflags <- getDynFlags ;
1051 if errorsFound dflags msgs then
1052 bale_out
1053 else
1054 normal }
1055
1056 failIfErrsM :: TcRn ()
1057 -- Useful to avoid error cascades
1058 failIfErrsM = ifErrsM failM (return ())
1059
1060 #ifdef GHCI
1061 checkTH :: a -> String -> TcRn ()
1062 checkTH _ _ = return () -- OK
1063 #else
1064 checkTH :: Outputable a => a -> String -> TcRn ()
1065 checkTH e what = failTH e what -- Raise an error in a stage-1 compiler
1066 #endif
1067
1068 failTH :: Outputable a => a -> String -> TcRn x
1069 failTH e what -- Raise an error in a stage-1 compiler
1070 = failWithTc (vcat [ hang (char 'A' <+> text what
1071 <+> text "requires GHC with interpreter support:")
1072 2 (ppr e)
1073 , text "Perhaps you are using a stage-1 compiler?" ])
1074
1075 {-
1076 ************************************************************************
1077 * *
1078 Context management for the type checker
1079 * *
1080 ************************************************************************
1081 -}
1082
1083 getErrCtxt :: TcM [ErrCtxt]
1084 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
1085
1086 setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
1087 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
1088
1089 -- | Add a fixed message to the error context. This message should not
1090 -- do any tidying.
1091 addErrCtxt :: MsgDoc -> TcM a -> TcM a
1092 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
1093
1094 -- | Add a message to the error context. This message may do tidying.
1095 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
1096 addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
1097
1098 -- | Add a fixed landmark message to the error context. A landmark
1099 -- message is always sure to be reported, even if there is a lot of
1100 -- context. It also doesn't count toward the maximum number of contexts
1101 -- reported.
1102 addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
1103 addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
1104
1105 -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
1106 -- and tidying.
1107 addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
1108 addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts)
1109
1110 -- Helper function for the above
1111 updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
1112 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
1113 env { tcl_ctxt = upd ctxt })
1114
1115 popErrCtxt :: TcM a -> TcM a
1116 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
1117
1118 getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
1119 getCtLocM origin t_or_k
1120 = do { env <- getLclEnv
1121 ; return (CtLoc { ctl_origin = origin
1122 , ctl_env = env
1123 , ctl_t_or_k = t_or_k
1124 , ctl_depth = initialSubGoalDepth }) }
1125
1126 setCtLocM :: CtLoc -> TcM a -> TcM a
1127 -- Set the SrcSpan and error context from the CtLoc
1128 setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
1129 = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
1130 , tcl_bndrs = tcl_bndrs lcl
1131 , tcl_ctxt = tcl_ctxt lcl })
1132 thing_inside
1133
1134 {-
1135 ************************************************************************
1136 * *
1137 Error message generation (type checker)
1138 * *
1139 ************************************************************************
1140
1141 The addErrTc functions add an error message, but do not cause failure.
1142 The 'M' variants pass a TidyEnv that has already been used to
1143 tidy up the message; we then use it to tidy the context messages
1144 -}
1145
1146 addErrTc :: MsgDoc -> TcM ()
1147 addErrTc err_msg = do { env0 <- tcInitTidyEnv
1148 ; addErrTcM (env0, err_msg) }
1149
1150 addErrsTc :: [MsgDoc] -> TcM ()
1151 addErrsTc err_msgs = mapM_ addErrTc err_msgs
1152
1153 addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()
1154 addErrTcM (tidy_env, err_msg)
1155 = do { ctxt <- getErrCtxt ;
1156 loc <- getSrcSpanM ;
1157 add_err_tcm tidy_env err_msg loc ctxt }
1158
1159 -- Return the error message, instead of reporting it straight away
1160 mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg
1161 mkErrTcM (tidy_env, err_msg)
1162 = do { ctxt <- getErrCtxt ;
1163 loc <- getSrcSpanM ;
1164 err_info <- mkErrInfo tidy_env ctxt ;
1165 mkLongErrAt loc err_msg err_info }
1166
1167 -- The failWith functions add an error message and cause failure
1168
1169 failWithTc :: MsgDoc -> TcM a -- Add an error message and fail
1170 failWithTc err_msg
1171 = addErrTc err_msg >> failM
1172
1173 failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail
1174 failWithTcM local_and_msg
1175 = addErrTcM local_and_msg >> failM
1176
1177 checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true
1178 checkTc True _ = return ()
1179 checkTc False err = failWithTc err
1180
1181 checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
1182 checkTcM True _ = return ()
1183 checkTcM False err = failWithTcM err
1184
1185 failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false
1186 failIfTc False _ = return ()
1187 failIfTc True err = failWithTc err
1188
1189 failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
1190 -- Check that the boolean is false
1191 failIfTcM False _ = return ()
1192 failIfTcM True err = failWithTcM err
1193
1194
1195 -- Warnings have no 'M' variant, nor failure
1196
1197 -- | Display a warning if a condition is met.
1198 -- and the warning is enabled
1199 warnIf :: WarnReason -> Bool -> MsgDoc -> TcRn ()
1200 warnIf reason is_bad msg
1201 = do { warn_on <- case reason of
1202 NoReason -> return True
1203 Reason warn_flag -> woptM warn_flag
1204 ; when (warn_on && is_bad) $
1205 addWarn reason msg }
1206
1207 -- | Display a warning if a condition is met.
1208 warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()
1209 warnTc reason warn_if_true warn_msg
1210 | warn_if_true = addWarnTc reason warn_msg
1211 | otherwise = return ()
1212
1213 -- | Display a warning if a condition is met.
1214 warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()
1215 warnTcM reason warn_if_true warn_msg
1216 | warn_if_true = addWarnTcM reason warn_msg
1217 | otherwise = return ()
1218
1219 -- | Display a warning in the current context.
1220 addWarnTc :: WarnReason -> MsgDoc -> TcM ()
1221 addWarnTc reason msg
1222 = do { env0 <- tcInitTidyEnv ;
1223 addWarnTcM reason (env0, msg) }
1224
1225 -- | Display a warning in a given context.
1226 addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()
1227 addWarnTcM reason (env0, msg)
1228 = do { ctxt <- getErrCtxt ;
1229 err_info <- mkErrInfo env0 ctxt ;
1230 add_warn reason msg err_info }
1231
1232 -- | Display a warning for the current source location.
1233 addWarn :: WarnReason -> MsgDoc -> TcRn ()
1234 addWarn reason msg = add_warn reason msg Outputable.empty
1235
1236 -- | Display a warning for a given source location.
1237 addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
1238 addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty
1239
1240 -- | Display a warning, with an optional flag, for the current source
1241 -- location.
1242 add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()
1243 add_warn reason msg extra_info
1244 = do { loc <- getSrcSpanM
1245 ; add_warn_at reason loc msg extra_info }
1246
1247 -- | Display a warning, with an optional flag, for a given location.
1248 add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
1249 add_warn_at reason loc msg extra_info
1250 = do { dflags <- getDynFlags ;
1251 printer <- getPrintUnqualified dflags ;
1252 let { warn = mkLongWarnMsg dflags loc printer
1253 msg extra_info } ;
1254 reportWarning reason warn }
1255
1256 tcInitTidyEnv :: TcM TidyEnv
1257 tcInitTidyEnv
1258 = do { lcl_env <- getLclEnv
1259 ; return (tcl_tidy lcl_env) }
1260
1261 -- | Get a 'TidyEnv' that includes mappings for all vars free in the given
1262 -- type. Useful when tidying open types.
1263 tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
1264 tcInitOpenTidyEnv tvs
1265 = do { env1 <- tcInitTidyEnv
1266 ; let env2 = tidyFreeTyCoVars env1 tvs
1267 ; return env2 }
1268
1269
1270 {-
1271 -----------------------------------
1272 Other helper functions
1273 -}
1274
1275 add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan
1276 -> [ErrCtxt]
1277 -> TcM ()
1278 add_err_tcm tidy_env err_msg loc ctxt
1279 = do { err_info <- mkErrInfo tidy_env ctxt ;
1280 addLongErrAt loc err_msg err_info }
1281
1282 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
1283 -- Tidy the error info, trimming excessive contexts
1284 mkErrInfo env ctxts
1285 -- | opt_PprStyle_Debug -- In -dppr-debug style the output
1286 -- = return empty -- just becomes too voluminous
1287 | otherwise
1288 = go 0 env ctxts
1289 where
1290 go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
1291 go _ _ [] = return empty
1292 go n env ((is_landmark, ctxt) : ctxts)
1293 | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug
1294 = do { (env', msg) <- ctxt env
1295 ; let n' = if is_landmark then n else n+1
1296 ; rest <- go n' env' ctxts
1297 ; return (msg $$ rest) }
1298 | otherwise
1299 = go n env ctxts
1300
1301 mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts
1302 mAX_CONTEXTS = 3
1303
1304 -- debugTc is useful for monadic debugging code
1305
1306 debugTc :: TcM () -> TcM ()
1307 debugTc thing
1308 | debugIsOn = thing
1309 | otherwise = return ()
1310
1311 {-
1312 ************************************************************************
1313 * *
1314 Type constraints
1315 * *
1316 ************************************************************************
1317 -}
1318
1319 newTcEvBinds :: TcM EvBindsVar
1320 newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
1321 ; uniq <- newUnique
1322 ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
1323 ; return (EvBindsVar ref uniq) }
1324
1325 addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
1326 -- Add a binding to the TcEvBinds by side effect
1327 addTcEvBind (EvBindsVar ev_ref u) ev_bind
1328 = do { traceTc "addTcEvBind" $ ppr u $$
1329 ppr ev_bind
1330 ; bnds <- readTcRef ev_ref
1331 ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
1332
1333 getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind)
1334 getTcEvBinds (EvBindsVar ev_ref _)
1335 = do { bnds <- readTcRef ev_ref
1336 ; return (evBindMapBinds bnds) }
1337
1338 getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
1339 getTcEvBindsMap (EvBindsVar ev_ref _)
1340 = readTcRef ev_ref
1341
1342 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
1343 chooseUniqueOccTc fn =
1344 do { env <- getGblEnv
1345 ; let dfun_n_var = tcg_dfun_n env
1346 ; set <- readTcRef dfun_n_var
1347 ; let occ = fn set
1348 ; writeTcRef dfun_n_var (extendOccSet set occ)
1349 ; return occ }
1350
1351 getConstraintVar :: TcM (TcRef WantedConstraints)
1352 getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
1353
1354 setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
1355 setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
1356
1357 emitConstraints :: WantedConstraints -> TcM ()
1358 emitConstraints ct
1359 = do { lie_var <- getConstraintVar ;
1360 updTcRef lie_var (`andWC` ct) }
1361
1362 emitSimple :: Ct -> TcM ()
1363 emitSimple ct
1364 = do { lie_var <- getConstraintVar ;
1365 updTcRef lie_var (`addSimples` unitBag ct) }
1366
1367 emitSimples :: Cts -> TcM ()
1368 emitSimples cts
1369 = do { lie_var <- getConstraintVar ;
1370 updTcRef lie_var (`addSimples` cts) }
1371
1372 emitImplication :: Implication -> TcM ()
1373 emitImplication ct
1374 = do { lie_var <- getConstraintVar ;
1375 updTcRef lie_var (`addImplics` unitBag ct) }
1376
1377 emitImplications :: Bag Implication -> TcM ()
1378 emitImplications ct
1379 = unless (isEmptyBag ct) $
1380 do { lie_var <- getConstraintVar ;
1381 updTcRef lie_var (`addImplics` ct) }
1382
1383 emitInsoluble :: Ct -> TcM ()
1384 emitInsoluble ct
1385 = do { lie_var <- getConstraintVar ;
1386 updTcRef lie_var (`addInsols` unitBag ct) ;
1387 v <- readTcRef lie_var ;
1388 traceTc "emitInsoluble" (ppr v) }
1389
1390 emitInsolubles :: [Ct] -> TcM ()
1391 emitInsolubles cts
1392 = do { lie_var <- getConstraintVar ;
1393 updTcRef lie_var (`addInsols` listToBag cts) ;
1394 v <- readTcRef lie_var ;
1395 traceTc "emitInsoluble" (ppr v) }
1396
1397 -- | Throw out any constraints emitted by the thing_inside
1398 discardConstraints :: TcM a -> TcM a
1399 discardConstraints thing_inside = fst <$> captureConstraints thing_inside
1400
1401 captureConstraints :: TcM a -> TcM (a, WantedConstraints)
1402 -- (captureConstraints m) runs m, and returns the type constraints it generates
1403 captureConstraints thing_inside
1404 = do { lie_var <- newTcRef emptyWC ;
1405 res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
1406 thing_inside ;
1407 lie <- readTcRef lie_var ;
1408 return (res, lie) }
1409
1410 pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
1411 pushLevelAndCaptureConstraints thing_inside
1412 = do { env <- getLclEnv
1413 ; lie_var <- newTcRef emptyWC
1414 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1415 ; res <- setLclEnv (env { tcl_tclvl = tclvl'
1416 , tcl_lie = lie_var })
1417 thing_inside
1418 ; lie <- readTcRef lie_var
1419 ; return (tclvl', lie, res) }
1420
1421 pushTcLevelM_ :: TcM a -> TcM a
1422 pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
1423
1424 pushTcLevelM :: TcM a -> TcM (a, TcLevel)
1425 -- See Note [TcLevel assignment]
1426 pushTcLevelM thing_inside
1427 = do { env <- getLclEnv
1428 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1429 ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
1430 thing_inside
1431 ; return (res, tclvl') }
1432
1433 getTcLevel :: TcM TcLevel
1434 getTcLevel = do { env <- getLclEnv
1435 ; return (tcl_tclvl env) }
1436
1437 setTcLevel :: TcLevel -> TcM a -> TcM a
1438 setTcLevel tclvl thing_inside
1439 = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
1440
1441 isTouchableTcM :: TcTyVar -> TcM Bool
1442 isTouchableTcM tv
1443 = do { env <- getLclEnv
1444 ; return (isTouchableMetaTyVar (tcl_tclvl env) tv) }
1445
1446 getLclTypeEnv :: TcM TcTypeEnv
1447 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
1448
1449 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
1450 -- Set the local type envt, but do *not* disturb other fields,
1451 -- notably the lie_var
1452 setLclTypeEnv lcl_env thing_inside
1453 = updLclEnv upd thing_inside
1454 where
1455 upd env = env { tcl_env = tcl_env lcl_env,
1456 tcl_tyvars = tcl_tyvars lcl_env }
1457
1458 traceTcConstraints :: String -> TcM ()
1459 traceTcConstraints msg
1460 = do { lie_var <- getConstraintVar
1461 ; lie <- readTcRef lie_var
1462 ; traceTc (msg ++ ": LIE:") (ppr lie)
1463 }
1464
1465 emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
1466 emitWildCardHoleConstraints wcs
1467 = do { ct_loc <- getCtLocM HoleOrigin Nothing
1468 ; emitInsolubles (map (do_one ct_loc) wcs) }
1469 where
1470 do_one :: CtLoc -> (Name, TcTyVar) -> Ct
1471 do_one ct_loc (name, tv)
1472 = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv
1473 , ctev_loc = ct_loc' }
1474 , cc_hole = TypeHole (occName name) }
1475 where
1476 real_span = case nameSrcSpan name of
1477 RealSrcSpan span -> span
1478 UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints"
1479 (ppr name <+> quotes (ftext str))
1480 -- Wildcards are defined locally, and so have RealSrcSpans
1481 ct_loc' = setCtLocSpan ct_loc real_span
1482
1483 {-
1484 ************************************************************************
1485 * *
1486 Template Haskell context
1487 * *
1488 ************************************************************************
1489 -}
1490
1491 recordThUse :: TcM ()
1492 recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
1493
1494 recordThSpliceUse :: TcM ()
1495 recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
1496
1497 -- | When generating an out-of-scope error message for a variable matching a
1498 -- binding in a later inter-splice group, the typechecker uses the splice
1499 -- locations to provide details in the message about the scope of that binding.
1500 recordTopLevelSpliceLoc :: SrcSpan -> TcM ()
1501 recordTopLevelSpliceLoc (RealSrcSpan real_loc)
1502 = do { env <- getGblEnv
1503 ; let locs_var = tcg_th_top_level_locs env
1504 ; locs0 <- readTcRef locs_var
1505 ; writeTcRef locs_var (Set.insert real_loc locs0) }
1506 recordTopLevelSpliceLoc (UnhelpfulSpan _) = return ()
1507
1508 getTopLevelSpliceLocs :: TcM (Set RealSrcSpan)
1509 getTopLevelSpliceLocs
1510 = do { env <- getGblEnv
1511 ; readTcRef (tcg_th_top_level_locs env) }
1512
1513 keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set
1514 keepAlive name
1515 = do { env <- getGblEnv
1516 ; traceRn (text "keep alive" <+> ppr name)
1517 ; updTcRef (tcg_keep env) (`extendNameSet` name) }
1518
1519 getStage :: TcM ThStage
1520 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
1521
1522 getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
1523 getStageAndBindLevel name
1524 = do { env <- getLclEnv;
1525 ; case lookupNameEnv (tcl_th_bndrs env) name of
1526 Nothing -> return Nothing
1527 Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
1528
1529 setStage :: ThStage -> TcM a -> TcRn a
1530 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
1531
1532 {-
1533 ************************************************************************
1534 * *
1535 Safe Haskell context
1536 * *
1537 ************************************************************************
1538 -}
1539
1540 -- | Mark that safe inference has failed
1541 -- See Note [Safe Haskell Overlapping Instances Implementation]
1542 -- although this is used for more than just that failure case.
1543 recordUnsafeInfer :: WarningMessages -> TcM ()
1544 recordUnsafeInfer warns =
1545 getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)
1546
1547 -- | Figure out the final correct safe haskell mode
1548 finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
1549 finalSafeMode dflags tcg_env = do
1550 safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)
1551 return $ case safeHaskell dflags of
1552 Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
1553 | otherwise -> Sf_None
1554 s -> s
1555
1556 -- | Switch instances to safe instances if we're in Safe mode.
1557 fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
1558 fixSafeInstances sfMode | sfMode /= Sf_Safe = id
1559 fixSafeInstances _ = map fixSafe
1560 where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
1561 in inst { is_flag = new_flag }
1562
1563 {-
1564 ************************************************************************
1565 * *
1566 Stuff for the renamer's local env
1567 * *
1568 ************************************************************************
1569 -}
1570
1571 getLocalRdrEnv :: RnM LocalRdrEnv
1572 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
1573
1574 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
1575 setLocalRdrEnv rdr_env thing_inside
1576 = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
1577
1578 {-
1579 ************************************************************************
1580 * *
1581 Stuff for interface decls
1582 * *
1583 ************************************************************************
1584 -}
1585
1586 mkIfLclEnv :: Module -> SDoc -> IfLclEnv
1587 mkIfLclEnv mod loc = IfLclEnv { if_mod = mod,
1588 if_loc = loc,
1589 if_tv_env = emptyFsEnv,
1590 if_id_env = emptyFsEnv }
1591
1592 -- | Run an 'IfG' (top-level interface monad) computation inside an existing
1593 -- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
1594 -- based on 'TcGblEnv'.
1595 initIfaceTcRn :: IfG a -> TcRn a
1596 initIfaceTcRn thing_inside
1597 = do { tcg_env <- getGblEnv
1598 ; let { if_env = IfGblEnv {
1599 if_doc = text "initIfaceTcRn",
1600 if_rec_types = Just (tcg_mod tcg_env, get_type_env)
1601 }
1602 ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
1603 ; setEnvs (if_env, ()) thing_inside }
1604
1605 initIfaceCheck :: HscEnv -> IfG a -> IO a
1606 -- Used when checking the up-to-date-ness of the old Iface
1607 -- Initialise the environment with no useful info at all
1608 initIfaceCheck hsc_env do_this
1609 = do let rec_types = case hsc_type_env_var hsc_env of
1610 Just (mod,var) -> Just (mod, readTcRef var)
1611 Nothing -> Nothing
1612 gbl_env = IfGblEnv {
1613 if_doc = text "initIfaceCheck",
1614 if_rec_types = rec_types
1615 }
1616 initTcRnIf 'i' hsc_env gbl_env () do_this
1617
1618 initIfaceTc :: ModIface
1619 -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
1620 -- Used when type-checking checking an up-to-date interface file
1621 -- No type envt from the current module, but we do know the module dependencies
1622 initIfaceTc iface do_this
1623 = do { tc_env_var <- newTcRef emptyTypeEnv
1624 ; let { gbl_env = IfGblEnv {
1625 if_doc = text "initIfaceTc",
1626 if_rec_types = Just (mod, readTcRef tc_env_var)
1627 } ;
1628 ; if_lenv = mkIfLclEnv mod doc
1629 }
1630 ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
1631 }
1632 where
1633 mod = mi_module iface
1634 doc = text "The interface for" <+> quotes (ppr mod)
1635
1636 initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
1637 initIfaceLcl mod loc_doc thing_inside
1638 = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
1639
1640 getIfModule :: IfL Module
1641 getIfModule = do { env <- getLclEnv; return (if_mod env) }
1642
1643 --------------------
1644 failIfM :: MsgDoc -> IfL a
1645 -- The Iface monad doesn't have a place to accumulate errors, so we
1646 -- just fall over fast if one happens; it "shouldnt happen".
1647 -- We use IfL here so that we can get context info out of the local env
1648 failIfM msg
1649 = do { env <- getLclEnv
1650 ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1651 ; dflags <- getDynFlags
1652 ; liftIO (log_action dflags dflags NoReason SevFatal
1653 noSrcSpan (defaultErrStyle dflags) full_msg)
1654 ; failM }
1655
1656 --------------------
1657 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1658 -- Run thing_inside in an interleaved thread.
1659 -- It shares everything with the parent thread, so this is DANGEROUS.
1660 --
1661 -- It returns Nothing if the computation fails
1662 --
1663 -- It's used for lazily type-checking interface
1664 -- signatures, which is pretty benign
1665
1666 forkM_maybe doc thing_inside
1667 -- NB: Don't share the mutable env_us with the interleaved thread since env_us
1668 -- does not get updated atomically (e.g. in newUnique and newUniqueSupply).
1669 = do { child_us <- newUniqueSupply
1670 ; child_env_us <- newMutVar child_us
1671 -- see Note [Masking exceptions in forkM_maybe]
1672 ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $
1673 do { traceIf (text "Starting fork {" <+> doc)
1674 ; mb_res <- tryM $
1675 updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1676 thing_inside
1677 ; case mb_res of
1678 Right r -> do { traceIf (text "} ending fork" <+> doc)
1679 ; return (Just r) }
1680 Left exn -> do {
1681
1682 -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1683 -- Otherwise we silently discard errors. Errors can legitimately
1684 -- happen when compiling interface signatures (see tcInterfaceSigs)
1685 whenDOptM Opt_D_dump_if_trace $ do
1686 dflags <- getDynFlags
1687 let msg = hang (text "forkM failed:" <+> doc)
1688 2 (text (show exn))
1689 liftIO $ log_action dflags
1690 dflags
1691 NoReason
1692 SevFatal
1693 noSrcSpan
1694 (defaultErrStyle dflags)
1695 msg
1696
1697 ; traceIf (text "} ending fork (badly)" <+> doc)
1698 ; return Nothing }
1699 }}
1700
1701 forkM :: SDoc -> IfL a -> IfL a
1702 forkM doc thing_inside
1703 = do { mb_res <- forkM_maybe doc thing_inside
1704 ; return (case mb_res of
1705 Nothing -> pgmError "Cannot continue after interface file error"
1706 -- pprPanic "forkM" doc
1707 Just r -> r) }
1708
1709 {-
1710 Note [Masking exceptions in forkM_maybe]
1711 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1712
1713 When using GHC-as-API it must be possible to interrupt snippets of code
1714 executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
1715 by throwing an asynchronous interrupt to the GHC thread. However, there is a
1716 subtle problem: runStmt first typechecks the code before running it, and the
1717 exception might interrupt the type checker rather than the code. Moreover, the
1718 typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
1719 more importantly might be inside an exception handler inside that
1720 unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
1721 asynchronous exception as a synchronous exception, and the exception will end
1722 up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
1723 discussion). We don't currently know a general solution to this problem, but
1724 we can use uninterruptibleMask_ to avoid the situation.
1725 -}