3dff875114d7961b491d4f81521443feb8afb017
[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, foldAndRecoverM,
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
954 -- | Drop elements of the input that fail, so the result
955 -- list can be shorter than the argument list
956 mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
957 mapAndRecoverM f = fmap reverse . foldAndRecoverM (\xs x -> (:xs) <$> f x ) []
958
959 -- | The accumulator is not updated if the action fails
960 foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
961 foldAndRecoverM _ acc [] = return acc
962 foldAndRecoverM f acc (x:xs) =
963 do { mb_r <- try_m (f acc x)
964 ; case mb_r of
965 Left _ -> foldAndRecoverM f acc xs
966 Right acc' -> foldAndRecoverM f acc' xs }
967
968 -- | Succeeds if applying the argument to all members of the lists succeeds,
969 -- but nevertheless runs it on all arguments, to collect all errors.
970 mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
971 mapAndReportM f xs = checkNoErrs (mapAndRecoverM f xs)
972
973 -----------------------
974 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
975 -- (tryTc m) executes m, and returns
976 -- Just r, if m succeeds (returning r)
977 -- Nothing, if m fails
978 -- It also returns all the errors and warnings accumulated by m
979 -- It always succeeds (never raises an exception)
980 tryTc m
981 = do { errs_var <- newTcRef emptyMessages ;
982 res <- try_m (setErrsVar errs_var m) ;
983 msgs <- readTcRef errs_var ;
984 return (msgs, case res of
985 Left _ -> Nothing
986 Right val -> Just val)
987 -- The exception is always the IOEnv built-in
988 -- in exception; see IOEnv.failM
989 }
990
991 -- (askNoErrs m) runs m
992 -- If m fails, (askNoErrs m) fails
993 -- If m succeeds with result r, (askNoErrs m) succeeds with result (r, b),
994 -- where b is True iff m generated no errors
995 -- Regardless of success or failure, any errors generated by m are propagated
996 askNoErrs :: TcRn a -> TcRn (a, Bool)
997 askNoErrs m
998 = do { errs_var <- newTcRef emptyMessages
999 ; res <- setErrsVar errs_var m
1000 ; (warns, errs) <- readTcRef errs_var
1001 ; addMessages (warns, errs)
1002 ; return (res, isEmptyBag errs) }
1003
1004 discardErrs :: TcRn a -> TcRn a
1005 -- (discardErrs m) runs m,
1006 -- discarding all error messages and warnings generated by m
1007 -- If m fails, discardErrs fails, and vice versa
1008 discardErrs m
1009 = do { errs_var <- newTcRef emptyMessages
1010 ; setErrsVar errs_var m }
1011
1012 -----------------------
1013 tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
1014 -- Run the thing, returning
1015 -- Just r, if m succceeds with no error messages
1016 -- Nothing, if m fails, or if it succeeds but has error messages
1017 -- Either way, the messages are returned;
1018 -- even in the Just case there might be warnings
1019 tryTcErrs thing
1020 = do { (msgs, res) <- tryTc thing
1021 ; dflags <- getDynFlags
1022 ; let errs_found = errorsFound dflags msgs
1023 ; return (msgs, case res of
1024 Nothing -> Nothing
1025 Just val | errs_found -> Nothing
1026 | otherwise -> Just val)
1027 }
1028
1029 -----------------------
1030 tryTcLIE_ :: TcM r -> TcM r -> TcM r
1031 -- (tryTcLIE_ r m) tries m;
1032 -- if m succeeds with no error messages, it's the answer
1033 -- otherwise tryTcLIE_ drops everything from m and tries r instead.
1034 tryTcLIE_ recover main
1035 = do { (msgs, mb_res) <- tryTcErrs main
1036 ; case mb_res of
1037 Just val -> do { addMessages msgs -- There might be warnings
1038 ; return val }
1039 Nothing -> recover -- Discard all msgs
1040 }
1041
1042 -----------------------
1043 checkNoErrs :: TcM r -> TcM r
1044 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
1045 -- If m fails then (checkNoErrsTc m) fails.
1046 -- If m succeeds, it checks whether m generated any errors messages
1047 -- (it might have recovered internally)
1048 -- If so, it fails too.
1049 -- Regardless, any errors generated by m are propagated to the enclosing context.
1050 checkNoErrs main
1051 = do { (msgs, mb_res) <- tryTcErrs main
1052 ; addMessages msgs
1053 ; case mb_res of
1054 Nothing -> failM
1055 Just val -> return val
1056 }
1057
1058 whenNoErrs :: TcM () -> TcM ()
1059 whenNoErrs thing = ifErrsM (return ()) thing
1060
1061 ifErrsM :: TcRn r -> TcRn r -> TcRn r
1062 -- ifErrsM bale_out normal
1063 -- does 'bale_out' if there are errors in errors collection
1064 -- otherwise does 'normal'
1065 ifErrsM bale_out normal
1066 = do { errs_var <- getErrsVar ;
1067 msgs <- readTcRef errs_var ;
1068 dflags <- getDynFlags ;
1069 if errorsFound dflags msgs then
1070 bale_out
1071 else
1072 normal }
1073
1074 failIfErrsM :: TcRn ()
1075 -- Useful to avoid error cascades
1076 failIfErrsM = ifErrsM failM (return ())
1077
1078 #ifdef GHCI
1079 checkTH :: a -> String -> TcRn ()
1080 checkTH _ _ = return () -- OK
1081 #else
1082 checkTH :: Outputable a => a -> String -> TcRn ()
1083 checkTH e what = failTH e what -- Raise an error in a stage-1 compiler
1084 #endif
1085
1086 failTH :: Outputable a => a -> String -> TcRn x
1087 failTH e what -- Raise an error in a stage-1 compiler
1088 = failWithTc (vcat [ hang (char 'A' <+> text what
1089 <+> text "requires GHC with interpreter support:")
1090 2 (ppr e)
1091 , text "Perhaps you are using a stage-1 compiler?" ])
1092
1093 {- Note [Constraints and errors]
1094 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1095 Consider this (Trac #12124):
1096
1097 foo :: Maybe Int
1098 foo = return (case Left 3 of
1099 Left -> 1 -- Error here!
1100 _ -> 0)
1101
1102 The call to 'return' will generate a (Monad m) wanted constraint; but
1103 then there'll be "hard error" (i.e. an exception in the TcM monad).
1104 We'll recover in tcPolyBinds, using recoverM. But then the final
1105 tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly
1106 un-filled-in, and will emit a misleading error message.
1107
1108 The underlying problem is that an exception interrupts the connstraint
1109 gathering process. Bottom line: if we have an exception, it's best
1110 simply to discard any gathered constraints. Hence in 'try_m' we
1111 capture the constraints in a fresh variable, and only emit them into
1112 the surrounding context if we exit normally. If an exception is
1113 raised, simply discard the collected constraints... we have a hard
1114 error to report. So this capture-the-emit dance isn't as stupid as it
1115 looks :-).
1116
1117 ************************************************************************
1118 * *
1119 Context management for the type checker
1120 * *
1121 ************************************************************************
1122 -}
1123
1124 getErrCtxt :: TcM [ErrCtxt]
1125 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
1126
1127 setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
1128 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
1129
1130 -- | Add a fixed message to the error context. This message should not
1131 -- do any tidying.
1132 addErrCtxt :: MsgDoc -> TcM a -> TcM a
1133 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
1134
1135 -- | Add a message to the error context. This message may do tidying.
1136 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
1137 addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
1138
1139 -- | Add a fixed landmark message to the error context. A landmark
1140 -- message is always sure to be reported, even if there is a lot of
1141 -- context. It also doesn't count toward the maximum number of contexts
1142 -- reported.
1143 addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
1144 addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
1145
1146 -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
1147 -- and tidying.
1148 addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
1149 addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts)
1150
1151 -- Helper function for the above
1152 updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
1153 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
1154 env { tcl_ctxt = upd ctxt })
1155
1156 popErrCtxt :: TcM a -> TcM a
1157 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
1158
1159 getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
1160 getCtLocM origin t_or_k
1161 = do { env <- getLclEnv
1162 ; return (CtLoc { ctl_origin = origin
1163 , ctl_env = env
1164 , ctl_t_or_k = t_or_k
1165 , ctl_depth = initialSubGoalDepth }) }
1166
1167 setCtLocM :: CtLoc -> TcM a -> TcM a
1168 -- Set the SrcSpan and error context from the CtLoc
1169 setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
1170 = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
1171 , tcl_bndrs = tcl_bndrs lcl
1172 , tcl_ctxt = tcl_ctxt lcl })
1173 thing_inside
1174
1175 {-
1176 ************************************************************************
1177 * *
1178 Error message generation (type checker)
1179 * *
1180 ************************************************************************
1181
1182 The addErrTc functions add an error message, but do not cause failure.
1183 The 'M' variants pass a TidyEnv that has already been used to
1184 tidy up the message; we then use it to tidy the context messages
1185 -}
1186
1187 addErrTc :: MsgDoc -> TcM ()
1188 addErrTc err_msg = do { env0 <- tcInitTidyEnv
1189 ; addErrTcM (env0, err_msg) }
1190
1191 addErrsTc :: [MsgDoc] -> TcM ()
1192 addErrsTc err_msgs = mapM_ addErrTc err_msgs
1193
1194 addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()
1195 addErrTcM (tidy_env, err_msg)
1196 = do { ctxt <- getErrCtxt ;
1197 loc <- getSrcSpanM ;
1198 add_err_tcm tidy_env err_msg loc ctxt }
1199
1200 -- Return the error message, instead of reporting it straight away
1201 mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg
1202 mkErrTcM (tidy_env, err_msg)
1203 = do { ctxt <- getErrCtxt ;
1204 loc <- getSrcSpanM ;
1205 err_info <- mkErrInfo tidy_env ctxt ;
1206 mkLongErrAt loc err_msg err_info }
1207
1208 -- The failWith functions add an error message and cause failure
1209
1210 failWithTc :: MsgDoc -> TcM a -- Add an error message and fail
1211 failWithTc err_msg
1212 = addErrTc err_msg >> failM
1213
1214 failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail
1215 failWithTcM local_and_msg
1216 = addErrTcM local_and_msg >> failM
1217
1218 checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true
1219 checkTc True _ = return ()
1220 checkTc False err = failWithTc err
1221
1222 checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
1223 checkTcM True _ = return ()
1224 checkTcM False err = failWithTcM err
1225
1226 failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false
1227 failIfTc False _ = return ()
1228 failIfTc True err = failWithTc err
1229
1230 failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
1231 -- Check that the boolean is false
1232 failIfTcM False _ = return ()
1233 failIfTcM True err = failWithTcM err
1234
1235
1236 -- Warnings have no 'M' variant, nor failure
1237
1238 -- | Display a warning if a condition is met.
1239 -- and the warning is enabled
1240 warnIf :: WarnReason -> Bool -> MsgDoc -> TcRn ()
1241 warnIf reason is_bad msg
1242 = do { warn_on <- case reason of
1243 NoReason -> return True
1244 Reason warn_flag -> woptM warn_flag
1245 ; when (warn_on && is_bad) $
1246 addWarn reason msg }
1247
1248 -- | Display a warning if a condition is met.
1249 warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()
1250 warnTc reason warn_if_true warn_msg
1251 | warn_if_true = addWarnTc reason warn_msg
1252 | otherwise = return ()
1253
1254 -- | Display a warning if a condition is met.
1255 warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()
1256 warnTcM reason warn_if_true warn_msg
1257 | warn_if_true = addWarnTcM reason warn_msg
1258 | otherwise = return ()
1259
1260 -- | Display a warning in the current context.
1261 addWarnTc :: WarnReason -> MsgDoc -> TcM ()
1262 addWarnTc reason msg
1263 = do { env0 <- tcInitTidyEnv ;
1264 addWarnTcM reason (env0, msg) }
1265
1266 -- | Display a warning in a given context.
1267 addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()
1268 addWarnTcM reason (env0, msg)
1269 = do { ctxt <- getErrCtxt ;
1270 err_info <- mkErrInfo env0 ctxt ;
1271 add_warn reason msg err_info }
1272
1273 -- | Display a warning for the current source location.
1274 addWarn :: WarnReason -> MsgDoc -> TcRn ()
1275 addWarn reason msg = add_warn reason msg Outputable.empty
1276
1277 -- | Display a warning for a given source location.
1278 addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
1279 addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty
1280
1281 -- | Display a warning, with an optional flag, for the current source
1282 -- location.
1283 add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()
1284 add_warn reason msg extra_info
1285 = do { loc <- getSrcSpanM
1286 ; add_warn_at reason loc msg extra_info }
1287
1288 -- | Display a warning, with an optional flag, for a given location.
1289 add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
1290 add_warn_at reason loc msg extra_info
1291 = do { dflags <- getDynFlags ;
1292 printer <- getPrintUnqualified dflags ;
1293 let { warn = mkLongWarnMsg dflags loc printer
1294 msg extra_info } ;
1295 reportWarning reason warn }
1296
1297 tcInitTidyEnv :: TcM TidyEnv
1298 tcInitTidyEnv
1299 = do { lcl_env <- getLclEnv
1300 ; return (tcl_tidy lcl_env) }
1301
1302 -- | Get a 'TidyEnv' that includes mappings for all vars free in the given
1303 -- type. Useful when tidying open types.
1304 tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
1305 tcInitOpenTidyEnv tvs
1306 = do { env1 <- tcInitTidyEnv
1307 ; let env2 = tidyFreeTyCoVars env1 tvs
1308 ; return env2 }
1309
1310
1311 {-
1312 -----------------------------------
1313 Other helper functions
1314 -}
1315
1316 add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan
1317 -> [ErrCtxt]
1318 -> TcM ()
1319 add_err_tcm tidy_env err_msg loc ctxt
1320 = do { err_info <- mkErrInfo tidy_env ctxt ;
1321 addLongErrAt loc err_msg err_info }
1322
1323 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
1324 -- Tidy the error info, trimming excessive contexts
1325 mkErrInfo env ctxts
1326 -- | opt_PprStyle_Debug -- In -dppr-debug style the output
1327 -- = return empty -- just becomes too voluminous
1328 | otherwise
1329 = go 0 env ctxts
1330 where
1331 go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
1332 go _ _ [] = return empty
1333 go n env ((is_landmark, ctxt) : ctxts)
1334 | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug
1335 = do { (env', msg) <- ctxt env
1336 ; let n' = if is_landmark then n else n+1
1337 ; rest <- go n' env' ctxts
1338 ; return (msg $$ rest) }
1339 | otherwise
1340 = go n env ctxts
1341
1342 mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts
1343 mAX_CONTEXTS = 3
1344
1345 -- debugTc is useful for monadic debugging code
1346
1347 debugTc :: TcM () -> TcM ()
1348 debugTc thing
1349 | debugIsOn = thing
1350 | otherwise = return ()
1351
1352 {-
1353 ************************************************************************
1354 * *
1355 Type constraints
1356 * *
1357 ************************************************************************
1358 -}
1359
1360 newTcEvBinds :: TcM EvBindsVar
1361 newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
1362 ; uniq <- newUnique
1363 ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
1364 ; return (EvBindsVar ref uniq) }
1365
1366 addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
1367 -- Add a binding to the TcEvBinds by side effect
1368 addTcEvBind (EvBindsVar ev_ref u) ev_bind
1369 = do { traceTc "addTcEvBind" $ ppr u $$
1370 ppr ev_bind
1371 ; bnds <- readTcRef ev_ref
1372 ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
1373
1374 getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind)
1375 getTcEvBinds (EvBindsVar ev_ref _)
1376 = do { bnds <- readTcRef ev_ref
1377 ; return (evBindMapBinds bnds) }
1378
1379 getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
1380 getTcEvBindsMap (EvBindsVar ev_ref _)
1381 = readTcRef ev_ref
1382
1383 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
1384 chooseUniqueOccTc fn =
1385 do { env <- getGblEnv
1386 ; let dfun_n_var = tcg_dfun_n env
1387 ; set <- readTcRef dfun_n_var
1388 ; let occ = fn set
1389 ; writeTcRef dfun_n_var (extendOccSet set occ)
1390 ; return occ }
1391
1392 getConstraintVar :: TcM (TcRef WantedConstraints)
1393 getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
1394
1395 setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
1396 setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
1397
1398 emitConstraints :: WantedConstraints -> TcM ()
1399 emitConstraints ct
1400 = do { lie_var <- getConstraintVar ;
1401 updTcRef lie_var (`andWC` ct) }
1402
1403 emitSimple :: Ct -> TcM ()
1404 emitSimple ct
1405 = do { lie_var <- getConstraintVar ;
1406 updTcRef lie_var (`addSimples` unitBag ct) }
1407
1408 emitSimples :: Cts -> TcM ()
1409 emitSimples cts
1410 = do { lie_var <- getConstraintVar ;
1411 updTcRef lie_var (`addSimples` cts) }
1412
1413 emitImplication :: Implication -> TcM ()
1414 emitImplication ct
1415 = do { lie_var <- getConstraintVar ;
1416 updTcRef lie_var (`addImplics` unitBag ct) }
1417
1418 emitImplications :: Bag Implication -> TcM ()
1419 emitImplications ct
1420 = unless (isEmptyBag ct) $
1421 do { lie_var <- getConstraintVar ;
1422 updTcRef lie_var (`addImplics` ct) }
1423
1424 emitInsoluble :: Ct -> TcM ()
1425 emitInsoluble ct
1426 = do { lie_var <- getConstraintVar ;
1427 updTcRef lie_var (`addInsols` unitBag ct) ;
1428 v <- readTcRef lie_var ;
1429 traceTc "emitInsoluble" (ppr v) }
1430
1431 emitInsolubles :: [Ct] -> TcM ()
1432 emitInsolubles cts
1433 = do { lie_var <- getConstraintVar ;
1434 updTcRef lie_var (`addInsols` listToBag cts) ;
1435 v <- readTcRef lie_var ;
1436 traceTc "emitInsoluble" (ppr v) }
1437
1438 -- | Throw out any constraints emitted by the thing_inside
1439 discardConstraints :: TcM a -> TcM a
1440 discardConstraints thing_inside = fst <$> captureConstraints thing_inside
1441
1442 captureConstraints :: TcM a -> TcM (a, WantedConstraints)
1443 -- (captureConstraints m) runs m, and returns the type constraints it generates
1444 captureConstraints thing_inside
1445 = do { lie_var <- newTcRef emptyWC ;
1446 res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
1447 thing_inside ;
1448 lie <- readTcRef lie_var ;
1449 return (res, lie) }
1450
1451 pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
1452 pushLevelAndCaptureConstraints thing_inside
1453 = do { env <- getLclEnv
1454 ; lie_var <- newTcRef emptyWC
1455 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1456 ; res <- setLclEnv (env { tcl_tclvl = tclvl'
1457 , tcl_lie = lie_var })
1458 thing_inside
1459 ; lie <- readTcRef lie_var
1460 ; return (tclvl', lie, res) }
1461
1462 pushTcLevelM_ :: TcM a -> TcM a
1463 pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
1464
1465 pushTcLevelM :: TcM a -> TcM (a, TcLevel)
1466 -- See Note [TcLevel assignment]
1467 pushTcLevelM thing_inside
1468 = do { env <- getLclEnv
1469 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1470 ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
1471 thing_inside
1472 ; return (res, tclvl') }
1473
1474 getTcLevel :: TcM TcLevel
1475 getTcLevel = do { env <- getLclEnv
1476 ; return (tcl_tclvl env) }
1477
1478 setTcLevel :: TcLevel -> TcM a -> TcM a
1479 setTcLevel tclvl thing_inside
1480 = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
1481
1482 isTouchableTcM :: TcTyVar -> TcM Bool
1483 isTouchableTcM tv
1484 = do { env <- getLclEnv
1485 ; return (isTouchableMetaTyVar (tcl_tclvl env) tv) }
1486
1487 getLclTypeEnv :: TcM TcTypeEnv
1488 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
1489
1490 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
1491 -- Set the local type envt, but do *not* disturb other fields,
1492 -- notably the lie_var
1493 setLclTypeEnv lcl_env thing_inside
1494 = updLclEnv upd thing_inside
1495 where
1496 upd env = env { tcl_env = tcl_env lcl_env,
1497 tcl_tyvars = tcl_tyvars lcl_env }
1498
1499 traceTcConstraints :: String -> TcM ()
1500 traceTcConstraints msg
1501 = do { lie_var <- getConstraintVar
1502 ; lie <- readTcRef lie_var
1503 ; traceTc (msg ++ ": LIE:") (ppr lie)
1504 }
1505
1506 emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
1507 emitWildCardHoleConstraints wcs
1508 = do { ct_loc <- getCtLocM HoleOrigin Nothing
1509 ; emitInsolubles (map (do_one ct_loc) wcs) }
1510 where
1511 do_one :: CtLoc -> (Name, TcTyVar) -> Ct
1512 do_one ct_loc (name, tv)
1513 = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv
1514 , ctev_loc = ct_loc' }
1515 , cc_hole = TypeHole (occName name) }
1516 where
1517 real_span = case nameSrcSpan name of
1518 RealSrcSpan span -> span
1519 UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints"
1520 (ppr name <+> quotes (ftext str))
1521 -- Wildcards are defined locally, and so have RealSrcSpans
1522 ct_loc' = setCtLocSpan ct_loc real_span
1523
1524 {-
1525 ************************************************************************
1526 * *
1527 Template Haskell context
1528 * *
1529 ************************************************************************
1530 -}
1531
1532 recordThUse :: TcM ()
1533 recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
1534
1535 recordThSpliceUse :: TcM ()
1536 recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
1537
1538 -- | When generating an out-of-scope error message for a variable matching a
1539 -- binding in a later inter-splice group, the typechecker uses the splice
1540 -- locations to provide details in the message about the scope of that binding.
1541 recordTopLevelSpliceLoc :: SrcSpan -> TcM ()
1542 recordTopLevelSpliceLoc (RealSrcSpan real_loc)
1543 = do { env <- getGblEnv
1544 ; let locs_var = tcg_th_top_level_locs env
1545 ; locs0 <- readTcRef locs_var
1546 ; writeTcRef locs_var (Set.insert real_loc locs0) }
1547 recordTopLevelSpliceLoc (UnhelpfulSpan _) = return ()
1548
1549 getTopLevelSpliceLocs :: TcM (Set RealSrcSpan)
1550 getTopLevelSpliceLocs
1551 = do { env <- getGblEnv
1552 ; readTcRef (tcg_th_top_level_locs env) }
1553
1554 keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set
1555 keepAlive name
1556 = do { env <- getGblEnv
1557 ; traceRn (text "keep alive" <+> ppr name)
1558 ; updTcRef (tcg_keep env) (`extendNameSet` name) }
1559
1560 getStage :: TcM ThStage
1561 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
1562
1563 getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
1564 getStageAndBindLevel name
1565 = do { env <- getLclEnv;
1566 ; case lookupNameEnv (tcl_th_bndrs env) name of
1567 Nothing -> return Nothing
1568 Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
1569
1570 setStage :: ThStage -> TcM a -> TcRn a
1571 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
1572
1573 #ifdef GHCI
1574 -- | Adds the given modFinalizers to the global environment and set them to use
1575 -- the current local environment.
1576 addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
1577 addModFinalizersWithLclEnv mod_finalizers
1578 = do lcl_env <- getLclEnv
1579 th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
1580 updTcRef th_modfinalizers_var $ \fins ->
1581 setLclEnv lcl_env (runRemoteModFinalizers mod_finalizers)
1582 : fins
1583 #else
1584 addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
1585 addModFinalizersWithLclEnv ThModFinalizers = return ()
1586 #endif
1587
1588 {-
1589 ************************************************************************
1590 * *
1591 Safe Haskell context
1592 * *
1593 ************************************************************************
1594 -}
1595
1596 -- | Mark that safe inference has failed
1597 -- See Note [Safe Haskell Overlapping Instances Implementation]
1598 -- although this is used for more than just that failure case.
1599 recordUnsafeInfer :: WarningMessages -> TcM ()
1600 recordUnsafeInfer warns =
1601 getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)
1602
1603 -- | Figure out the final correct safe haskell mode
1604 finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
1605 finalSafeMode dflags tcg_env = do
1606 safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)
1607 return $ case safeHaskell dflags of
1608 Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
1609 | otherwise -> Sf_None
1610 s -> s
1611
1612 -- | Switch instances to safe instances if we're in Safe mode.
1613 fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
1614 fixSafeInstances sfMode | sfMode /= Sf_Safe = id
1615 fixSafeInstances _ = map fixSafe
1616 where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
1617 in inst { is_flag = new_flag }
1618
1619 {-
1620 ************************************************************************
1621 * *
1622 Stuff for the renamer's local env
1623 * *
1624 ************************************************************************
1625 -}
1626
1627 getLocalRdrEnv :: RnM LocalRdrEnv
1628 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
1629
1630 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
1631 setLocalRdrEnv rdr_env thing_inside
1632 = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
1633
1634 {-
1635 ************************************************************************
1636 * *
1637 Stuff for interface decls
1638 * *
1639 ************************************************************************
1640 -}
1641
1642 mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv
1643 mkIfLclEnv mod loc boot
1644 = IfLclEnv { if_mod = mod,
1645 if_loc = loc,
1646 if_boot = boot,
1647 if_nsubst = Nothing,
1648 if_tv_env = emptyFsEnv,
1649 if_id_env = emptyFsEnv }
1650
1651 -- | Run an 'IfG' (top-level interface monad) computation inside an existing
1652 -- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
1653 -- based on 'TcGblEnv'.
1654 initIfaceTcRn :: IfG a -> TcRn a
1655 initIfaceTcRn thing_inside
1656 = do { tcg_env <- getGblEnv
1657 ; dflags <- getDynFlags
1658 ; let mod = tcg_semantic_mod tcg_env
1659 -- When we are instantiating a signature, we DEFINITELY
1660 -- do not want to knot tie.
1661 is_instantiate = unitIdIsDefinite (thisPackage dflags) &&
1662 not (null (thisUnitIdInsts dflags))
1663 ; let { if_env = IfGblEnv {
1664 if_doc = text "initIfaceTcRn",
1665 if_rec_types =
1666 if is_instantiate
1667 then Nothing
1668 else Just (mod, get_type_env)
1669 }
1670 ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
1671 ; setEnvs (if_env, ()) thing_inside }
1672
1673 -- Used when sucking in a ModIface into a ModDetails to put in
1674 -- the HPT. Notably, unlike initIfaceCheck, this does NOT use
1675 -- hsc_type_env_var (since we're not actually going to typecheck,
1676 -- so this variable will never get updated!)
1677 initIfaceLoad :: HscEnv -> IfG a -> IO a
1678 initIfaceLoad hsc_env do_this
1679 = do let gbl_env = IfGblEnv {
1680 if_doc = text "initIfaceLoad",
1681 if_rec_types = Nothing
1682 }
1683 initTcRnIf 'i' hsc_env gbl_env () do_this
1684
1685 initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a
1686 -- Used when checking the up-to-date-ness of the old Iface
1687 -- Initialise the environment with no useful info at all
1688 initIfaceCheck doc hsc_env do_this
1689 = do let rec_types = case hsc_type_env_var hsc_env of
1690 Just (mod,var) -> Just (mod, readTcRef var)
1691 Nothing -> Nothing
1692 gbl_env = IfGblEnv {
1693 if_doc = text "initIfaceCheck" <+> doc,
1694 if_rec_types = rec_types
1695 }
1696 initTcRnIf 'i' hsc_env gbl_env () do_this
1697
1698 initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a
1699 initIfaceLcl mod loc_doc hi_boot_file thing_inside
1700 = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside
1701
1702 -- | Initialize interface typechecking, but with a 'NameShape'
1703 -- to apply when typechecking top-level 'OccName's (see
1704 -- 'lookupIfaceTop')
1705 initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a
1706 initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside
1707 = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside
1708
1709 getIfModule :: IfL Module
1710 getIfModule = do { env <- getLclEnv; return (if_mod env) }
1711
1712 --------------------
1713 failIfM :: MsgDoc -> IfL a
1714 -- The Iface monad doesn't have a place to accumulate errors, so we
1715 -- just fall over fast if one happens; it "shouldnt happen".
1716 -- We use IfL here so that we can get context info out of the local env
1717 failIfM msg
1718 = do { env <- getLclEnv
1719 ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1720 ; dflags <- getDynFlags
1721 ; liftIO (log_action dflags dflags NoReason SevFatal
1722 noSrcSpan (defaultErrStyle dflags) full_msg)
1723 ; failM }
1724
1725 --------------------
1726 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1727 -- Run thing_inside in an interleaved thread.
1728 -- It shares everything with the parent thread, so this is DANGEROUS.
1729 --
1730 -- It returns Nothing if the computation fails
1731 --
1732 -- It's used for lazily type-checking interface
1733 -- signatures, which is pretty benign
1734
1735 forkM_maybe doc thing_inside
1736 -- NB: Don't share the mutable env_us with the interleaved thread since env_us
1737 -- does not get updated atomically (e.g. in newUnique and newUniqueSupply).
1738 = do { child_us <- newUniqueSupply
1739 ; child_env_us <- newMutVar child_us
1740 -- see Note [Masking exceptions in forkM_maybe]
1741 ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $
1742 do { traceIf (text "Starting fork {" <+> doc)
1743 ; mb_res <- tryM $
1744 updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1745 thing_inside
1746 ; case mb_res of
1747 Right r -> do { traceIf (text "} ending fork" <+> doc)
1748 ; return (Just r) }
1749 Left exn -> do {
1750
1751 -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1752 -- Otherwise we silently discard errors. Errors can legitimately
1753 -- happen when compiling interface signatures (see tcInterfaceSigs)
1754 whenDOptM Opt_D_dump_if_trace $ do
1755 dflags <- getDynFlags
1756 let msg = hang (text "forkM failed:" <+> doc)
1757 2 (text (show exn))
1758 liftIO $ log_action dflags
1759 dflags
1760 NoReason
1761 SevFatal
1762 noSrcSpan
1763 (defaultErrStyle dflags)
1764 msg
1765
1766 ; traceIf (text "} ending fork (badly)" <+> doc)
1767 ; return Nothing }
1768 }}
1769
1770 forkM :: SDoc -> IfL a -> IfL a
1771 forkM doc thing_inside
1772 = do { mb_res <- forkM_maybe doc thing_inside
1773 ; return (case mb_res of
1774 Nothing -> pgmError "Cannot continue after interface file error"
1775 -- pprPanic "forkM" doc
1776 Just r -> r) }
1777
1778 {-
1779 Note [Masking exceptions in forkM_maybe]
1780 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1781
1782 When using GHC-as-API it must be possible to interrupt snippets of code
1783 executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
1784 by throwing an asynchronous interrupt to the GHC thread. However, there is a
1785 subtle problem: runStmt first typechecks the code before running it, and the
1786 exception might interrupt the type checker rather than the code. Moreover, the
1787 typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
1788 more importantly might be inside an exception handler inside that
1789 unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
1790 asynchronous exception as a synchronous exception, and the exception will end
1791 up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
1792 discussion). We don't currently know a general solution to this problem, but
1793 we can use uninterruptibleMask_ to avoid the situation.
1794 -}