never executed always true always false
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE ExplicitForAll #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE RecordWildCards #-}
5
6 {-# OPTIONS_GHC -fno-warn-orphans #-}
7 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
8
9 {-
10 (c) The University of Glasgow 2006
11
12 -}
13
14 -- | Functions for working with the typechecker environment (setters,
15 -- getters...).
16 module GHC.Tc.Utils.Monad(
17 -- * Initialisation
18 initTc, initTcWithGbl, initTcInteractive, initTcRnIf,
19
20 -- * Simple accessors
21 discardResult,
22 getTopEnv, updTopEnv, getGblEnv, updGblEnv,
23 setGblEnv, getLclEnv, updLclEnv, setLclEnv,
24 updTopFlags,
25 getEnvs, setEnvs,
26 xoptM, doptM, goptM, woptM,
27 setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,
28 whenDOptM, whenGOptM, whenWOptM,
29 whenXOptM, unlessXOptM,
30 getGhcMode,
31 withoutDynamicNow,
32 getEpsVar,
33 getEps,
34 updateEps, updateEps_,
35 getHpt, getEpsAndHpt,
36
37 -- * Arrow scopes
38 newArrowScope, escapeArrowScope,
39
40 -- * Unique supply
41 newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName,
42 newSysName, newSysLocalId, newSysLocalIds,
43
44 -- * Accessing input/output
45 newTcRef, readTcRef, writeTcRef, updTcRef,
46
47 -- * Debugging
48 traceTc, traceRn, traceOptTcRn, dumpOptTcRn,
49 dumpTcRn,
50 getPrintUnqualified,
51 printForUserTcRn,
52 traceIf, traceOptIf,
53 debugTc,
54
55 -- * Typechecker global environment
56 getIsGHCi, getGHCiMonad, getInteractivePrintName,
57 tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv,
58 getRdrEnvs, getImports,
59 getFixityEnv, extendFixityEnv, getRecFieldEnv,
60 getDeclaredDefaultTys,
61 addDependentFiles, getMnwib,
62
63 -- * Error management
64 getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, inGeneratedCode,
65 wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
66 wrapLocMA_,wrapLocMA,
67 getErrsVar, setErrsVar,
68 addErr,
69 failWith, failAt,
70 addErrAt, addErrs,
71 checkErr,
72 addMessages,
73 discardWarnings,
74
75 -- * Usage environment
76 tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,
77
78 -- * Shared error message stuff: renamer and typechecker
79 recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
80 attemptM, tryTc,
81 askNoErrs, discardErrs, tryTcDiscardingErrs,
82 checkNoErrs, whenNoErrs,
83 ifErrsM, failIfErrsM,
84
85 -- * Context management for the type checker
86 getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
87 addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM,
88
89 -- * Diagnostic message generation (type checker)
90 addErrTc,
91 addErrTcM,
92 failWithTc, failWithTcM,
93 checkTc, checkTcM,
94 failIfTc, failIfTcM,
95 mkErrInfo,
96 addTcRnDiagnostic, addDetailedDiagnostic,
97 mkTcRnMessage, reportDiagnostic, reportDiagnostics,
98 warnIf, diagnosticTc, diagnosticTcM,
99 addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt,
100
101 -- * Type constraints
102 newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,
103 addTcEvBind, addTopEvBinds,
104 getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
105 chooseUniqueOccTc,
106 getConstraintVar, setConstraintVar,
107 emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
108 emitImplication, emitImplications, emitInsoluble,
109 emitHole, emitHoles,
110 discardConstraints, captureConstraints, tryCaptureConstraints,
111 pushLevelAndCaptureConstraints,
112 pushTcLevelM_, pushTcLevelM, pushTcLevelsM,
113 getTcLevel, setTcLevel, isTouchableTcM,
114 getLclTypeEnv, setLclTypeEnv,
115 traceTcConstraints,
116 emitNamedTypeHole, IsExtraConstraint(..), emitAnonTypeHole,
117
118 -- * Template Haskell context
119 recordThUse, recordThSpliceUse,
120 keepAlive, getStage, getStageAndBindLevel, setStage,
121 addModFinalizersWithLclEnv,
122
123 -- * Safe Haskell context
124 recordUnsafeInfer, finalSafeMode, fixSafeInstances,
125
126 -- * Stuff for the renamer's local env
127 getLocalRdrEnv, setLocalRdrEnv,
128
129 -- * Stuff for interface decls
130 mkIfLclEnv,
131 initIfaceTcRn,
132 initIfaceCheck,
133 initIfaceLcl,
134 initIfaceLclWithSubst,
135 initIfaceLoad,
136 initIfaceLoadModule,
137 getIfModule,
138 failIfM,
139 forkM_maybe,
140 forkM,
141 setImplicitEnvM,
142
143 withException,
144
145 -- * Stuff for cost centres.
146 getCCIndexM, getCCIndexTcM,
147
148 -- * Types etc.
149 module GHC.Tc.Types,
150 module GHC.Data.IOEnv
151 ) where
152
153 import GHC.Prelude
154
155
156 import GHC.Builtin.Names
157
158 import GHC.Tc.Types -- Re-export all
159 import GHC.Tc.Types.Constraint
160 import GHC.Tc.Types.Evidence
161 import GHC.Tc.Types.Origin
162 import GHC.Tc.Utils.TcType
163
164 import GHC.Hs hiding (LIE)
165
166 import GHC.Unit
167 import GHC.Unit.Env
168 import GHC.Unit.External
169 import GHC.Unit.Module.Warnings
170 import GHC.Unit.Home.ModInfo
171
172 import GHC.Core.UsageEnv
173 import GHC.Core.Multiplicity
174 import GHC.Core.InstEnv
175 import GHC.Core.FamInstEnv
176
177 import GHC.Driver.Env
178 import GHC.Driver.Session
179 import GHC.Driver.Config.Diagnostic
180
181 import GHC.Runtime.Context
182
183 import GHC.Data.IOEnv -- Re-export all
184 import GHC.Data.Bag
185 import GHC.Data.FastString
186 import GHC.Data.Maybe
187
188 import GHC.Utils.Outputable as Outputable
189 import GHC.Utils.Error
190 import GHC.Utils.Panic
191 import GHC.Utils.Constants (debugIsOn)
192 import GHC.Utils.Misc
193 import GHC.Utils.Logger
194 import qualified GHC.Data.Strict as Strict
195
196 import GHC.Types.Error
197 import GHC.Types.Fixity.Env
198 import GHC.Types.Name.Reader
199 import GHC.Types.Name
200 import GHC.Types.SafeHaskell
201 import GHC.Types.Id
202 import GHC.Types.TypeEnv
203 import GHC.Types.Var.Set
204 import GHC.Types.Var.Env
205 import GHC.Types.SrcLoc
206 import GHC.Types.Name.Env
207 import GHC.Types.Name.Set
208 import GHC.Types.Name.Ppr
209 import GHC.Types.Unique.FM ( emptyUFM )
210 import GHC.Types.Unique.Supply
211 import GHC.Types.Annotations
212 import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) )
213 import GHC.Types.CostCentre.State
214 import GHC.Types.SourceFile
215
216 import qualified GHC.LanguageExtensions as LangExt
217
218 import Data.IORef
219 import Control.Monad
220
221 import GHC.Tc.Errors.Types
222 import {-# SOURCE #-} GHC.Tc.Utils.Env ( tcInitTidyEnv )
223
224 import qualified Data.Map as Map
225 import GHC.Driver.Env.KnotVars
226
227 {-
228 ************************************************************************
229 * *
230 initTc
231 * *
232 ************************************************************************
233 -}
234
235 -- | Setup the initial typechecking environment
236 initTc :: HscEnv
237 -> HscSource
238 -> Bool -- True <=> retain renamed syntax trees
239 -> Module
240 -> RealSrcSpan
241 -> TcM r
242 -> IO (Messages TcRnMessage, Maybe r)
243 -- Nothing => error thrown by the thing inside
244 -- (error messages should have been printed already)
245
246 initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
247 = do { keep_var <- newIORef emptyNameSet ;
248 used_gre_var <- newIORef [] ;
249 th_var <- newIORef False ;
250 th_splice_var<- newIORef False ;
251 infer_var <- newIORef True ;
252 infer_reasons_var <- newIORef emptyMessages ;
253 dfun_n_var <- newIORef emptyOccSet ;
254 let { type_env_var = hsc_type_env_vars hsc_env };
255
256 dependent_files_var <- newIORef [] ;
257 static_wc_var <- newIORef emptyWC ;
258 cc_st_var <- newIORef newCostCentreState ;
259 th_topdecls_var <- newIORef [] ;
260 th_foreign_files_var <- newIORef [] ;
261 th_topnames_var <- newIORef emptyNameSet ;
262 th_modfinalizers_var <- newIORef [] ;
263 th_coreplugins_var <- newIORef [] ;
264 th_state_var <- newIORef Map.empty ;
265 th_remote_state_var <- newIORef Nothing ;
266 th_docs_var <- newIORef Map.empty ;
267 next_wrapper_num <- newIORef emptyModuleEnv ;
268 let {
269 -- bangs to avoid leaking the env (#19356)
270 !dflags = hsc_dflags hsc_env ;
271 !home_unit = hsc_home_unit hsc_env ;
272 !logger = hsc_logger hsc_env ;
273
274 maybe_rn_syntax :: forall a. a -> Maybe a ;
275 maybe_rn_syntax empty_val
276 | logHasDumpFlag logger Opt_D_dump_rn_ast = Just empty_val
277
278 | gopt Opt_WriteHie dflags = Just empty_val
279
280 -- We want to serialize the documentation in the .hi-files,
281 -- and need to extract it from the renamed syntax first.
282 -- See 'GHC.HsToCore.Docs.extractDocs'.
283 | gopt Opt_Haddock dflags = Just empty_val
284
285 | keep_rn_syntax = Just empty_val
286 | otherwise = Nothing ;
287
288 gbl_env = TcGblEnv {
289 tcg_th_topdecls = th_topdecls_var,
290 tcg_th_foreign_files = th_foreign_files_var,
291 tcg_th_topnames = th_topnames_var,
292 tcg_th_modfinalizers = th_modfinalizers_var,
293 tcg_th_coreplugins = th_coreplugins_var,
294 tcg_th_state = th_state_var,
295 tcg_th_remote_state = th_remote_state_var,
296 tcg_th_docs = th_docs_var,
297
298 tcg_mod = mod,
299 tcg_semantic_mod = homeModuleInstantiation home_unit mod,
300 tcg_src = hsc_src,
301 tcg_rdr_env = emptyGlobalRdrEnv,
302 tcg_fix_env = emptyNameEnv,
303 tcg_field_env = emptyNameEnv,
304 tcg_default = if moduleUnit mod == primUnit
305 || moduleUnit mod == bignumUnit
306 then Just [] -- See Note [Default types]
307 else Nothing,
308 tcg_type_env = emptyNameEnv,
309 tcg_type_env_var = type_env_var,
310 tcg_inst_env = emptyInstEnv,
311 tcg_fam_inst_env = emptyFamInstEnv,
312 tcg_ann_env = emptyAnnEnv,
313 tcg_th_used = th_var,
314 tcg_th_splice_used = th_splice_var,
315 tcg_exports = [],
316 tcg_imports = emptyImportAvails,
317 tcg_used_gres = used_gre_var,
318 tcg_dus = emptyDUs,
319
320 tcg_rn_imports = [],
321 tcg_rn_exports =
322 if hsc_src == HsigFile
323 -- Always retain renamed syntax, so that we can give
324 -- better errors. (TODO: how?)
325 then Just []
326 else maybe_rn_syntax [],
327 tcg_rn_decls = maybe_rn_syntax emptyRnGroup,
328 tcg_tr_module = Nothing,
329 tcg_binds = emptyLHsBinds,
330 tcg_imp_specs = [],
331 tcg_sigs = emptyNameSet,
332 tcg_ksigs = emptyNameSet,
333 tcg_ev_binds = emptyBag,
334 tcg_warns = NoWarnings,
335 tcg_anns = [],
336 tcg_tcs = [],
337 tcg_insts = [],
338 tcg_fam_insts = [],
339 tcg_rules = [],
340 tcg_fords = [],
341 tcg_patsyns = [],
342 tcg_merged = [],
343 tcg_dfun_n = dfun_n_var,
344 tcg_keep = keep_var,
345 tcg_doc_hdr = Nothing,
346 tcg_hpc = False,
347 tcg_main = Nothing,
348 tcg_self_boot = NoSelfBoot,
349 tcg_safe_infer = infer_var,
350 tcg_safe_infer_reasons = infer_reasons_var,
351 tcg_dependent_files = dependent_files_var,
352 tcg_tc_plugin_solvers = [],
353 tcg_tc_plugin_rewriters = emptyUFM,
354 tcg_defaulting_plugins = [],
355 tcg_hf_plugins = [],
356 tcg_top_loc = loc,
357 tcg_static_wc = static_wc_var,
358 tcg_complete_matches = [],
359 tcg_cc_st = cc_st_var,
360 tcg_next_wrapper_num = next_wrapper_num
361 } ;
362 } ;
363
364 -- OK, here's the business end!
365 initTcWithGbl hsc_env gbl_env loc do_this
366 }
367
368 -- | Run a 'TcM' action in the context of an existing 'GblEnv'.
369 initTcWithGbl :: HscEnv
370 -> TcGblEnv
371 -> RealSrcSpan
372 -> TcM r
373 -> IO (Messages TcRnMessage, Maybe r)
374 initTcWithGbl hsc_env gbl_env loc do_this
375 = do { lie_var <- newIORef emptyWC
376 ; errs_var <- newIORef emptyMessages
377 ; usage_var <- newIORef zeroUE
378 ; let lcl_env = TcLclEnv {
379 tcl_errs = errs_var,
380 tcl_loc = loc,
381 -- tcl_loc should be over-ridden very soon!
382 tcl_in_gen_code = False,
383 tcl_ctxt = [],
384 tcl_rdr = emptyLocalRdrEnv,
385 tcl_th_ctxt = topStage,
386 tcl_th_bndrs = emptyNameEnv,
387 tcl_arrow_ctxt = NoArrowCtxt,
388 tcl_env = emptyNameEnv,
389 tcl_usage = usage_var,
390 tcl_bndrs = [],
391 tcl_lie = lie_var,
392 tcl_tclvl = topTcLevel
393 }
394
395 ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
396 do { r <- tryM do_this
397 ; case r of
398 Right res -> return (Just res)
399 Left _ -> return Nothing }
400
401 -- Check for unsolved constraints
402 -- If we succeed (maybe_res = Just r), there should be
403 -- no unsolved constraints. But if we exit via an
404 -- exception (maybe_res = Nothing), we may have skipped
405 -- solving, so don't panic then (#13466)
406 ; lie <- readIORef (tcl_lie lcl_env)
407 ; when (isJust maybe_res && not (isEmptyWC lie)) $
408 pprPanic "initTc: unsolved constraints" (ppr lie)
409
410 -- Collect any error messages
411 ; msgs <- readIORef (tcl_errs lcl_env)
412
413 ; let { final_res | errorsFound msgs = Nothing
414 | otherwise = maybe_res }
415
416 ; return (msgs, final_res)
417 }
418
419 initTcInteractive :: HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
420 -- Initialise the type checker monad for use in GHCi
421 initTcInteractive hsc_env thing_inside
422 = initTc hsc_env HsSrcFile False
423 (icInteractiveModule (hsc_IC hsc_env))
424 (realSrcLocSpan interactive_src_loc)
425 thing_inside
426 where
427 interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
428
429 {- Note [Default types]
430 ~~~~~~~~~~~~~~~~~~~~~~~
431 The Integer type is simply not available in ghc-prim and ghc-bignum packages (it
432 is declared in ghc-bignum). So we set the defaulting types to (Just []), meaning
433 there are no default types, rather than Nothing, which means "use the default
434 default types of Integer, Double".
435
436 If you don't do this, attempted defaulting in package ghc-prim causes
437 an actual crash (attempting to look up the Integer type).
438
439
440 ************************************************************************
441 * *
442 Initialisation
443 * *
444 ************************************************************************
445 -}
446
447 initTcRnIf :: Char -- ^ Mask for unique supply
448 -> HscEnv
449 -> gbl -> lcl
450 -> TcRnIf gbl lcl a
451 -> IO a
452 initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside
453 = do { let { env = Env { env_top = hsc_env,
454 env_um = uniq_mask,
455 env_gbl = gbl_env,
456 env_lcl = lcl_env} }
457
458 ; runIOEnv env thing_inside
459 }
460
461 {-
462 ************************************************************************
463 * *
464 Simple accessors
465 * *
466 ************************************************************************
467 -}
468
469 discardResult :: TcM a -> TcM ()
470 discardResult a = a >> return ()
471
472 getTopEnv :: TcRnIf gbl lcl HscEnv
473 getTopEnv = do { env <- getEnv; return (env_top env) }
474
475 updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
476 updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->
477 env { env_top = upd top })
478
479 getGblEnv :: TcRnIf gbl lcl gbl
480 getGblEnv = do { Env{..} <- getEnv; return env_gbl }
481
482 updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
483 updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
484 env { env_gbl = upd gbl })
485
486 setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
487 setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
488
489 getLclEnv :: TcRnIf gbl lcl lcl
490 getLclEnv = do { Env{..} <- getEnv; return env_lcl }
491
492 updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
493 updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
494 env { env_lcl = upd lcl })
495
496 setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
497 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
498
499 getEnvs :: TcRnIf gbl lcl (gbl, lcl)
500 getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
501
502 setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
503 setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
504
505 -- Command-line flags
506
507 xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool
508 xoptM flag = xopt flag <$> getDynFlags
509
510 doptM :: DumpFlag -> TcRnIf gbl lcl Bool
511 doptM flag = do
512 logger <- getLogger
513 return (logHasDumpFlag logger flag)
514
515 goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
516 goptM flag = gopt flag <$> getDynFlags
517
518 woptM :: WarningFlag -> TcRnIf gbl lcl Bool
519 woptM flag = wopt flag <$> getDynFlags
520
521 setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
522 setXOptM flag = updTopFlags (\dflags -> xopt_set dflags flag)
523
524 unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
525 unsetXOptM flag = updTopFlags (\dflags -> xopt_unset dflags flag)
526
527 unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
528 unsetGOptM flag = updTopFlags (\dflags -> gopt_unset dflags flag)
529
530 unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
531 unsetWOptM flag = updTopFlags (\dflags -> wopt_unset dflags flag)
532
533 -- | Do it flag is true
534 whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
535 whenDOptM flag thing_inside = do b <- doptM flag
536 when b thing_inside
537 {-# INLINE whenDOptM #-} -- see Note [INLINE conditional tracing utilities]
538
539
540 whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
541 whenGOptM flag thing_inside = do b <- goptM flag
542 when b thing_inside
543 {-# INLINE whenGOptM #-} -- see Note [INLINE conditional tracing utilities]
544
545 whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
546 whenWOptM flag thing_inside = do b <- woptM flag
547 when b thing_inside
548 {-# INLINE whenWOptM #-} -- see Note [INLINE conditional tracing utilities]
549
550 whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
551 whenXOptM flag thing_inside = do b <- xoptM flag
552 when b thing_inside
553 {-# INLINE whenXOptM #-} -- see Note [INLINE conditional tracing utilities]
554
555 unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
556 unlessXOptM flag thing_inside = do b <- xoptM flag
557 unless b thing_inside
558 {-# INLINE unlessXOptM #-} -- see Note [INLINE conditional tracing utilities]
559
560 getGhcMode :: TcRnIf gbl lcl GhcMode
561 getGhcMode = ghcMode <$> getDynFlags
562
563 withoutDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
564 withoutDynamicNow = updTopFlags (\dflags -> dflags { dynamicNow = False})
565
566 updTopFlags :: (DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
567 updTopFlags f = updTopEnv (hscUpdateFlags f)
568
569 getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
570 getEpsVar = do
571 env <- getTopEnv
572 return (euc_eps (ue_eps (hsc_unit_env env)))
573
574 getEps :: TcRnIf gbl lcl ExternalPackageState
575 getEps = do { env <- getTopEnv; liftIO $ hscEPS env }
576
577 -- | Update the external package state. Returns the second result of the
578 -- modifier function.
579 --
580 -- This is an atomic operation and forces evaluation of the modified EPS in
581 -- order to avoid space leaks.
582 updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
583 -> TcRnIf gbl lcl a
584 updateEps upd_fn = do
585 traceIf (text "updating EPS")
586 eps_var <- getEpsVar
587 atomicUpdMutVar' eps_var upd_fn
588
589 -- | Update the external package state.
590 --
591 -- This is an atomic operation and forces evaluation of the modified EPS in
592 -- order to avoid space leaks.
593 updateEps_ :: (ExternalPackageState -> ExternalPackageState)
594 -> TcRnIf gbl lcl ()
595 updateEps_ upd_fn = updateEps (\eps -> (upd_fn eps, ()))
596
597 getHpt :: TcRnIf gbl lcl HomePackageTable
598 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
599
600 getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
601 getEpsAndHpt = do { env <- getTopEnv; eps <- liftIO $ hscEPS env
602 ; return (eps, hsc_HPT env) }
603
604 -- | A convenient wrapper for taking a @MaybeErr SDoc a@ and throwing
605 -- an exception if it is an error.
606 withException :: MonadIO m => SDocContext -> m (MaybeErr SDoc a) -> m a
607 withException ctx do_this = do
608 r <- do_this
609 case r of
610 Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx err))
611 Succeeded result -> return result
612
613 {-
614 ************************************************************************
615 * *
616 Arrow scopes
617 * *
618 ************************************************************************
619 -}
620
621 newArrowScope :: TcM a -> TcM a
622 newArrowScope
623 = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }
624
625 -- Return to the stored environment (from the enclosing proc)
626 escapeArrowScope :: TcM a -> TcM a
627 escapeArrowScope
628 = updLclEnv $ \ env ->
629 case tcl_arrow_ctxt env of
630 NoArrowCtxt -> env
631 ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
632 , tcl_lie = lie
633 , tcl_rdr = rdr_env }
634
635 {-
636 ************************************************************************
637 * *
638 Unique supply
639 * *
640 ************************************************************************
641 -}
642
643 newUnique :: TcRnIf gbl lcl Unique
644 newUnique
645 = do { env <- getEnv
646 ; let mask = env_um env
647 ; liftIO $! uniqFromMask mask }
648
649 newUniqueSupply :: TcRnIf gbl lcl UniqSupply
650 newUniqueSupply
651 = do { env <- getEnv
652 ; let mask = env_um env
653 ; liftIO $! mkSplitUniqSupply mask }
654
655 cloneLocalName :: Name -> TcM Name
656 -- Make a fresh Internal name with the same OccName and SrcSpan
657 cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name)
658
659 newName :: OccName -> TcM Name
660 newName occ = do { loc <- getSrcSpanM
661 ; newNameAt occ loc }
662
663 newNameAt :: OccName -> SrcSpan -> TcM Name
664 newNameAt occ span
665 = do { uniq <- newUnique
666 ; return (mkInternalName uniq occ span) }
667
668 newSysName :: OccName -> TcRnIf gbl lcl Name
669 newSysName occ
670 = do { uniq <- newUnique
671 ; return (mkSystemName uniq occ) }
672
673 newSysLocalId :: FastString -> Mult -> TcType -> TcRnIf gbl lcl TcId
674 newSysLocalId fs w ty
675 = do { u <- newUnique
676 ; return (mkSysLocal fs u w ty) }
677
678 newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId]
679 newSysLocalIds fs tys
680 = do { us <- newUniqueSupply
681 ; let mkId' n (Scaled w t) = mkSysLocal fs n w t
682 ; return (zipWith mkId' (uniqsFromSupply us) tys) }
683
684 instance MonadUnique (IOEnv (Env gbl lcl)) where
685 getUniqueM = newUnique
686 getUniqueSupplyM = newUniqueSupply
687
688 {-
689 ************************************************************************
690 * *
691 Accessing input/output
692 * *
693 ************************************************************************
694 -}
695
696 newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
697 newTcRef = newMutVar
698
699 readTcRef :: TcRef a -> TcRnIf gbl lcl a
700 readTcRef = readMutVar
701
702 writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
703 writeTcRef = writeMutVar
704
705 updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
706 -- Returns ()
707 updTcRef ref fn = liftIO $ modifyIORef' ref fn
708
709 {-
710 ************************************************************************
711 * *
712 Debugging
713 * *
714 ************************************************************************
715 -}
716
717 {- Note [INLINE conditional tracing utilities]
718 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
719 In general we want to optimise for the case where tracing is not enabled.
720 To ensure this happens, we ensure that traceTc and friends are inlined; this
721 ensures that the allocation of the document can be pushed into the tracing
722 path, keeping the non-traced path free of this extraneous work. For
723 instance, if we don't inline traceTc, we'll get
724
725 let stuff_to_print = ...
726 in traceTc "wombat" stuff_to_print
727
728 and the stuff_to_print thunk will be allocated in the "hot path", regardless
729 of tracing. But if we INLINE traceTc we get
730
731 let stuff_to_print = ...
732 in if doTracing
733 then emitTraceMsg "wombat" stuff_to_print
734 else return ()
735
736 and then we float in:
737
738 if doTracing
739 then let stuff_to_print = ...
740 in emitTraceMsg "wombat" stuff_to_print
741 else return ()
742
743 Now stuff_to_print is allocated only in the "cold path".
744
745 Moreover, on the "cold" path, after the conditional, we want to inline
746 as /little/ as possible. Performance doesn't matter here, and we'd like
747 to bloat the caller's code as little as possible. So we put a NOINLINE
748 on 'emitTraceMsg'
749
750 See #18168.
751 -}
752
753 -- Typechecker trace
754 traceTc :: String -> SDoc -> TcRn ()
755 traceTc herald doc =
756 labelledTraceOptTcRn Opt_D_dump_tc_trace herald doc
757 {-# INLINE traceTc #-} -- see Note [INLINE conditional tracing utilities]
758
759 -- Renamer Trace
760 traceRn :: String -> SDoc -> TcRn ()
761 traceRn herald doc =
762 labelledTraceOptTcRn Opt_D_dump_rn_trace herald doc
763 {-# INLINE traceRn #-} -- see Note [INLINE conditional tracing utilities]
764
765 -- | Trace when a certain flag is enabled. This is like `traceOptTcRn`
766 -- but accepts a string as a label and formats the trace message uniformly.
767 labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn ()
768 labelledTraceOptTcRn flag herald doc =
769 traceOptTcRn flag (formatTraceMsg herald doc)
770 {-# INLINE labelledTraceOptTcRn #-} -- see Note [INLINE conditional tracing utilities]
771
772 formatTraceMsg :: String -> SDoc -> SDoc
773 formatTraceMsg herald doc = hang (text herald) 2 doc
774
775 traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
776 traceOptTcRn flag doc =
777 whenDOptM flag $
778 dumpTcRn False flag "" FormatText doc
779 {-# INLINE traceOptTcRn #-} -- see Note [INLINE conditional tracing utilities]
780
781 -- | Dump if the given 'DumpFlag' is set.
782 dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()
783 dumpOptTcRn flag title fmt doc =
784 whenDOptM flag $
785 dumpTcRn False flag title fmt doc
786 {-# INLINE dumpOptTcRn #-} -- see Note [INLINE conditional tracing utilities]
787
788 -- | Unconditionally dump some trace output
789 --
790 -- Certain tests (T3017, Roles3, T12763 etc.) expect part of the
791 -- output generated by `-ddump-types` to be in 'PprUser' style. However,
792 -- generally we want all other debugging output to use 'PprDump'
793 -- style. We 'PprUser' style if 'useUserStyle' is True.
794 --
795 dumpTcRn :: Bool -> DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()
796 dumpTcRn useUserStyle flag title fmt doc = do
797 logger <- getLogger
798 printer <- getPrintUnqualified
799 real_doc <- wrapDocLoc doc
800 let sty = if useUserStyle
801 then mkUserStyle printer AllTheWay
802 else mkDumpStyle printer
803 liftIO $ logDumpFile logger sty flag title fmt real_doc
804
805 -- | Add current location if -dppr-debug
806 -- (otherwise the full location is usually way too much)
807 wrapDocLoc :: SDoc -> TcRn SDoc
808 wrapDocLoc doc = do
809 logger <- getLogger
810 if logHasDumpFlag logger Opt_D_ppr_debug
811 then do
812 loc <- getSrcSpanM
813 return (mkLocMessage MCOutput loc doc)
814 else
815 return doc
816
817 getPrintUnqualified :: TcRn PrintUnqualified
818 getPrintUnqualified
819 = do { rdr_env <- getGlobalRdrEnv
820 ; hsc_env <- getTopEnv
821 ; return $ mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env }
822
823 -- | Like logInfoTcRn, but for user consumption
824 printForUserTcRn :: SDoc -> TcRn ()
825 printForUserTcRn doc = do
826 logger <- getLogger
827 printer <- getPrintUnqualified
828 liftIO (printOutputForUser logger printer doc)
829
830 {-
831 traceIf works in the TcRnIf monad, where no RdrEnv is
832 available. Alas, they behave inconsistently with the other stuff;
833 e.g. are unaffected by -dump-to-file.
834 -}
835
836 traceIf :: SDoc -> TcRnIf m n ()
837 traceIf = traceOptIf Opt_D_dump_if_trace
838 {-# INLINE traceIf #-}
839 -- see Note [INLINE conditional tracing utilities]
840
841 traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
842 traceOptIf flag doc
843 = whenDOptM flag $ do -- No RdrEnv available, so qualify everything
844 logger <- getLogger
845 liftIO (putMsg logger doc)
846 {-# INLINE traceOptIf #-} -- see Note [INLINE conditional tracing utilities]
847
848 {-
849 ************************************************************************
850 * *
851 Typechecker global environment
852 * *
853 ************************************************************************
854 -}
855
856 getIsGHCi :: TcRn Bool
857 getIsGHCi = do { mod <- getModule
858 ; return (isInteractiveModule mod) }
859
860 getGHCiMonad :: TcRn Name
861 getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
862
863 getInteractivePrintName :: TcRn Name
864 getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }
865
866 tcIsHsBootOrSig :: TcRn Bool
867 tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
868
869 tcIsHsig :: TcRn Bool
870 tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) }
871
872 tcSelfBootInfo :: TcRn SelfBootInfo
873 tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }
874
875 getGlobalRdrEnv :: TcRn GlobalRdrEnv
876 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
877
878 getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
879 getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
880
881 getImports :: TcRn ImportAvails
882 getImports = do { env <- getGblEnv; return (tcg_imports env) }
883
884 getFixityEnv :: TcRn FixityEnv
885 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
886
887 extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
888 extendFixityEnv new_bit
889 = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
890 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
891
892 getRecFieldEnv :: TcRn RecFieldEnv
893 getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
894
895 getDeclaredDefaultTys :: TcRn (Maybe [Type])
896 getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
897
898 addDependentFiles :: [FilePath] -> TcRn ()
899 addDependentFiles fs = do
900 ref <- fmap tcg_dependent_files getGblEnv
901 dep_files <- readTcRef ref
902 writeTcRef ref (fs ++ dep_files)
903
904 {-
905 ************************************************************************
906 * *
907 Error management
908 * *
909 ************************************************************************
910 -}
911
912 getSrcSpanM :: TcRn SrcSpan
913 -- Avoid clash with Name.getSrcLoc
914 getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Strict.Nothing) }
915
916 getMnwib :: TcRn ModuleNameWithIsBoot
917 getMnwib = do
918 gbl_env <- getGblEnv
919 return $ GWIB (moduleName $ tcg_mod gbl_env) (hscSourceToIsBoot (tcg_src gbl_env))
920
921 -- See Note [Error contexts in generated code]
922 inGeneratedCode :: TcRn Bool
923 inGeneratedCode = tcl_in_gen_code <$> getLclEnv
924
925 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
926 -- See Note [Error contexts in generated code]
927 -- for the tcl_in_gen_code manipulation
928 setSrcSpan (RealSrcSpan loc _) thing_inside
929 = updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False })
930 thing_inside
931
932 setSrcSpan loc@(UnhelpfulSpan _) thing_inside
933 | isGeneratedSrcSpan loc
934 = updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside
935
936 | otherwise
937 = thing_inside
938
939 setSrcSpanA :: SrcSpanAnn' ann -> TcRn a -> TcRn a
940 setSrcSpanA l = setSrcSpan (locA l)
941
942 addLocM :: (a -> TcM b) -> Located a -> TcM b
943 addLocM fn (L loc a) = setSrcSpan loc $ fn a
944
945 addLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
946 addLocMA fn (L loc a) = setSrcSpanA loc $ fn a
947
948 wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
949 wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a
950 ; return (L loc b) }
951
952 wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b)
953 wrapLocAM fn (L loc a) = setSrcSpanA loc $ do { b <- fn a
954 ; return (L (locA loc) b) }
955
956 wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated (SrcSpanAnn' ann) b)
957 wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a
958 ; return (L loc b) }
959
960 wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
961 wrapLocFstM fn (L loc a) =
962 setSrcSpan loc $ do
963 (b,c) <- fn a
964 return (L loc b, c)
965
966 wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedAn t a -> TcM (LocatedAn t b, c)
967 wrapLocFstMA fn (L loc a) =
968 setSrcSpanA loc $ do
969 (b,c) <- fn a
970 return (L loc b, c)
971
972 wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c)
973 wrapLocSndM fn (L loc a) =
974 setSrcSpan loc $ do
975 (b,c) <- fn a
976 return (b, L loc c)
977
978 wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedA a -> TcM (b, LocatedA c)
979 wrapLocSndMA fn (L loc a) =
980 setSrcSpanA loc $ do
981 (b,c) <- fn a
982 return (b, L loc c)
983
984 wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM ()
985 wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a)
986
987 wrapLocMA_ :: (a -> TcM ()) -> LocatedA a -> TcM ()
988 wrapLocMA_ fn (L loc a) = setSrcSpan (locA loc) (fn a)
989
990 -- Reporting errors
991
992 getErrsVar :: TcRn (TcRef (Messages TcRnMessage))
993 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
994
995 setErrsVar :: TcRef (Messages TcRnMessage) -> TcRn a -> TcRn a
996 setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v })
997
998 addErr :: TcRnMessage -> TcRn ()
999 addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
1000
1001 failWith :: TcRnMessage -> TcRn a
1002 failWith msg = addErr msg >> failM
1003
1004 failAt :: SrcSpan -> TcRnMessage -> TcRn a
1005 failAt loc msg = addErrAt loc msg >> failM
1006
1007 addErrAt :: SrcSpan -> TcRnMessage -> TcRn ()
1008 -- addErrAt is mainly (exclusively?) used by the renamer, where
1009 -- tidying is not an issue, but it's all lazy so the extra
1010 -- work doesn't matter
1011 addErrAt loc msg = do { ctxt <- getErrCtxt
1012 ; tidy_env <- tcInitTidyEnv
1013 ; err_info <- mkErrInfo tidy_env ctxt
1014 ; add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) }
1015
1016 addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn ()
1017 addErrs msgs = mapM_ add msgs
1018 where
1019 add (loc,msg) = addErrAt loc msg
1020
1021 checkErr :: Bool -> TcRnMessage -> TcRn ()
1022 -- Add the error if the bool is False
1023 checkErr ok msg = unless ok (addErr msg)
1024
1025 addMessages :: Messages TcRnMessage -> TcRn ()
1026 addMessages msgs1
1027 = do { errs_var <- getErrsVar ;
1028 msgs0 <- readTcRef errs_var ;
1029 writeTcRef errs_var (unionMessages msgs0 msgs1) }
1030
1031 discardWarnings :: TcRn a -> TcRn a
1032 -- Ignore warnings inside the thing inside;
1033 -- used to ignore-unused-variable warnings inside derived code
1034 discardWarnings thing_inside
1035 = do { errs_var <- getErrsVar
1036 ; old_warns <- getWarningMessages <$> readTcRef errs_var
1037
1038 ; result <- thing_inside
1039
1040 -- Revert warnings to old_warns
1041 ; new_errs <- getErrorMessages <$> readTcRef errs_var
1042 ; writeTcRef errs_var $ mkMessages (old_warns `unionBags` new_errs)
1043
1044 ; return result }
1045
1046 {-
1047 ************************************************************************
1048 * *
1049 Shared error message stuff: renamer and typechecker
1050 * *
1051 ************************************************************************
1052 -}
1053
1054 add_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn ()
1055 add_long_err_at loc msg = mk_long_err_at loc msg >>= reportDiagnostic
1056 where
1057 mk_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn (MsgEnvelope TcRnMessage)
1058 mk_long_err_at loc msg
1059 = do { printer <- getPrintUnqualified ;
1060 unit_state <- hsc_units <$> getTopEnv ;
1061 return $ mkErrorMsgEnvelope loc printer
1062 $ TcRnMessageWithInfo unit_state msg
1063 }
1064
1065 mkTcRnMessage :: SrcSpan
1066 -> TcRnMessage
1067 -> TcRn (MsgEnvelope TcRnMessage)
1068 mkTcRnMessage loc msg
1069 = do { printer <- getPrintUnqualified ;
1070 diag_opts <- initDiagOpts <$> getDynFlags ;
1071 return $ mkMsgEnvelope diag_opts loc printer msg }
1072
1073 reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM ()
1074 reportDiagnostics = mapM_ reportDiagnostic
1075
1076 reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn ()
1077 reportDiagnostic msg
1078 = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelope msg) ;
1079 errs_var <- getErrsVar ;
1080 msgs <- readTcRef errs_var ;
1081 writeTcRef errs_var (msg `addMessage` msgs) }
1082
1083 -----------------------
1084 checkNoErrs :: TcM r -> TcM r
1085 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
1086 -- If m fails then (checkNoErrsTc m) fails.
1087 -- If m succeeds, it checks whether m generated any errors messages
1088 -- (it might have recovered internally)
1089 -- If so, it fails too.
1090 -- Regardless, any errors generated by m are propagated to the enclosing context.
1091 checkNoErrs main
1092 = do { (res, no_errs) <- askNoErrs main
1093 ; unless no_errs failM
1094 ; return res }
1095
1096 -----------------------
1097 whenNoErrs :: TcM () -> TcM ()
1098 whenNoErrs thing = ifErrsM (return ()) thing
1099
1100 ifErrsM :: TcRn r -> TcRn r -> TcRn r
1101 -- ifErrsM bale_out normal
1102 -- does 'bale_out' if there are errors in errors collection
1103 -- otherwise does 'normal'
1104 ifErrsM bale_out normal
1105 = do { errs_var <- getErrsVar ;
1106 msgs <- readTcRef errs_var ;
1107 if errorsFound msgs then
1108 bale_out
1109 else
1110 normal }
1111
1112 failIfErrsM :: TcRn ()
1113 -- Useful to avoid error cascades
1114 failIfErrsM = ifErrsM failM (return ())
1115
1116 {- *********************************************************************
1117 * *
1118 Context management for the type checker
1119 * *
1120 ************************************************************************
1121 -}
1122
1123 {- Note [Inlining addErrCtxt]
1124 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1125 You will notice a bunch of INLINE pragamas on addErrCtxt and friends.
1126 The reason is to promote better eta-expansion in client modules.
1127 Consider
1128 \e s. addErrCtxt c (tc_foo x) e s
1129 It looks as if tc_foo is applied to only two arguments, but if we
1130 inline addErrCtxt it'll turn into something more like
1131 \e s. tc_foo x (munge c e) s
1132 This is much better because Called Arity analysis can see that tc_foo
1133 is applied to four arguments. See #18379 for a concrete example.
1134
1135 This reliance on delicate inlining and Called Arity is not good.
1136 See #18202 for a more general approach. But meanwhile, these
1137 ininings seem unobjectional, and they solve the immediate
1138 problem.
1139
1140 Note [Error contexts in generated code]
1141 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1142 * setSrcSpan sets tc_in_gen_code to True if the SrcSpan is GeneratedSrcSpan,
1143 and back to False when we get a useful SrcSpan
1144
1145 * When tc_in_gen_code is True, addErrCtxt becomes a no-op.
1146
1147 So typically it's better to do setSrcSpan /before/ addErrCtxt.
1148
1149 See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr for
1150 more discussion of this fancy footwork.
1151 -}
1152
1153 getErrCtxt :: TcM [ErrCtxt]
1154 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
1155
1156 setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
1157 {-# INLINE setErrCtxt #-} -- Note [Inlining addErrCtxt]
1158 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
1159
1160 -- | Add a fixed message to the error context. This message should not
1161 -- do any tidying.
1162 addErrCtxt :: SDoc -> TcM a -> TcM a
1163 {-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt]
1164 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
1165
1166 -- | Add a message to the error context. This message may do tidying.
1167 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
1168 {-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt]
1169 addErrCtxtM ctxt = pushCtxt (False, ctxt)
1170
1171 -- | Add a fixed landmark message to the error context. A landmark
1172 -- message is always sure to be reported, even if there is a lot of
1173 -- context. It also doesn't count toward the maximum number of contexts
1174 -- reported.
1175 addLandmarkErrCtxt :: SDoc -> TcM a -> TcM a
1176 {-# INLINE addLandmarkErrCtxt #-} -- Note [Inlining addErrCtxt]
1177 addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
1178
1179 -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
1180 -- and tidying.
1181 addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
1182 {-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt]
1183 addLandmarkErrCtxtM ctxt = pushCtxt (True, ctxt)
1184
1185 pushCtxt :: ErrCtxt -> TcM a -> TcM a
1186 {-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt]
1187 pushCtxt ctxt = updLclEnv (updCtxt ctxt)
1188
1189 updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
1190 -- Do not update the context if we are in generated code
1191 -- See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
1192 updCtxt ctxt env@(TcLclEnv { tcl_ctxt = ctxts, tcl_in_gen_code = in_gen })
1193 | in_gen = env
1194 | otherwise = env { tcl_ctxt = ctxt : ctxts }
1195
1196 popErrCtxt :: TcM a -> TcM a
1197 popErrCtxt = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
1198 env { tcl_ctxt = pop ctxt })
1199 where
1200 pop [] = []
1201 pop (_:msgs) = msgs
1202
1203 getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
1204 getCtLocM origin t_or_k
1205 = do { env <- getLclEnv
1206 ; return (CtLoc { ctl_origin = origin
1207 , ctl_env = env
1208 , ctl_t_or_k = t_or_k
1209 , ctl_depth = initialSubGoalDepth }) }
1210
1211 setCtLocM :: CtLoc -> TcM a -> TcM a
1212 -- Set the SrcSpan and error context from the CtLoc
1213 setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
1214 = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
1215 , tcl_bndrs = tcl_bndrs lcl
1216 , tcl_ctxt = tcl_ctxt lcl })
1217 thing_inside
1218
1219
1220 {- *********************************************************************
1221 * *
1222 Error recovery and exceptions
1223 * *
1224 ********************************************************************* -}
1225
1226 tcTryM :: TcRn r -> TcRn (Maybe r)
1227 -- The most basic function: catch the exception
1228 -- Nothing => an exception happened
1229 -- Just r => no exception, result R
1230 -- Errors and constraints are propagated in both cases
1231 -- Never throws an exception
1232 tcTryM thing_inside
1233 = do { either_res <- tryM thing_inside
1234 ; return (case either_res of
1235 Left _ -> Nothing
1236 Right r -> Just r) }
1237 -- In the Left case the exception is always the IOEnv
1238 -- built-in in exception; see IOEnv.failM
1239
1240 -----------------------
1241 capture_constraints :: TcM r -> TcM (r, WantedConstraints)
1242 -- capture_constraints simply captures and returns the
1243 -- constraints generated by thing_inside
1244 -- Precondition: thing_inside must not throw an exception!
1245 -- Reason for precondition: an exception would blow past the place
1246 -- where we read the lie_var, and we'd lose the constraints altogether
1247 capture_constraints thing_inside
1248 = do { lie_var <- newTcRef emptyWC
1249 ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) $
1250 thing_inside
1251 ; lie <- readTcRef lie_var
1252 ; return (res, lie) }
1253
1254 capture_messages :: TcM r -> TcM (r, Messages TcRnMessage)
1255 -- capture_messages simply captures and returns the
1256 -- errors arnd warnings generated by thing_inside
1257 -- Precondition: thing_inside must not throw an exception!
1258 -- Reason for precondition: an exception would blow past the place
1259 -- where we read the msg_var, and we'd lose the constraints altogether
1260 capture_messages thing_inside
1261 = do { msg_var <- newTcRef emptyMessages
1262 ; res <- setErrsVar msg_var thing_inside
1263 ; msgs <- readTcRef msg_var
1264 ; return (res, msgs) }
1265
1266 -----------------------
1267 -- (askNoErrs m) runs m
1268 -- If m fails,
1269 -- then (askNoErrs m) fails, propagating only
1270 -- insoluble constraints
1271 --
1272 -- If m succeeds with result r,
1273 -- then (askNoErrs m) succeeds with result (r, b),
1274 -- where b is True iff m generated no errors
1275 --
1276 -- Regardless of success or failure,
1277 -- propagate any errors/warnings generated by m
1278 askNoErrs :: TcRn a -> TcRn (a, Bool)
1279 askNoErrs thing_inside
1280 = do { ((mb_res, lie), msgs) <- capture_messages $
1281 capture_constraints $
1282 tcTryM thing_inside
1283 ; addMessages msgs
1284
1285 ; case mb_res of
1286 Nothing -> do { emitConstraints (dropMisleading lie)
1287 ; failM }
1288
1289 Just res -> do { emitConstraints lie
1290 ; let errs_found = errorsFound msgs
1291 || insolubleWC lie
1292 ; return (res, not errs_found) } }
1293
1294 -----------------------
1295 tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints)
1296 -- (tryCaptureConstraints_maybe m) runs m,
1297 -- and returns the type constraints it generates
1298 -- It never throws an exception; instead if thing_inside fails,
1299 -- it returns Nothing and the /insoluble/ constraints
1300 -- Error messages are propagated
1301 tryCaptureConstraints thing_inside
1302 = do { (mb_res, lie) <- capture_constraints $
1303 tcTryM thing_inside
1304
1305 -- See Note [Constraints and errors]
1306 ; let lie_to_keep = case mb_res of
1307 Nothing -> dropMisleading lie
1308 Just {} -> lie
1309
1310 ; return (mb_res, lie_to_keep) }
1311
1312 captureConstraints :: TcM a -> TcM (a, WantedConstraints)
1313 -- (captureConstraints m) runs m, and returns the type constraints it generates
1314 -- If thing_inside fails (throwing an exception),
1315 -- then (captureConstraints thing_inside) fails too
1316 -- propagating the insoluble constraints only
1317 -- Error messages are propagated in either case
1318 captureConstraints thing_inside
1319 = do { (mb_res, lie) <- tryCaptureConstraints thing_inside
1320
1321 -- See Note [Constraints and errors]
1322 -- If the thing_inside threw an exception, emit the insoluble
1323 -- constraints only (returned by tryCaptureConstraints)
1324 -- so that they are not lost
1325 ; case mb_res of
1326 Nothing -> do { emitConstraints lie; failM }
1327 Just res -> return (res, lie) }
1328
1329 -----------------------
1330 -- | @tcCollectingUsage thing_inside@ runs @thing_inside@ and returns the usage
1331 -- information which was collected as part of the execution of
1332 -- @thing_inside@. Careful: @tcCollectingUsage thing_inside@ itself does not
1333 -- report any usage information, it's up to the caller to incorporate the
1334 -- returned usage information into the larger context appropriately.
1335 tcCollectingUsage :: TcM a -> TcM (UsageEnv,a)
1336 tcCollectingUsage thing_inside
1337 = do { env0 <- getLclEnv
1338 ; local_usage_ref <- newTcRef zeroUE
1339 ; let env1 = env0 { tcl_usage = local_usage_ref }
1340 ; result <- setLclEnv env1 thing_inside
1341 ; local_usage <- readTcRef local_usage_ref
1342 ; return (local_usage,result) }
1343
1344 -- | @tcScalingUsage mult thing_inside@ runs @thing_inside@ and scales all the
1345 -- usage information by @mult@.
1346 tcScalingUsage :: Mult -> TcM a -> TcM a
1347 tcScalingUsage mult thing_inside
1348 = do { (usage, result) <- tcCollectingUsage thing_inside
1349 ; traceTc "tcScalingUsage" (ppr mult)
1350 ; tcEmitBindingUsage $ scaleUE mult usage
1351 ; return result }
1352
1353 tcEmitBindingUsage :: UsageEnv -> TcM ()
1354 tcEmitBindingUsage ue
1355 = do { lcl_env <- getLclEnv
1356 ; let usage = tcl_usage lcl_env
1357 ; updTcRef usage (addUE ue) }
1358
1359 -----------------------
1360 attemptM :: TcRn r -> TcRn (Maybe r)
1361 -- (attemptM thing_inside) runs thing_inside
1362 -- If thing_inside succeeds, returning r,
1363 -- we return (Just r), and propagate all constraints and errors
1364 -- If thing_inside fail, throwing an exception,
1365 -- we return Nothing, propagating insoluble constraints,
1366 -- and all errors
1367 -- attemptM never throws an exception
1368 attemptM thing_inside
1369 = do { (mb_r, lie) <- tryCaptureConstraints thing_inside
1370 ; emitConstraints lie
1371
1372 -- Debug trace
1373 ; when (isNothing mb_r) $
1374 traceTc "attemptM recovering with insoluble constraints" $
1375 (ppr lie)
1376
1377 ; return mb_r }
1378
1379 -----------------------
1380 recoverM :: TcRn r -- Recovery action; do this if the main one fails
1381 -> TcRn r -- Main action: do this first;
1382 -- if it generates errors, propagate them all
1383 -> TcRn r
1384 -- (recoverM recover thing_inside) runs thing_inside
1385 -- If thing_inside fails, propagate its errors and insoluble constraints
1386 -- and run 'recover'
1387 -- If thing_inside succeeds, propagate all its errors and constraints
1388 --
1389 -- Can fail, if 'recover' fails
1390 recoverM recover thing
1391 = do { mb_res <- attemptM thing ;
1392 case mb_res of
1393 Nothing -> recover
1394 Just res -> return res }
1395
1396 -----------------------
1397
1398 -- | Drop elements of the input that fail, so the result
1399 -- list can be shorter than the argument list
1400 mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
1401 mapAndRecoverM f xs
1402 = do { mb_rs <- mapM (attemptM . f) xs
1403 ; return [r | Just r <- mb_rs] }
1404
1405 -- | Apply the function to all elements on the input list
1406 -- If all succeed, return the list of results
1407 -- Otherwise fail, propagating all errors
1408 mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
1409 mapAndReportM f xs
1410 = do { mb_rs <- mapM (attemptM . f) xs
1411 ; when (any isNothing mb_rs) failM
1412 ; return [r | Just r <- mb_rs] }
1413
1414 -- | The accumulator is not updated if the action fails
1415 foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
1416 foldAndRecoverM _ acc [] = return acc
1417 foldAndRecoverM f acc (x:xs) =
1418 do { mb_r <- attemptM (f acc x)
1419 ; case mb_r of
1420 Nothing -> foldAndRecoverM f acc xs
1421 Just acc' -> foldAndRecoverM f acc' xs }
1422
1423 -----------------------
1424 tryTc :: TcRn a -> TcRn (Maybe a, Messages TcRnMessage)
1425 -- (tryTc m) executes m, and returns
1426 -- Just r, if m succeeds (returning r)
1427 -- Nothing, if m fails
1428 -- It also returns all the errors and warnings accumulated by m
1429 -- It always succeeds (never raises an exception)
1430 tryTc thing_inside
1431 = capture_messages (attemptM thing_inside)
1432
1433 -----------------------
1434 discardErrs :: TcRn a -> TcRn a
1435 -- (discardErrs m) runs m,
1436 -- discarding all error messages and warnings generated by m
1437 -- If m fails, discardErrs fails, and vice versa
1438 discardErrs m
1439 = do { errs_var <- newTcRef emptyMessages
1440 ; setErrsVar errs_var m }
1441
1442 -----------------------
1443 tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r
1444 -- (tryTcDiscardingErrs recover thing_inside) tries 'thing_inside';
1445 -- if 'main' succeeds with no error messages, it's the answer
1446 -- otherwise discard everything from 'main', including errors,
1447 -- and try 'recover' instead.
1448 tryTcDiscardingErrs recover thing_inside
1449 = do { ((mb_res, lie), msgs) <- capture_messages $
1450 capture_constraints $
1451 tcTryM thing_inside
1452 ; case mb_res of
1453 Just res | not (errorsFound msgs)
1454 , not (insolubleWC lie)
1455 -> -- 'main' succeeded with no errors
1456 do { addMessages msgs -- msgs might still have warnings
1457 ; emitConstraints lie
1458 ; return res }
1459
1460 _ -> -- 'main' failed, or produced an error message
1461 recover -- Discard all errors and warnings
1462 -- and unsolved constraints entirely
1463 }
1464
1465 {-
1466 ************************************************************************
1467 * *
1468 Error message generation (type checker)
1469 * *
1470 ************************************************************************
1471
1472 The addErrTc functions add an error message, but do not cause failure.
1473 The 'M' variants pass a TidyEnv that has already been used to
1474 tidy up the message; we then use it to tidy the context messages
1475 -}
1476
1477 addErrTc :: TcRnMessage -> TcM ()
1478 addErrTc err_msg = do { env0 <- tcInitTidyEnv
1479 ; addErrTcM (env0, err_msg) }
1480
1481 addErrTcM :: (TidyEnv, TcRnMessage) -> TcM ()
1482 addErrTcM (tidy_env, err_msg)
1483 = do { ctxt <- getErrCtxt ;
1484 loc <- getSrcSpanM ;
1485 add_err_tcm tidy_env err_msg loc ctxt }
1486
1487 -- The failWith functions add an error message and cause failure
1488
1489 failWithTc :: TcRnMessage -> TcM a -- Add an error message and fail
1490 failWithTc err_msg
1491 = addErrTc err_msg >> failM
1492
1493 failWithTcM :: (TidyEnv, TcRnMessage) -> TcM a -- Add an error message and fail
1494 failWithTcM local_and_msg
1495 = addErrTcM local_and_msg >> failM
1496
1497 checkTc :: Bool -> TcRnMessage -> TcM () -- Check that the boolean is true
1498 checkTc True _ = return ()
1499 checkTc False err = failWithTc err
1500
1501 checkTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
1502 checkTcM True _ = return ()
1503 checkTcM False err = failWithTcM err
1504
1505 failIfTc :: Bool -> TcRnMessage -> TcM () -- Check that the boolean is false
1506 failIfTc False _ = return ()
1507 failIfTc True err = failWithTc err
1508
1509 failIfTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
1510 -- Check that the boolean is false
1511 failIfTcM False _ = return ()
1512 failIfTcM True err = failWithTcM err
1513
1514
1515 -- Warnings have no 'M' variant, nor failure
1516
1517 -- | Display a warning if a condition is met.
1518 warnIf :: Bool -> TcRnMessage -> TcRn ()
1519 warnIf is_bad msg -- No need to check any flag here, it will be done in 'diagReasonSeverity'.
1520 = when is_bad (addDiagnostic msg)
1521
1522 no_err_info :: ErrInfo
1523 no_err_info = ErrInfo Outputable.empty Outputable.empty
1524
1525 -- | Display a warning if a condition is met.
1526 diagnosticTc :: Bool -> TcRnMessage -> TcM ()
1527 diagnosticTc should_report warn_msg
1528 | should_report = addDiagnosticTc warn_msg
1529 | otherwise = return ()
1530
1531 -- | Display a diagnostic if a condition is met.
1532 diagnosticTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
1533 diagnosticTcM should_report warn_msg
1534 | should_report = addDiagnosticTcM warn_msg
1535 | otherwise = return ()
1536
1537 -- | Display a diagnostic in the current context.
1538 addDiagnosticTc :: TcRnMessage -> TcM ()
1539 addDiagnosticTc msg
1540 = do { env0 <- tcInitTidyEnv ;
1541 addDiagnosticTcM (env0, msg) }
1542
1543 -- | Display a diagnostic in a given context.
1544 addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM ()
1545 addDiagnosticTcM (env0, msg)
1546 = do { ctxt <- getErrCtxt
1547 ; extra <- mkErrInfo env0 ctxt
1548 ; let err_info = ErrInfo extra Outputable.empty
1549 ; add_diagnostic (TcRnMessageDetailed err_info msg) }
1550
1551 -- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage'
1552 -- given some additional context about the diagnostic.
1553 addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM ()
1554 addDetailedDiagnostic mkMsg = do
1555 loc <- getSrcSpanM
1556 printer <- getPrintUnqualified
1557 !diag_opts <- initDiagOpts <$> getDynFlags
1558 env0 <- tcInitTidyEnv
1559 ctxt <- getErrCtxt
1560 err_info <- mkErrInfo env0 ctxt
1561 reportDiagnostic (mkMsgEnvelope diag_opts loc printer (mkMsg (ErrInfo err_info empty)))
1562
1563 addTcRnDiagnostic :: TcRnMessage -> TcM ()
1564 addTcRnDiagnostic msg = do
1565 loc <- getSrcSpanM
1566 mkTcRnMessage loc msg >>= reportDiagnostic
1567
1568 -- | Display a diagnostic for the current source location, taken from
1569 -- the 'TcRn' monad.
1570 addDiagnostic :: TcRnMessage -> TcRn ()
1571 addDiagnostic msg = add_diagnostic (TcRnMessageDetailed no_err_info msg)
1572
1573 -- | Display a diagnostic for a given source location.
1574 addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn ()
1575 addDiagnosticAt loc msg = do
1576 unit_state <- hsc_units <$> getTopEnv
1577 let dia = TcRnMessageDetailed no_err_info msg
1578 mkTcRnMessage loc (TcRnMessageWithInfo unit_state dia) >>= reportDiagnostic
1579
1580 -- | Display a diagnostic, with an optional flag, for the current source
1581 -- location.
1582 add_diagnostic :: TcRnMessageDetailed -> TcRn ()
1583 add_diagnostic msg
1584 = do { loc <- getSrcSpanM
1585 ; unit_state <- hsc_units <$> getTopEnv
1586 ; mkTcRnMessage loc (TcRnMessageWithInfo unit_state msg) >>= reportDiagnostic
1587 }
1588
1589
1590 {-
1591 -----------------------------------
1592 Other helper functions
1593 -}
1594
1595 add_err_tcm :: TidyEnv -> TcRnMessage -> SrcSpan
1596 -> [ErrCtxt]
1597 -> TcM ()
1598 add_err_tcm tidy_env msg loc ctxt
1599 = do { err_info <- mkErrInfo tidy_env ctxt ;
1600 add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) }
1601
1602 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
1603 -- Tidy the error info, trimming excessive contexts
1604 mkErrInfo env ctxts
1605 -- = do
1606 -- dbg <- hasPprDebug <$> getDynFlags
1607 -- if dbg -- In -dppr-debug style the output
1608 -- then return empty -- just becomes too voluminous
1609 -- else go dbg 0 env ctxts
1610 = go False 0 env ctxts
1611 where
1612 go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
1613 go _ _ _ [] = return empty
1614 go dbg n env ((is_landmark, ctxt) : ctxts)
1615 | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg
1616 = do { (env', msg) <- ctxt env
1617 ; let n' = if is_landmark then n else n+1
1618 ; rest <- go dbg n' env' ctxts
1619 ; return (msg $$ rest) }
1620 | otherwise
1621 = go dbg n env ctxts
1622
1623 mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts
1624 mAX_CONTEXTS = 3
1625
1626 -- debugTc is useful for monadic debugging code
1627
1628 debugTc :: TcM () -> TcM ()
1629 debugTc thing
1630 | debugIsOn = thing
1631 | otherwise = return ()
1632
1633 {-
1634 ************************************************************************
1635 * *
1636 Type constraints
1637 * *
1638 ************************************************************************
1639 -}
1640
1641 addTopEvBinds :: Bag EvBind -> TcM a -> TcM a
1642 addTopEvBinds new_ev_binds thing_inside
1643 =updGblEnv upd_env thing_inside
1644 where
1645 upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env
1646 `unionBags` new_ev_binds }
1647
1648 newTcEvBinds :: TcM EvBindsVar
1649 newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
1650 ; tcvs_ref <- newTcRef emptyVarSet
1651 ; uniq <- newUnique
1652 ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
1653 ; return (EvBindsVar { ebv_binds = binds_ref
1654 , ebv_tcvs = tcvs_ref
1655 , ebv_uniq = uniq }) }
1656
1657 -- | Creates an EvBindsVar incapable of holding any bindings. It still
1658 -- tracks covar usages (see comments on ebv_tcvs in "GHC.Tc.Types.Evidence"), thus
1659 -- must be made monadically
1660 newNoTcEvBinds :: TcM EvBindsVar
1661 newNoTcEvBinds
1662 = do { tcvs_ref <- newTcRef emptyVarSet
1663 ; uniq <- newUnique
1664 ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq)
1665 ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref
1666 , ebv_uniq = uniq }) }
1667
1668 cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar
1669 -- Clone the refs, so that any binding created when
1670 -- solving don't pollute the original
1671 cloneEvBindsVar ebv@(EvBindsVar {})
1672 = do { binds_ref <- newTcRef emptyEvBindMap
1673 ; tcvs_ref <- newTcRef emptyVarSet
1674 ; return (ebv { ebv_binds = binds_ref
1675 , ebv_tcvs = tcvs_ref }) }
1676 cloneEvBindsVar ebv@(CoEvBindsVar {})
1677 = do { tcvs_ref <- newTcRef emptyVarSet
1678 ; return (ebv { ebv_tcvs = tcvs_ref }) }
1679
1680 getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
1681 getTcEvTyCoVars ev_binds_var
1682 = readTcRef (ebv_tcvs ev_binds_var)
1683
1684 getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
1685 getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref })
1686 = readTcRef ev_ref
1687 getTcEvBindsMap (CoEvBindsVar {})
1688 = return emptyEvBindMap
1689
1690 setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM ()
1691 setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds
1692 = writeTcRef ev_ref binds
1693 setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds
1694 | isEmptyEvBindMap ev_binds
1695 = return ()
1696 | otherwise
1697 = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds)
1698
1699 addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
1700 -- Add a binding to the TcEvBinds by side effect
1701 addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind
1702 = do { traceTc "addTcEvBind" $ ppr u $$
1703 ppr ev_bind
1704 ; bnds <- readTcRef ev_ref
1705 ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
1706 addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind
1707 = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u)
1708
1709 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
1710 chooseUniqueOccTc fn =
1711 do { env <- getGblEnv
1712 ; let dfun_n_var = tcg_dfun_n env
1713 ; set <- readTcRef dfun_n_var
1714 ; let occ = fn set
1715 ; writeTcRef dfun_n_var (extendOccSet set occ)
1716 ; return occ }
1717
1718 getConstraintVar :: TcM (TcRef WantedConstraints)
1719 getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
1720
1721 setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
1722 setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
1723
1724 emitStaticConstraints :: WantedConstraints -> TcM ()
1725 emitStaticConstraints static_lie
1726 = do { gbl_env <- getGblEnv
1727 ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) }
1728
1729 emitConstraints :: WantedConstraints -> TcM ()
1730 emitConstraints ct
1731 | isEmptyWC ct
1732 = return ()
1733 | otherwise
1734 = do { lie_var <- getConstraintVar ;
1735 updTcRef lie_var (`andWC` ct) }
1736
1737 emitSimple :: Ct -> TcM ()
1738 emitSimple ct
1739 = do { lie_var <- getConstraintVar ;
1740 updTcRef lie_var (`addSimples` unitBag ct) }
1741
1742 emitSimples :: Cts -> TcM ()
1743 emitSimples cts
1744 = do { lie_var <- getConstraintVar ;
1745 updTcRef lie_var (`addSimples` cts) }
1746
1747 emitImplication :: Implication -> TcM ()
1748 emitImplication ct
1749 = do { lie_var <- getConstraintVar ;
1750 updTcRef lie_var (`addImplics` unitBag ct) }
1751
1752 emitImplications :: Bag Implication -> TcM ()
1753 emitImplications ct
1754 = unless (isEmptyBag ct) $
1755 do { lie_var <- getConstraintVar ;
1756 updTcRef lie_var (`addImplics` ct) }
1757
1758 emitInsoluble :: Ct -> TcM ()
1759 emitInsoluble ct
1760 = do { traceTc "emitInsoluble" (ppr ct)
1761 ; lie_var <- getConstraintVar
1762 ; updTcRef lie_var (`addInsols` unitBag ct) }
1763
1764 emitHole :: Hole -> TcM ()
1765 emitHole hole
1766 = do { traceTc "emitHole" (ppr hole)
1767 ; lie_var <- getConstraintVar
1768 ; updTcRef lie_var (`addHoles` unitBag hole) }
1769
1770 emitHoles :: Bag Hole -> TcM ()
1771 emitHoles holes
1772 = do { traceTc "emitHoles" (ppr holes)
1773 ; lie_var <- getConstraintVar
1774 ; updTcRef lie_var (`addHoles` holes) }
1775
1776 -- | Throw out any constraints emitted by the thing_inside
1777 discardConstraints :: TcM a -> TcM a
1778 discardConstraints thing_inside = fst <$> captureConstraints thing_inside
1779
1780 -- | The name says it all. The returned TcLevel is the *inner* TcLevel.
1781 pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
1782 pushLevelAndCaptureConstraints thing_inside
1783 = do { env <- getLclEnv
1784 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1785 ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl')
1786 ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $
1787 captureConstraints thing_inside
1788 ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl')
1789 ; return (tclvl', lie, res) }
1790
1791 pushTcLevelM_ :: TcM a -> TcM a
1792 pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
1793
1794 pushTcLevelM :: TcM a -> TcM (TcLevel, a)
1795 -- See Note [TcLevel assignment] in GHC.Tc.Utils.TcType
1796 pushTcLevelM thing_inside
1797 = do { env <- getLclEnv
1798 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1799 ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
1800 thing_inside
1801 ; return (tclvl', res) }
1802
1803 -- Returns pushed TcLevel
1804 pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel)
1805 pushTcLevelsM num_levels thing_inside
1806 = do { env <- getLclEnv
1807 ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env)
1808 ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $
1809 thing_inside
1810 ; return (res, tclvl') }
1811
1812 getTcLevel :: TcM TcLevel
1813 getTcLevel = do { env <- getLclEnv
1814 ; return (tcl_tclvl env) }
1815
1816 setTcLevel :: TcLevel -> TcM a -> TcM a
1817 setTcLevel tclvl thing_inside
1818 = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
1819
1820 isTouchableTcM :: TcTyVar -> TcM Bool
1821 isTouchableTcM tv
1822 = do { lvl <- getTcLevel
1823 ; return (isTouchableMetaTyVar lvl tv) }
1824
1825 getLclTypeEnv :: TcM TcTypeEnv
1826 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
1827
1828 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
1829 -- Set the local type envt, but do *not* disturb other fields,
1830 -- notably the lie_var
1831 setLclTypeEnv lcl_env thing_inside
1832 = updLclEnv upd thing_inside
1833 where
1834 upd env = env { tcl_env = tcl_env lcl_env }
1835
1836 traceTcConstraints :: String -> TcM ()
1837 traceTcConstraints msg
1838 = do { lie_var <- getConstraintVar
1839 ; lie <- readTcRef lie_var
1840 ; traceOptTcRn Opt_D_dump_tc_trace $
1841 hang (text (msg ++ ": LIE:")) 2 (ppr lie)
1842 }
1843
1844 data IsExtraConstraint = YesExtraConstraint
1845 | NoExtraConstraint
1846
1847 instance Outputable IsExtraConstraint where
1848 ppr YesExtraConstraint = text "YesExtraConstraint"
1849 ppr NoExtraConstraint = text "NoExtraConstraint"
1850
1851 emitAnonTypeHole :: IsExtraConstraint
1852 -> TcTyVar -> TcM ()
1853 emitAnonTypeHole extra_constraints tv
1854 = do { ct_loc <- getCtLocM (TypeHoleOrigin occ) Nothing
1855 ; let hole = Hole { hole_sort = sort
1856 , hole_occ = occ
1857 , hole_ty = mkTyVarTy tv
1858 , hole_loc = ct_loc }
1859 ; emitHole hole }
1860 where
1861 occ = mkTyVarOcc "_"
1862 sort | YesExtraConstraint <- extra_constraints = ConstraintHole
1863 | otherwise = TypeHole
1864
1865 emitNamedTypeHole :: (Name, TcTyVar) -> TcM ()
1866 emitNamedTypeHole (name, tv)
1867 = do { ct_loc <- setSrcSpan (nameSrcSpan name) $
1868 getCtLocM (TypeHoleOrigin occ) Nothing
1869 ; let hole = Hole { hole_sort = TypeHole
1870 , hole_occ = occ
1871 , hole_ty = mkTyVarTy tv
1872 , hole_loc = ct_loc }
1873 ; emitHole hole }
1874 where
1875 occ = nameOccName name
1876
1877 {- Note [Constraints and errors]
1878 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1879 Consider this (#12124):
1880
1881 foo :: Maybe Int
1882 foo = return (case Left 3 of
1883 Left -> 1 -- Hard error here!
1884 _ -> 0)
1885
1886 The call to 'return' will generate a (Monad m) wanted constraint; but
1887 then there'll be "hard error" (i.e. an exception in the TcM monad), from
1888 the unsaturated Left constructor pattern.
1889
1890 We'll recover in tcPolyBinds, using recoverM. But then the final
1891 tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly
1892 un-filled-in, and will emit a misleading error message.
1893
1894 The underlying problem is that an exception interrupts the constraint
1895 gathering process. Bottom line: if we have an exception, it's best
1896 simply to discard any gathered constraints. Hence in 'attemptM' we
1897 capture the constraints in a fresh variable, and only emit them into
1898 the surrounding context if we exit normally. If an exception is
1899 raised, simply discard the collected constraints... we have a hard
1900 error to report. So this capture-the-emit dance isn't as stupid as it
1901 looks :-).
1902
1903 However suppose we throw an exception inside an invocation of
1904 captureConstraints, and discard all the constraints. Some of those
1905 constraints might be "variable out of scope" Hole constraints, and that
1906 might have been the actual original cause of the exception! For
1907 example (#12529):
1908 f = p @ Int
1909 Here 'p' is out of scope, so we get an insoluble Hole constraint. But
1910 the visible type application fails in the monad (throws an exception).
1911 We must not discard the out-of-scope error.
1912
1913 It's distressingly delicate though:
1914
1915 * If we discard too /many/ constraints we may fail to report the error
1916 that led us to interrupte the constraint gathering process.
1917
1918 One particular example "variable out of scope" Hole constraints. For
1919 example (#12529):
1920 f = p @ Int
1921 Here 'p' is out of scope, so we get an insoluble Hole constraint. But
1922 the visible type application fails in the monad (throws an exception).
1923 We must not discard the out-of-scope error.
1924
1925 Also GHC.Tc.Solver.simplifyAndEmitFlatConstraints may fail having
1926 emitted some constraints with skolem-escape problems.
1927
1928 * If we discard too /few/ constraints, we may get the misleading
1929 class constraints mentioned above. But we may /also/ end up taking
1930 constraints built at some inner level, and emitting them at some
1931 outer level, and then breaking the TcLevel invariants
1932 See Note [TcLevel invariants] in GHC.Tc.Utils.TcType
1933
1934 So dropMisleading has a horridly ad-hoc structure. It keeps only
1935 /insoluble/ flat constraints (which are unlikely to very visibly trip
1936 up on the TcLevel invariant, but all /implication/ constraints (except
1937 the class constraints inside them). The implication constraints are
1938 OK because they set the ambient level before attempting to solve any
1939 inner constraints. Ugh! I hate this. But it seems to work.
1940
1941 However note that freshly-generated constraints like (Int ~ Bool), or
1942 ((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as
1943 insoluble. The constraint solver does that. So they'll be discarded.
1944 That's probably ok; but see th/5358 as a not-so-good example:
1945 t1 :: Int
1946 t1 x = x -- Manifestly wrong
1947
1948 foo = $(...raises exception...)
1949 We report the exception, but not the bug in t1. Oh well. Possible
1950 solution: make GHC.Tc.Utils.Unify.uType spot manifestly-insoluble constraints.
1951
1952
1953 ************************************************************************
1954 * *
1955 Template Haskell context
1956 * *
1957 ************************************************************************
1958 -}
1959
1960 recordThUse :: TcM ()
1961 recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
1962
1963 recordThSpliceUse :: TcM ()
1964 recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
1965
1966 keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set
1967 keepAlive name
1968 = do { env <- getGblEnv
1969 ; traceRn "keep alive" (ppr name)
1970 ; updTcRef (tcg_keep env) (`extendNameSet` name) }
1971
1972 getStage :: TcM ThStage
1973 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
1974
1975 getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
1976 getStageAndBindLevel name
1977 = do { env <- getLclEnv;
1978 ; case lookupNameEnv (tcl_th_bndrs env) name of
1979 Nothing -> return Nothing
1980 Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
1981
1982 setStage :: ThStage -> TcM a -> TcRn a
1983 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
1984
1985 -- | Adds the given modFinalizers to the global environment and set them to use
1986 -- the current local environment.
1987 addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
1988 addModFinalizersWithLclEnv mod_finalizers
1989 = do lcl_env <- getLclEnv
1990 th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
1991 updTcRef th_modfinalizers_var $ \fins ->
1992 (lcl_env, mod_finalizers) : fins
1993
1994 {-
1995 ************************************************************************
1996 * *
1997 Safe Haskell context
1998 * *
1999 ************************************************************************
2000 -}
2001
2002 -- | Mark that safe inference has failed
2003 -- See Note [Safe Haskell Overlapping Instances Implementation]
2004 -- although this is used for more than just that failure case.
2005 recordUnsafeInfer :: Messages TcRnMessage -> TcM ()
2006 recordUnsafeInfer msgs =
2007 getGblEnv >>= \env -> do writeTcRef (tcg_safe_infer env) False
2008 writeTcRef (tcg_safe_infer_reasons env) msgs
2009
2010 -- | Figure out the final correct safe haskell mode
2011 finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
2012 finalSafeMode dflags tcg_env = do
2013 safeInf <- readIORef (tcg_safe_infer tcg_env)
2014 return $ case safeHaskell dflags of
2015 Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred
2016 | otherwise -> Sf_None
2017 s -> s
2018
2019 -- | Switch instances to safe instances if we're in Safe mode.
2020 fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
2021 fixSafeInstances sfMode | sfMode /= Sf_Safe && sfMode /= Sf_SafeInferred = id
2022 fixSafeInstances _ = map fixSafe
2023 where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
2024 in inst { is_flag = new_flag }
2025
2026 {-
2027 ************************************************************************
2028 * *
2029 Stuff for the renamer's local env
2030 * *
2031 ************************************************************************
2032 -}
2033
2034 getLocalRdrEnv :: RnM LocalRdrEnv
2035 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
2036
2037 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
2038 setLocalRdrEnv rdr_env thing_inside
2039 = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
2040
2041 {-
2042 ************************************************************************
2043 * *
2044 Stuff for interface decls
2045 * *
2046 ************************************************************************
2047 -}
2048
2049 mkIfLclEnv :: Module -> SDoc -> IsBootInterface -> IfLclEnv
2050 mkIfLclEnv mod loc boot
2051 = IfLclEnv { if_mod = mod,
2052 if_loc = loc,
2053 if_boot = boot,
2054 if_nsubst = Nothing,
2055 if_implicits_env = Nothing,
2056 if_tv_env = emptyFsEnv,
2057 if_id_env = emptyFsEnv }
2058
2059 -- | Run an 'IfG' (top-level interface monad) computation inside an existing
2060 -- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
2061 -- based on 'TcGblEnv'.
2062 initIfaceTcRn :: IfG a -> TcRn a
2063 initIfaceTcRn thing_inside
2064 = do { tcg_env <- getGblEnv
2065 ; hsc_env <- getTopEnv
2066 -- bangs to avoid leaking the envs (#19356)
2067 ; let !home_unit = hsc_home_unit hsc_env
2068 !knot_vars = tcg_type_env_var tcg_env
2069 -- When we are instantiating a signature, we DEFINITELY
2070 -- do not want to knot tie.
2071 is_instantiate = isHomeUnitInstantiating home_unit
2072 ; let { if_env = IfGblEnv {
2073 if_doc = text "initIfaceTcRn",
2074 if_rec_types =
2075 if is_instantiate
2076 then emptyKnotVars
2077 else readTcRef <$> knot_vars
2078 }
2079 }
2080 ; setEnvs (if_env, ()) thing_inside }
2081
2082 -- | 'initIfaceLoad' can be used when there's no chance that the action will
2083 -- call 'typecheckIface' when inside a module loop and hence 'tcIfaceGlobal'.
2084 initIfaceLoad :: HscEnv -> IfG a -> IO a
2085 initIfaceLoad hsc_env do_this
2086 = do let gbl_env = IfGblEnv {
2087 if_doc = text "initIfaceLoad",
2088 if_rec_types = emptyKnotVars
2089 }
2090 initTcRnIf 'i' (hsc_env { hsc_type_env_vars = emptyKnotVars }) gbl_env () do_this
2091
2092 -- | This is used when we are doing to call 'typecheckModule' on an 'ModIface',
2093 -- if it's part of a loop with some other modules then we need to use their
2094 -- IORef TypeEnv vars when typechecking but crucially not our own.
2095 initIfaceLoadModule :: HscEnv -> Module -> IfG a -> IO a
2096 initIfaceLoadModule hsc_env this_mod do_this
2097 = do let gbl_env = IfGblEnv {
2098 if_doc = text "initIfaceLoadModule",
2099 if_rec_types = readTcRef <$> knotVarsWithout this_mod (hsc_type_env_vars hsc_env)
2100 }
2101 initTcRnIf 'i' hsc_env gbl_env () do_this
2102
2103 initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a
2104 -- Used when checking the up-to-date-ness of the old Iface
2105 -- Initialise the environment with no useful info at all
2106 initIfaceCheck doc hsc_env do_this
2107 = do let gbl_env = IfGblEnv {
2108 if_doc = text "initIfaceCheck" <+> doc,
2109 if_rec_types = readTcRef <$> hsc_type_env_vars hsc_env
2110 }
2111 initTcRnIf 'i' hsc_env gbl_env () do_this
2112
2113 initIfaceLcl :: Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a
2114 initIfaceLcl mod loc_doc hi_boot_file thing_inside
2115 = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside
2116
2117 -- | Initialize interface typechecking, but with a 'NameShape'
2118 -- to apply when typechecking top-level 'OccName's (see
2119 -- 'lookupIfaceTop')
2120 initIfaceLclWithSubst :: Module -> SDoc -> IsBootInterface -> NameShape -> IfL a -> IfM lcl a
2121 initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside
2122 = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside
2123
2124 getIfModule :: IfL Module
2125 getIfModule = do { env <- getLclEnv; return (if_mod env) }
2126
2127 --------------------
2128 failIfM :: SDoc -> IfL a
2129 -- The Iface monad doesn't have a place to accumulate errors, so we
2130 -- just fall over fast if one happens; it "shouldn't happen".
2131 -- We use IfL here so that we can get context info out of the local env
2132 failIfM msg = do
2133 env <- getLclEnv
2134 let full_msg = (if_loc env <> colon) $$ nest 2 msg
2135 logger <- getLogger
2136 liftIO (logMsg logger MCFatal
2137 noSrcSpan $ withPprStyle defaultErrStyle full_msg)
2138 failM
2139
2140 --------------------
2141
2142 -- | Run thing_inside in an interleaved thread.
2143 -- It shares everything with the parent thread, so this is DANGEROUS.
2144 --
2145 -- It returns Nothing if the computation fails
2146 --
2147 -- It's used for lazily type-checking interface
2148 -- signatures, which is pretty benign.
2149 --
2150 -- See Note [Masking exceptions in forkM_maybe]
2151 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
2152 forkM_maybe doc thing_inside
2153 = unsafeInterleaveM $ uninterruptibleMaskM_ $
2154 do { traceIf (text "Starting fork {" <+> doc)
2155 ; mb_res <- tryM $
2156 updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
2157 thing_inside
2158 ; case mb_res of
2159 Right r -> do { traceIf (text "} ending fork" <+> doc)
2160 ; return (Just r) }
2161 Left exn -> do {
2162 -- Bleat about errors in the forked thread, if -ddump-if-trace is on
2163 -- Otherwise we silently discard errors. Errors can legitimately
2164 -- happen when compiling interface signatures (see tcInterfaceSigs)
2165 whenDOptM Opt_D_dump_if_trace $ do
2166 logger <- getLogger
2167 let msg = hang (text "forkM failed:" <+> doc)
2168 2 (text (show exn))
2169 liftIO $ logMsg logger
2170 MCFatal
2171 noSrcSpan
2172 $ withPprStyle defaultErrStyle msg
2173
2174 ; traceIf (text "} ending fork (badly)" <+> doc)
2175 ; return Nothing }
2176 }
2177
2178 forkM :: SDoc -> IfL a -> IfL a
2179 forkM doc thing_inside
2180 = do { mb_res <- forkM_maybe doc thing_inside
2181 ; return (case mb_res of
2182 Nothing -> pgmError "Cannot continue after interface file error"
2183 -- pprPanic "forkM" doc
2184 Just r -> r) }
2185
2186 setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
2187 setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl
2188 { if_implicits_env = Just tenv }) m
2189
2190 {-
2191 Note [Masking exceptions in forkM_maybe]
2192 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2193
2194 When using GHC-as-API it must be possible to interrupt snippets of code
2195 executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
2196 by throwing an asynchronous interrupt to the GHC thread. However, there is a
2197 subtle problem: runStmt first typechecks the code before running it, and the
2198 exception might interrupt the type checker rather than the code. Moreover, the
2199 typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
2200 more importantly might be inside an exception handler inside that
2201 unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
2202 asynchronous exception as a synchronous exception, and the exception will end
2203 up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
2204 discussion). We don't currently know a general solution to this problem, but
2205 we can use uninterruptibleMask_ to avoid the situation.
2206 -}
2207
2208 -- | Get the next cost centre index associated with a given name.
2209 getCCIndexM :: (gbl -> TcRef CostCentreState) -> FastString -> TcRnIf gbl lcl CostCentreIndex
2210 getCCIndexM get_ccs nm = do
2211 env <- getGblEnv
2212 let cc_st_ref = get_ccs env
2213 cc_st <- readTcRef cc_st_ref
2214 let (idx, cc_st') = getCCIndex nm cc_st
2215 writeTcRef cc_st_ref cc_st'
2216 return idx
2217
2218 -- | See 'getCCIndexM'.
2219 getCCIndexTcM :: FastString -> TcM CostCentreIndex
2220 getCCIndexTcM = getCCIndexM tcg_cc_st