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