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