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