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