2b73812de04bedf07bdb14fe8deb3e7f37fc6bfd
[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, whenXOptM,
23 getGhcMode,
24 withDoDynamicToo,
25 getEpsVar,
26 getEps,
27 updateEps, updateEps_,
28 getHpt, getEpsAndHpt,
29
30 -- * Arrow scopes
31 newArrowScope, escapeArrowScope,
32
33 -- * Unique supply
34 newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName,
35 newSysName, newSysLocalId, newSysLocalIds,
36
37 -- * Accessing input/output
38 newTcRef, readTcRef, writeTcRef, updTcRef,
39
40 -- * Debugging
41 traceTc, traceRn, traceOptTcRn, traceTcRn,
42 getPrintUnqualified,
43 printForUserTcRn,
44 traceIf, traceHiDiffs, traceOptIf,
45 debugTc,
46
47 -- * Typechecker global environment
48 getIsGHCi, getGHCiMonad, getInteractivePrintName,
49 tcIsHsBootOrSig, tcSelfBootInfo, getGlobalRdrEnv,
50 getRdrEnvs, getImports,
51 getFixityEnv, extendFixityEnv, getRecFieldEnv,
52 getDeclaredDefaultTys,
53 addDependentFiles,
54
55 -- * Error management
56 getSrcSpanM, setSrcSpan, addLocM,
57 wrapLocM, wrapLocFstM, wrapLocSndM,
58 getErrsVar, setErrsVar,
59 addErr,
60 failWith, failAt,
61 addErrAt, addErrs,
62 checkErr,
63 addMessages,
64 discardWarnings,
65
66 -- * Shared error message stuff: renamer and typechecker
67 mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,
68 reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
69 tryTc,
70 askNoErrs, discardErrs,
71 tryTcErrs, tryTcLIE_,
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,
83 failWithTc, failWithTcM,
84 checkTc, checkTcM,
85 failIfTc, failIfTcM,
86 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 getGhcMode :: TcRnIf gbl lcl GhcMode
504 getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
505
506 withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
507 withDoDynamicToo =
508 updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->
509 top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags })
510
511 getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
512 getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
513
514 getEps :: TcRnIf gbl lcl ExternalPackageState
515 getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
516
517 -- | Update the external package state. Returns the second result of the
518 -- modifier function.
519 --
520 -- This is an atomic operation and forces evaluation of the modified EPS in
521 -- order to avoid space leaks.
522 updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
523 -> TcRnIf gbl lcl a
524 updateEps upd_fn = do
525 traceIf (text "updating EPS")
526 eps_var <- getEpsVar
527 atomicUpdMutVar' eps_var upd_fn
528
529 -- | Update the external package state.
530 --
531 -- This is an atomic operation and forces evaluation of the modified EPS in
532 -- order to avoid space leaks.
533 updateEps_ :: (ExternalPackageState -> ExternalPackageState)
534 -> TcRnIf gbl lcl ()
535 updateEps_ upd_fn = do
536 traceIf (text "updating EPS_")
537 eps_var <- getEpsVar
538 atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
539
540 getHpt :: TcRnIf gbl lcl HomePackageTable
541 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
542
543 getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
544 getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
545 ; return (eps, hsc_HPT env) }
546
547 -- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing
548 -- an exception if it is an error.
549 withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a
550 withException do_this = do
551 r <- do_this
552 dflags <- getDynFlags
553 case r of
554 Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err))
555 Succeeded result -> return result
556
557 {-
558 ************************************************************************
559 * *
560 Arrow scopes
561 * *
562 ************************************************************************
563 -}
564
565 newArrowScope :: TcM a -> TcM a
566 newArrowScope
567 = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }
568
569 -- Return to the stored environment (from the enclosing proc)
570 escapeArrowScope :: TcM a -> TcM a
571 escapeArrowScope
572 = updLclEnv $ \ env ->
573 case tcl_arrow_ctxt env of
574 NoArrowCtxt -> env
575 ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
576 , tcl_lie = lie
577 , tcl_rdr = rdr_env }
578
579 {-
580 ************************************************************************
581 * *
582 Unique supply
583 * *
584 ************************************************************************
585 -}
586
587 newUnique :: TcRnIf gbl lcl Unique
588 newUnique
589 = do { env <- getEnv ;
590 let { u_var = env_us env } ;
591 us <- readMutVar u_var ;
592 case takeUniqFromSupply us of { (uniq, us') -> do {
593 writeMutVar u_var us' ;
594 return $! uniq }}}
595 -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
596 -- a chain of unevaluated supplies behind.
597 -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
598 -- throw away one half of the new split supply. This is safe because this
599 -- is the only place we use that unique. Using the other half of the split
600 -- supply is safer, but slower.
601
602 newUniqueSupply :: TcRnIf gbl lcl UniqSupply
603 newUniqueSupply
604 = do { env <- getEnv ;
605 let { u_var = env_us env } ;
606 us <- readMutVar u_var ;
607 case splitUniqSupply us of { (us1,us2) -> do {
608 writeMutVar u_var us1 ;
609 return us2 }}}
610
611 cloneLocalName :: Name -> TcM Name
612 -- Make a fresh Internal name with the same OccName and SrcSpan
613 cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name)
614
615 newName :: OccName -> TcM Name
616 newName occ = do { loc <- getSrcSpanM
617 ; newNameAt occ loc }
618
619 newNameAt :: OccName -> SrcSpan -> TcM Name
620 newNameAt occ span
621 = do { uniq <- newUnique
622 ; return (mkInternalName uniq occ span) }
623
624 newSysName :: OccName -> TcRnIf gbl lcl Name
625 newSysName occ
626 = do { uniq <- newUnique
627 ; return (mkSystemName uniq occ) }
628
629 newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
630 newSysLocalId fs ty
631 = do { u <- newUnique
632 ; return (mkSysLocalOrCoVar fs u ty) }
633
634 newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
635 newSysLocalIds fs tys
636 = do { us <- newUniqueSupply
637 ; return (zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys) }
638
639 instance MonadUnique (IOEnv (Env gbl lcl)) where
640 getUniqueM = newUnique
641 getUniqueSupplyM = newUniqueSupply
642
643 {-
644 ************************************************************************
645 * *
646 Accessing input/output
647 * *
648 ************************************************************************
649 -}
650
651 newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
652 newTcRef = newMutVar
653
654 readTcRef :: TcRef a -> TcRnIf gbl lcl a
655 readTcRef = readMutVar
656
657 writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
658 writeTcRef = writeMutVar
659
660 updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
661 -- Returns ()
662 updTcRef ref fn = liftIO $ do { old <- readIORef ref
663 ; writeIORef ref (fn old) }
664
665 {-
666 ************************************************************************
667 * *
668 Debugging
669 * *
670 ************************************************************************
671 -}
672
673
674 -- Typechecker trace
675 traceTc :: String -> SDoc -> TcRn ()
676 traceTc =
677 labelledTraceOptTcRn Opt_D_dump_tc_trace
678
679 -- Renamer Trace
680 traceRn :: String -> SDoc -> TcRn ()
681 traceRn =
682 labelledTraceOptTcRn Opt_D_dump_rn_trace
683
684 -- | Trace when a certain flag is enabled. This is like `traceOptTcRn`
685 -- but accepts a string as a label and formats the trace message uniformly.
686 labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn ()
687 labelledTraceOptTcRn flag herald doc = do
688 traceOptTcRn flag (formatTraceMsg herald doc)
689
690 formatTraceMsg :: String -> SDoc -> SDoc
691 formatTraceMsg herald doc = hang (text herald) 2 doc
692
693 -- | Output a doc if the given 'DumpFlag' is set.
694 --
695 -- By default this logs to stdout
696 -- However, if the `-ddump-to-file` flag is set,
697 -- then this will dump output to a file
698 --
699 -- Just a wrapper for 'dumpSDoc'
700 traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
701 traceOptTcRn flag doc
702 = do { dflags <- getDynFlags
703 ; when (dopt flag dflags)
704 (traceTcRn flag doc)
705 }
706
707
708 traceTcRn :: DumpFlag -> SDoc -> TcRn ()
709 -- ^ Unconditionally dump some trace output
710 --
711 -- The DumpFlag is used only to set the output filename
712 -- for --dump-to-file, not to decide whether or not to output
713 -- That part is done by the caller
714 traceTcRn flag doc
715 = do { dflags <- getDynFlags
716 ; real_doc <- prettyDoc dflags doc
717 ; printer <- getPrintUnqualified dflags
718 ; liftIO $ dumpSDoc dflags printer flag "" real_doc }
719 where
720 -- Add current location if -dppr-debug
721 prettyDoc :: DynFlags -> SDoc -> TcRn SDoc
722 prettyDoc dflags doc = if hasPprDebug dflags
723 then do { loc <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }
724 else return doc -- The full location is usually way too much
725
726
727 getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
728 getPrintUnqualified dflags
729 = do { rdr_env <- getGlobalRdrEnv
730 ; return $ mkPrintUnqualified dflags rdr_env }
731
732 -- | Like logInfoTcRn, but for user consumption
733 printForUserTcRn :: SDoc -> TcRn ()
734 printForUserTcRn doc
735 = do { dflags <- getDynFlags
736 ; printer <- getPrintUnqualified dflags
737 ; liftIO (printOutputForUser dflags printer doc) }
738
739 {-
740 traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
741 available. Alas, they behave inconsistently with the other stuff;
742 e.g. are unaffected by -dump-to-file.
743 -}
744
745 traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
746 traceIf = traceOptIf Opt_D_dump_if_trace
747 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
748
749
750 traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
751 traceOptIf flag doc
752 = whenDOptM flag $ -- No RdrEnv available, so qualify everything
753 do { dflags <- getDynFlags
754 ; liftIO (putMsg dflags doc) }
755
756 {-
757 ************************************************************************
758 * *
759 Typechecker global environment
760 * *
761 ************************************************************************
762 -}
763
764 getIsGHCi :: TcRn Bool
765 getIsGHCi = do { mod <- getModule
766 ; return (isInteractiveModule mod) }
767
768 getGHCiMonad :: TcRn Name
769 getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
770
771 getInteractivePrintName :: TcRn Name
772 getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }
773
774 tcIsHsBootOrSig :: TcRn Bool
775 tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
776
777 tcSelfBootInfo :: TcRn SelfBootInfo
778 tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }
779
780 getGlobalRdrEnv :: TcRn GlobalRdrEnv
781 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
782
783 getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
784 getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
785
786 getImports :: TcRn ImportAvails
787 getImports = do { env <- getGblEnv; return (tcg_imports env) }
788
789 getFixityEnv :: TcRn FixityEnv
790 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
791
792 extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
793 extendFixityEnv new_bit
794 = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
795 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
796
797 getRecFieldEnv :: TcRn RecFieldEnv
798 getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
799
800 getDeclaredDefaultTys :: TcRn (Maybe [Type])
801 getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
802
803 addDependentFiles :: [FilePath] -> TcRn ()
804 addDependentFiles fs = do
805 ref <- fmap tcg_dependent_files getGblEnv
806 dep_files <- readTcRef ref
807 writeTcRef ref (fs ++ dep_files)
808
809 {-
810 ************************************************************************
811 * *
812 Error management
813 * *
814 ************************************************************************
815 -}
816
817 getSrcSpanM :: TcRn SrcSpan
818 -- Avoid clash with Name.getSrcLoc
819 getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) }
820
821 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
822 setSrcSpan (RealSrcSpan real_loc) thing_inside
823 = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside
824 -- Don't overwrite useful info with useless:
825 setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
826
827 addLocM :: (a -> TcM b) -> Located a -> TcM b
828 addLocM fn (L loc a) = setSrcSpan loc $ fn a
829
830 wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
831 wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
832
833 wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
834 wrapLocFstM fn (L loc a) =
835 setSrcSpan loc $ do
836 (b,c) <- fn a
837 return (L loc b, c)
838
839 wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
840 wrapLocSndM fn (L loc a) =
841 setSrcSpan loc $ do
842 (b,c) <- fn a
843 return (b, L loc c)
844
845 -- Reporting errors
846
847 getErrsVar :: TcRn (TcRef Messages)
848 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
849
850 setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
851 setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v })
852
853 addErr :: MsgDoc -> TcRn ()
854 addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
855
856 failWith :: MsgDoc -> TcRn a
857 failWith msg = addErr msg >> failM
858
859 failAt :: SrcSpan -> MsgDoc -> TcRn a
860 failAt loc msg = addErrAt loc msg >> failM
861
862 addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
863 -- addErrAt is mainly (exclusively?) used by the renamer, where
864 -- tidying is not an issue, but it's all lazy so the extra
865 -- work doesn't matter
866 addErrAt loc msg = do { ctxt <- getErrCtxt
867 ; tidy_env <- tcInitTidyEnv
868 ; err_info <- mkErrInfo tidy_env ctxt
869 ; addLongErrAt loc msg err_info }
870
871 addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()
872 addErrs msgs = mapM_ add msgs
873 where
874 add (loc,msg) = addErrAt loc msg
875
876 checkErr :: Bool -> MsgDoc -> TcRn ()
877 -- Add the error if the bool is False
878 checkErr ok msg = unless ok (addErr msg)
879
880 addMessages :: Messages -> TcRn ()
881 addMessages msgs1
882 = do { errs_var <- getErrsVar ;
883 msgs0 <- readTcRef errs_var ;
884 writeTcRef errs_var (unionMessages msgs0 msgs1) }
885
886 discardWarnings :: TcRn a -> TcRn a
887 -- Ignore warnings inside the thing inside;
888 -- used to ignore-unused-variable warnings inside derived code
889 discardWarnings thing_inside
890 = do { errs_var <- getErrsVar
891 ; (old_warns, _) <- readTcRef errs_var
892
893 ; result <- thing_inside
894
895 -- Revert warnings to old_warns
896 ; (_new_warns, new_errs) <- readTcRef errs_var
897 ; writeTcRef errs_var (old_warns, new_errs)
898
899 ; return result }
900
901 {-
902 ************************************************************************
903 * *
904 Shared error message stuff: renamer and typechecker
905 * *
906 ************************************************************************
907 -}
908
909 mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
910 mkLongErrAt loc msg extra
911 = do { dflags <- getDynFlags ;
912 printer <- getPrintUnqualified dflags ;
913 return $ mkLongErrMsg dflags loc printer msg extra }
914
915 mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg
916 mkErrDocAt loc errDoc
917 = do { dflags <- getDynFlags ;
918 printer <- getPrintUnqualified dflags ;
919 return $ mkErrDoc dflags loc printer errDoc }
920
921 addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
922 addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
923
924 reportErrors :: [ErrMsg] -> TcM ()
925 reportErrors = mapM_ reportError
926
927 reportError :: ErrMsg -> TcRn ()
928 reportError err
929 = do { traceTc "Adding error:" (pprLocErrMsg err) ;
930 errs_var <- getErrsVar ;
931 (warns, errs) <- readTcRef errs_var ;
932 writeTcRef errs_var (warns, errs `snocBag` err) }
933
934 reportWarning :: WarnReason -> ErrMsg -> TcRn ()
935 reportWarning reason err
936 = do { let warn = makeIntoWarning reason err
937 -- 'err' was built by mkLongErrMsg or something like that,
938 -- so it's of error severity. For a warning we downgrade
939 -- its severity to SevWarning
940
941 ; traceTc "Adding warning:" (pprLocErrMsg warn)
942 ; errs_var <- getErrsVar
943 ; (warns, errs) <- readTcRef errs_var
944 ; writeTcRef errs_var (warns `snocBag` warn, errs) }
945
946 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
947 -- Does tryM, with a debug-trace on failure
948 try_m thing
949 = do { (mb_r, lie) <- tryCaptureConstraints thing
950 ; emitConstraints lie
951
952 -- Debug trace
953 ; case mb_r of
954 Left exn -> traceTc "tryTc/recoverM recovering from" $
955 text (showException exn)
956 Right {} -> return ()
957
958 ; return mb_r }
959
960 -----------------------
961 recoverM :: TcRn r -- Recovery action; do this if the main one fails
962 -> TcRn r -- Main action: do this first
963 -> TcRn r
964 -- Errors in 'thing' are retained
965 recoverM recover thing
966 = do { mb_res <- try_m thing ;
967 case mb_res of
968 Left _ -> recover
969 Right res -> return res }
970
971
972 -----------------------
973
974 -- | Drop elements of the input that fail, so the result
975 -- list can be shorter than the argument list
976 mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
977 mapAndRecoverM f = fmap reverse . foldAndRecoverM (\xs x -> (:xs) <$> f x ) []
978
979 -- | The accumulator is not updated if the action fails
980 foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
981 foldAndRecoverM _ acc [] = return acc
982 foldAndRecoverM f acc (x:xs) =
983 do { mb_r <- try_m (f acc x)
984 ; case mb_r of
985 Left _ -> foldAndRecoverM f acc xs
986 Right acc' -> foldAndRecoverM f acc' xs }
987
988 -- | Succeeds if applying the argument to all members of the lists succeeds,
989 -- but nevertheless runs it on all arguments, to collect all errors.
990 mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
991 mapAndReportM f xs = checkNoErrs (mapAndRecoverM f xs)
992
993 -----------------------
994 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
995 -- (tryTc m) executes m, and returns
996 -- Just r, if m succeeds (returning r)
997 -- Nothing, if m fails
998 -- It also returns all the errors and warnings accumulated by m
999 -- It always succeeds (never raises an exception)
1000 tryTc m
1001 = do { errs_var <- newTcRef emptyMessages ;
1002 res <- try_m (setErrsVar errs_var m) ;
1003 msgs <- readTcRef errs_var ;
1004 return (msgs, case res of
1005 Left _ -> Nothing
1006 Right val -> Just val)
1007 -- The exception is always the IOEnv built-in
1008 -- in exception; see IOEnv.failM
1009 }
1010
1011 -- (askNoErrs m) runs m
1012 -- If m fails, (askNoErrs m) fails
1013 -- If m succeeds with result r, (askNoErrs m) succeeds with result (r, b),
1014 -- where b is True iff m generated no errors
1015 -- Regardless of success or failure, any errors generated by m are propagated
1016 askNoErrs :: TcRn a -> TcRn (a, Bool)
1017 askNoErrs m
1018 = do { errs_var <- newTcRef emptyMessages
1019 ; res <- setErrsVar errs_var m
1020 ; (warns, errs) <- readTcRef errs_var
1021 ; addMessages (warns, errs)
1022 ; return (res, isEmptyBag errs) }
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 tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
1034 -- Run the thing, returning
1035 -- Just r, if m succceeds with no error messages
1036 -- Nothing, if m fails, or if it succeeds but has error messages
1037 -- Either way, the messages are returned;
1038 -- even in the Just case there might be warnings
1039 tryTcErrs thing
1040 = do { (msgs, res) <- tryTc thing
1041 ; dflags <- getDynFlags
1042 ; let errs_found = errorsFound dflags msgs
1043 ; return (msgs, case res of
1044 Nothing -> Nothing
1045 Just val | errs_found -> Nothing
1046 | otherwise -> Just val)
1047 }
1048
1049 -----------------------
1050 tryTcLIE_ :: TcM r -> TcM r -> TcM r
1051 -- (tryTcLIE_ r m) tries m;
1052 -- if m succeeds with no error messages, it's the answer
1053 -- otherwise tryTcLIE_ drops everything from m and tries r instead.
1054 tryTcLIE_ recover main
1055 = do { (msgs, mb_res) <- tryTcErrs main
1056 ; case mb_res of
1057 Just val -> do { addMessages msgs -- There might be warnings
1058 ; return val }
1059 Nothing -> recover -- Discard all msgs
1060 }
1061
1062 -----------------------
1063 checkNoErrs :: TcM r -> TcM r
1064 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
1065 -- If m fails then (checkNoErrsTc m) fails.
1066 -- If m succeeds, it checks whether m generated any errors messages
1067 -- (it might have recovered internally)
1068 -- If so, it fails too.
1069 -- Regardless, any errors generated by m are propagated to the enclosing context.
1070 checkNoErrs main
1071 = do { (msgs, mb_res) <- tryTcErrs main
1072 ; addMessages msgs
1073 ; case mb_res of
1074 Nothing -> failM
1075 Just val -> return val
1076 }
1077
1078 whenNoErrs :: TcM () -> TcM ()
1079 whenNoErrs thing = ifErrsM (return ()) thing
1080
1081 ifErrsM :: TcRn r -> TcRn r -> TcRn r
1082 -- ifErrsM bale_out normal
1083 -- does 'bale_out' if there are errors in errors collection
1084 -- otherwise does 'normal'
1085 ifErrsM bale_out normal
1086 = do { errs_var <- getErrsVar ;
1087 msgs <- readTcRef errs_var ;
1088 dflags <- getDynFlags ;
1089 if errorsFound dflags msgs then
1090 bale_out
1091 else
1092 normal }
1093
1094 failIfErrsM :: TcRn ()
1095 -- Useful to avoid error cascades
1096 failIfErrsM = ifErrsM failM (return ())
1097
1098 checkTH :: a -> String -> TcRn ()
1099 checkTH _ _ = return () -- OK
1100
1101 failTH :: Outputable a => a -> String -> TcRn x
1102 failTH e what -- Raise an error in a stage-1 compiler
1103 = failWithTc (vcat [ hang (char 'A' <+> text what
1104 <+> text "requires GHC with interpreter support:")
1105 2 (ppr e)
1106 , text "Perhaps you are using a stage-1 compiler?" ])
1107
1108
1109 {- *********************************************************************
1110 * *
1111 Context management for the type checker
1112 * *
1113 ************************************************************************
1114 -}
1115
1116 getErrCtxt :: TcM [ErrCtxt]
1117 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
1118
1119 setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
1120 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
1121
1122 -- | Add a fixed message to the error context. This message should not
1123 -- do any tidying.
1124 addErrCtxt :: MsgDoc -> TcM a -> TcM a
1125 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
1126
1127 -- | Add a message to the error context. This message may do tidying.
1128 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
1129 addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
1130
1131 -- | Add a fixed landmark message to the error context. A landmark
1132 -- message is always sure to be reported, even if there is a lot of
1133 -- context. It also doesn't count toward the maximum number of contexts
1134 -- reported.
1135 addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
1136 addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
1137
1138 -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
1139 -- and tidying.
1140 addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
1141 addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts)
1142
1143 -- Helper function for the above
1144 updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
1145 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
1146 env { tcl_ctxt = upd ctxt })
1147
1148 popErrCtxt :: TcM a -> TcM a
1149 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
1150
1151 getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
1152 getCtLocM origin t_or_k
1153 = do { env <- getLclEnv
1154 ; return (CtLoc { ctl_origin = origin
1155 , ctl_env = env
1156 , ctl_t_or_k = t_or_k
1157 , ctl_depth = initialSubGoalDepth }) }
1158
1159 setCtLocM :: CtLoc -> TcM a -> TcM a
1160 -- Set the SrcSpan and error context from the CtLoc
1161 setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
1162 = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
1163 , tcl_bndrs = tcl_bndrs lcl
1164 , tcl_ctxt = tcl_ctxt lcl })
1165 thing_inside
1166
1167 {-
1168 ************************************************************************
1169 * *
1170 Error message generation (type checker)
1171 * *
1172 ************************************************************************
1173
1174 The addErrTc functions add an error message, but do not cause failure.
1175 The 'M' variants pass a TidyEnv that has already been used to
1176 tidy up the message; we then use it to tidy the context messages
1177 -}
1178
1179 addErrTc :: MsgDoc -> TcM ()
1180 addErrTc err_msg = do { env0 <- tcInitTidyEnv
1181 ; addErrTcM (env0, err_msg) }
1182
1183 addErrsTc :: [MsgDoc] -> TcM ()
1184 addErrsTc err_msgs = mapM_ addErrTc err_msgs
1185
1186 addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()
1187 addErrTcM (tidy_env, err_msg)
1188 = do { ctxt <- getErrCtxt ;
1189 loc <- getSrcSpanM ;
1190 add_err_tcm tidy_env err_msg loc ctxt }
1191
1192 -- Return the error message, instead of reporting it straight away
1193 mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg
1194 mkErrTcM (tidy_env, err_msg)
1195 = do { ctxt <- getErrCtxt ;
1196 loc <- getSrcSpanM ;
1197 err_info <- mkErrInfo tidy_env ctxt ;
1198 mkLongErrAt loc err_msg err_info }
1199
1200 -- The failWith functions add an error message and cause failure
1201
1202 failWithTc :: MsgDoc -> TcM a -- Add an error message and fail
1203 failWithTc err_msg
1204 = addErrTc err_msg >> failM
1205
1206 failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail
1207 failWithTcM local_and_msg
1208 = addErrTcM local_and_msg >> failM
1209
1210 checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true
1211 checkTc True _ = return ()
1212 checkTc False err = failWithTc err
1213
1214 checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
1215 checkTcM True _ = return ()
1216 checkTcM False err = failWithTcM err
1217
1218 failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false
1219 failIfTc False _ = return ()
1220 failIfTc True err = failWithTc err
1221
1222 failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
1223 -- Check that the boolean is false
1224 failIfTcM False _ = return ()
1225 failIfTcM True err = failWithTcM err
1226
1227
1228 -- Warnings have no 'M' variant, nor failure
1229
1230 -- | Display a warning if a condition is met.
1231 -- and the warning is enabled
1232 warnIf :: WarnReason -> Bool -> MsgDoc -> TcRn ()
1233 warnIf reason is_bad msg
1234 = do { warn_on <- case reason of
1235 NoReason -> return True
1236 Reason warn_flag -> woptM warn_flag
1237 ; when (warn_on && is_bad) $
1238 addWarn reason msg }
1239
1240 -- | Display a warning if a condition is met.
1241 warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()
1242 warnTc reason warn_if_true warn_msg
1243 | warn_if_true = addWarnTc reason warn_msg
1244 | otherwise = return ()
1245
1246 -- | Display a warning if a condition is met.
1247 warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()
1248 warnTcM reason warn_if_true warn_msg
1249 | warn_if_true = addWarnTcM reason warn_msg
1250 | otherwise = return ()
1251
1252 -- | Display a warning in the current context.
1253 addWarnTc :: WarnReason -> MsgDoc -> TcM ()
1254 addWarnTc reason msg
1255 = do { env0 <- tcInitTidyEnv ;
1256 addWarnTcM reason (env0, msg) }
1257
1258 -- | Display a warning in a given context.
1259 addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()
1260 addWarnTcM reason (env0, msg)
1261 = do { ctxt <- getErrCtxt ;
1262 err_info <- mkErrInfo env0 ctxt ;
1263 add_warn reason msg err_info }
1264
1265 -- | Display a warning for the current source location.
1266 addWarn :: WarnReason -> MsgDoc -> TcRn ()
1267 addWarn reason msg = add_warn reason msg Outputable.empty
1268
1269 -- | Display a warning for a given source location.
1270 addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
1271 addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty
1272
1273 -- | Display a warning, with an optional flag, for the current source
1274 -- location.
1275 add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()
1276 add_warn reason msg extra_info
1277 = do { loc <- getSrcSpanM
1278 ; add_warn_at reason loc msg extra_info }
1279
1280 -- | Display a warning, with an optional flag, for a given location.
1281 add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
1282 add_warn_at reason loc msg extra_info
1283 = do { dflags <- getDynFlags ;
1284 printer <- getPrintUnqualified dflags ;
1285 let { warn = mkLongWarnMsg dflags loc printer
1286 msg extra_info } ;
1287 reportWarning reason warn }
1288
1289 tcInitTidyEnv :: TcM TidyEnv
1290 tcInitTidyEnv
1291 = do { lcl_env <- getLclEnv
1292 ; return (tcl_tidy lcl_env) }
1293
1294 -- | Get a 'TidyEnv' that includes mappings for all vars free in the given
1295 -- type. Useful when tidying open types.
1296 tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
1297 tcInitOpenTidyEnv tvs
1298 = do { env1 <- tcInitTidyEnv
1299 ; let env2 = tidyFreeTyCoVars env1 tvs
1300 ; return env2 }
1301
1302
1303 {-
1304 -----------------------------------
1305 Other helper functions
1306 -}
1307
1308 add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan
1309 -> [ErrCtxt]
1310 -> TcM ()
1311 add_err_tcm tidy_env err_msg loc ctxt
1312 = do { err_info <- mkErrInfo tidy_env ctxt ;
1313 addLongErrAt loc err_msg err_info }
1314
1315 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
1316 -- Tidy the error info, trimming excessive contexts
1317 mkErrInfo env ctxts
1318 -- = do
1319 -- dbg <- hasPprDebug <$> getDynFlags
1320 -- if dbg -- In -dppr-debug style the output
1321 -- then return empty -- just becomes too voluminous
1322 -- else go dbg 0 env ctxts
1323 = go False 0 env ctxts
1324 where
1325 go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
1326 go _ _ _ [] = return empty
1327 go dbg n env ((is_landmark, ctxt) : ctxts)
1328 | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg
1329 = do { (env', msg) <- ctxt env
1330 ; let n' = if is_landmark then n else n+1
1331 ; rest <- go dbg n' env' ctxts
1332 ; return (msg $$ rest) }
1333 | otherwise
1334 = go dbg n env ctxts
1335
1336 mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts
1337 mAX_CONTEXTS = 3
1338
1339 -- debugTc is useful for monadic debugging code
1340
1341 debugTc :: TcM () -> TcM ()
1342 debugTc thing
1343 | debugIsOn = thing
1344 | otherwise = return ()
1345
1346 {-
1347 ************************************************************************
1348 * *
1349 Type constraints
1350 * *
1351 ************************************************************************
1352 -}
1353
1354 newTcEvBinds :: TcM EvBindsVar
1355 newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
1356 ; tcvs_ref <- newTcRef emptyVarSet
1357 ; uniq <- newUnique
1358 ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
1359 ; return (EvBindsVar { ebv_binds = binds_ref
1360 , ebv_tcvs = tcvs_ref
1361 , ebv_uniq = uniq }) }
1362
1363 getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
1364 getTcEvTyCoVars (EvBindsVar { ebv_tcvs = ev_ref })
1365 = readTcRef ev_ref
1366
1367 getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
1368 getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref })
1369 = readTcRef ev_ref
1370
1371 addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
1372 -- Add a binding to the TcEvBinds by side effect
1373 addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind
1374 = do { traceTc "addTcEvBind" $ ppr u $$
1375 ppr ev_bind
1376 ; bnds <- readTcRef ev_ref
1377 ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
1378
1379 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
1380 chooseUniqueOccTc fn =
1381 do { env <- getGblEnv
1382 ; let dfun_n_var = tcg_dfun_n env
1383 ; set <- readTcRef dfun_n_var
1384 ; let occ = fn set
1385 ; writeTcRef dfun_n_var (extendOccSet set occ)
1386 ; return occ }
1387
1388 getConstraintVar :: TcM (TcRef WantedConstraints)
1389 getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
1390
1391 setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
1392 setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
1393
1394 emitStaticConstraints :: WantedConstraints -> TcM ()
1395 emitStaticConstraints static_lie
1396 = do { gbl_env <- getGblEnv
1397 ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) }
1398
1399 emitConstraints :: WantedConstraints -> TcM ()
1400 emitConstraints ct
1401 = do { lie_var <- getConstraintVar ;
1402 updTcRef lie_var (`andWC` ct) }
1403
1404 emitSimple :: Ct -> TcM ()
1405 emitSimple ct
1406 = do { lie_var <- getConstraintVar ;
1407 updTcRef lie_var (`addSimples` unitBag ct) }
1408
1409 emitSimples :: Cts -> TcM ()
1410 emitSimples cts
1411 = do { lie_var <- getConstraintVar ;
1412 updTcRef lie_var (`addSimples` cts) }
1413
1414 emitImplication :: Implication -> TcM ()
1415 emitImplication ct
1416 = do { lie_var <- getConstraintVar ;
1417 updTcRef lie_var (`addImplics` unitBag ct) }
1418
1419 emitImplications :: Bag Implication -> TcM ()
1420 emitImplications ct
1421 = unless (isEmptyBag ct) $
1422 do { lie_var <- getConstraintVar ;
1423 updTcRef lie_var (`addImplics` ct) }
1424
1425 emitInsoluble :: Ct -> TcM ()
1426 emitInsoluble ct
1427 = do { traceTc "emitInsoluble" (ppr ct)
1428 ; lie_var <- getConstraintVar
1429 ; updTcRef lie_var (`addInsols` unitBag ct) }
1430
1431 emitInsolubles :: Cts -> TcM ()
1432 emitInsolubles cts
1433 | isEmptyBag cts = return ()
1434 | otherwise = do { traceTc "emitInsolubles" (ppr cts)
1435 ; lie_var <- getConstraintVar
1436 ; updTcRef lie_var (`addInsols` cts) }
1437
1438 -- | Throw out any constraints emitted by the thing_inside
1439 discardConstraints :: TcM a -> TcM a
1440 discardConstraints thing_inside = fst <$> captureConstraints thing_inside
1441
1442 tryCaptureConstraints :: TcM a -> TcM (Either IOEnvFailure a, WantedConstraints)
1443 -- (captureConstraints_maybe m) runs m,
1444 -- and returns the type constraints it generates
1445 -- It never throws an exception; instead if thing_inside fails,
1446 -- it returns Left exn and the insoluble constraints
1447 tryCaptureConstraints thing_inside
1448 = do { lie_var <- newTcRef emptyWC
1449 ; mb_res <- tryM $
1450 updLclEnv (\ env -> env { tcl_lie = lie_var }) $
1451 thing_inside
1452 ; lie <- readTcRef lie_var
1453
1454 -- See Note [Constraints and errors]
1455 ; let lie_to_keep = case mb_res of
1456 Left {} -> insolublesOnly lie
1457 Right {} -> lie
1458
1459 ; return (mb_res, lie_to_keep) }
1460
1461 captureConstraints :: TcM a -> TcM (a, WantedConstraints)
1462 -- (captureConstraints m) runs m, and returns the type constraints it generates
1463 captureConstraints thing_inside
1464 = do { (mb_res, lie) <- tryCaptureConstraints thing_inside
1465
1466 -- See Note [Constraints and errors]
1467 -- If the thing_inside threw an exception, emit the insoluble
1468 -- constraints only (returned by tryCaptureConstraints)
1469 -- so that they are not lost
1470 ; case mb_res of
1471 Left _ -> do { emitConstraints lie; failM }
1472 Right res -> return (res, lie) }
1473
1474 pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
1475 pushLevelAndCaptureConstraints thing_inside
1476 = do { env <- getLclEnv
1477 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1478 ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $
1479 captureConstraints thing_inside
1480 ; return (tclvl', lie, res) }
1481
1482 pushTcLevelM_ :: TcM a -> TcM a
1483 pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
1484
1485 pushTcLevelM :: TcM a -> TcM (a, TcLevel)
1486 -- See Note [TcLevel assignment] in TcType
1487 pushTcLevelM thing_inside
1488 = do { env <- getLclEnv
1489 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1490 ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
1491 thing_inside
1492 ; return (res, tclvl') }
1493
1494 getTcLevel :: TcM TcLevel
1495 getTcLevel = do { env <- getLclEnv
1496 ; return (tcl_tclvl env) }
1497
1498 setTcLevel :: TcLevel -> TcM a -> TcM a
1499 setTcLevel tclvl thing_inside
1500 = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
1501
1502 isTouchableTcM :: TcTyVar -> TcM Bool
1503 isTouchableTcM tv
1504 = do { env <- getLclEnv
1505 ; return (isTouchableMetaTyVar (tcl_tclvl env) tv) }
1506
1507 getLclTypeEnv :: TcM TcTypeEnv
1508 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
1509
1510 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
1511 -- Set the local type envt, but do *not* disturb other fields,
1512 -- notably the lie_var
1513 setLclTypeEnv lcl_env thing_inside
1514 = updLclEnv upd thing_inside
1515 where
1516 upd env = env { tcl_env = tcl_env lcl_env,
1517 tcl_tyvars = tcl_tyvars lcl_env }
1518
1519 traceTcConstraints :: String -> TcM ()
1520 traceTcConstraints msg
1521 = do { lie_var <- getConstraintVar
1522 ; lie <- readTcRef lie_var
1523 ; traceOptTcRn Opt_D_dump_tc_trace $
1524 hang (text (msg ++ ": LIE:")) 2 (ppr lie)
1525 }
1526
1527 emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
1528 emitWildCardHoleConstraints wcs
1529 = do { ct_loc <- getCtLocM HoleOrigin Nothing
1530 ; emitInsolubles $ listToBag $
1531 map (do_one ct_loc) wcs }
1532 where
1533 do_one :: CtLoc -> (Name, TcTyVar) -> Ct
1534 do_one ct_loc (name, tv)
1535 = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv
1536 , ctev_loc = ct_loc' }
1537 , cc_hole = TypeHole (occName name) }
1538 where
1539 real_span = case nameSrcSpan name of
1540 RealSrcSpan span -> span
1541 UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints"
1542 (ppr name <+> quotes (ftext str))
1543 -- Wildcards are defined locally, and so have RealSrcSpans
1544 ct_loc' = setCtLocSpan ct_loc real_span
1545
1546 {- Note [Constraints and errors]
1547 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1548 Consider this (Trac #12124):
1549
1550 foo :: Maybe Int
1551 foo = return (case Left 3 of
1552 Left -> 1 -- Hard error here!
1553 _ -> 0)
1554
1555 The call to 'return' will generate a (Monad m) wanted constraint; but
1556 then there'll be "hard error" (i.e. an exception in the TcM monad), from
1557 the unsaturated Left constructor pattern.
1558
1559 We'll recover in tcPolyBinds, using recoverM. But then the final
1560 tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly
1561 un-filled-in, and will emit a misleading error message.
1562
1563 The underlying problem is that an exception interrupts the constraint
1564 gathering process. Bottom line: if we have an exception, it's best
1565 simply to discard any gathered constraints. Hence in 'try_m' we
1566 capture the constraints in a fresh variable, and only emit them into
1567 the surrounding context if we exit normally. If an exception is
1568 raised, simply discard the collected constraints... we have a hard
1569 error to report. So this capture-the-emit dance isn't as stupid as it
1570 looks :-).
1571
1572 However suppose we throw an exception inside an invocation of
1573 captureConstraints, and discard all the constraints. Some of those
1574 contraints might be "variable out of scope" Hole constraints, and that
1575 might have been the actual original cause of the exception! For
1576 example (Trac #12529):
1577 f = p @ Int
1578 Here 'p' is out of scope, so we get an insolube Hole constraint. But
1579 the visible type application fails in the monad (thows an exception).
1580 We must not discard the out-of-scope error.
1581
1582 So we /retain the insoluble constraints/ if there is an exception.
1583 Hence:
1584 - insolublesOnly in tryCaptureConstraints
1585 - emitConstraints in the Left case of captureConstraints
1586
1587
1588 ************************************************************************
1589 * *
1590 Template Haskell context
1591 * *
1592 ************************************************************************
1593 -}
1594
1595 recordThUse :: TcM ()
1596 recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
1597
1598 recordThSpliceUse :: TcM ()
1599 recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
1600
1601 -- | When generating an out-of-scope error message for a variable matching a
1602 -- binding in a later inter-splice group, the typechecker uses the splice
1603 -- locations to provide details in the message about the scope of that binding.
1604 recordTopLevelSpliceLoc :: SrcSpan -> TcM ()
1605 recordTopLevelSpliceLoc (RealSrcSpan real_loc)
1606 = do { env <- getGblEnv
1607 ; let locs_var = tcg_th_top_level_locs env
1608 ; locs0 <- readTcRef locs_var
1609 ; writeTcRef locs_var (Set.insert real_loc locs0) }
1610 recordTopLevelSpliceLoc (UnhelpfulSpan _) = return ()
1611
1612 getTopLevelSpliceLocs :: TcM (Set RealSrcSpan)
1613 getTopLevelSpliceLocs
1614 = do { env <- getGblEnv
1615 ; readTcRef (tcg_th_top_level_locs env) }
1616
1617 keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set
1618 keepAlive name
1619 = do { env <- getGblEnv
1620 ; traceRn "keep alive" (ppr name)
1621 ; updTcRef (tcg_keep env) (`extendNameSet` name) }
1622
1623 getStage :: TcM ThStage
1624 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
1625
1626 getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
1627 getStageAndBindLevel name
1628 = do { env <- getLclEnv;
1629 ; case lookupNameEnv (tcl_th_bndrs env) name of
1630 Nothing -> return Nothing
1631 Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
1632
1633 setStage :: ThStage -> TcM a -> TcRn a
1634 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
1635
1636 -- | Adds the given modFinalizers to the global environment and set them to use
1637 -- the current local environment.
1638 addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
1639 addModFinalizersWithLclEnv mod_finalizers
1640 = do lcl_env <- getLclEnv
1641 th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
1642 updTcRef th_modfinalizers_var $ \fins ->
1643 setLclEnv lcl_env (runRemoteModFinalizers mod_finalizers)
1644 : fins
1645
1646 {-
1647 ************************************************************************
1648 * *
1649 Safe Haskell context
1650 * *
1651 ************************************************************************
1652 -}
1653
1654 -- | Mark that safe inference has failed
1655 -- See Note [Safe Haskell Overlapping Instances Implementation]
1656 -- although this is used for more than just that failure case.
1657 recordUnsafeInfer :: WarningMessages -> TcM ()
1658 recordUnsafeInfer warns =
1659 getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)
1660
1661 -- | Figure out the final correct safe haskell mode
1662 finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
1663 finalSafeMode dflags tcg_env = do
1664 safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)
1665 return $ case safeHaskell dflags of
1666 Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
1667 | otherwise -> Sf_None
1668 s -> s
1669
1670 -- | Switch instances to safe instances if we're in Safe mode.
1671 fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
1672 fixSafeInstances sfMode | sfMode /= Sf_Safe = id
1673 fixSafeInstances _ = map fixSafe
1674 where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
1675 in inst { is_flag = new_flag }
1676
1677 {-
1678 ************************************************************************
1679 * *
1680 Stuff for the renamer's local env
1681 * *
1682 ************************************************************************
1683 -}
1684
1685 getLocalRdrEnv :: RnM LocalRdrEnv
1686 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
1687
1688 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
1689 setLocalRdrEnv rdr_env thing_inside
1690 = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
1691
1692 {-
1693 ************************************************************************
1694 * *
1695 Stuff for interface decls
1696 * *
1697 ************************************************************************
1698 -}
1699
1700 mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv
1701 mkIfLclEnv mod loc boot
1702 = IfLclEnv { if_mod = mod,
1703 if_loc = loc,
1704 if_boot = boot,
1705 if_nsubst = Nothing,
1706 if_implicits_env = Nothing,
1707 if_tv_env = emptyFsEnv,
1708 if_id_env = emptyFsEnv }
1709
1710 -- | Run an 'IfG' (top-level interface monad) computation inside an existing
1711 -- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
1712 -- based on 'TcGblEnv'.
1713 initIfaceTcRn :: IfG a -> TcRn a
1714 initIfaceTcRn thing_inside
1715 = do { tcg_env <- getGblEnv
1716 ; dflags <- getDynFlags
1717 ; let mod = tcg_semantic_mod tcg_env
1718 -- When we are instantiating a signature, we DEFINITELY
1719 -- do not want to knot tie.
1720 is_instantiate = unitIdIsDefinite (thisPackage dflags) &&
1721 not (null (thisUnitIdInsts dflags))
1722 ; let { if_env = IfGblEnv {
1723 if_doc = text "initIfaceTcRn",
1724 if_rec_types =
1725 if is_instantiate
1726 then Nothing
1727 else Just (mod, get_type_env)
1728 }
1729 ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
1730 ; setEnvs (if_env, ()) thing_inside }
1731
1732 -- Used when sucking in a ModIface into a ModDetails to put in
1733 -- the HPT. Notably, unlike initIfaceCheck, this does NOT use
1734 -- hsc_type_env_var (since we're not actually going to typecheck,
1735 -- so this variable will never get updated!)
1736 initIfaceLoad :: HscEnv -> IfG a -> IO a
1737 initIfaceLoad hsc_env do_this
1738 = do let gbl_env = IfGblEnv {
1739 if_doc = text "initIfaceLoad",
1740 if_rec_types = Nothing
1741 }
1742 initTcRnIf 'i' hsc_env gbl_env () do_this
1743
1744 initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a
1745 -- Used when checking the up-to-date-ness of the old Iface
1746 -- Initialise the environment with no useful info at all
1747 initIfaceCheck doc hsc_env do_this
1748 = do let rec_types = case hsc_type_env_var hsc_env of
1749 Just (mod,var) -> Just (mod, readTcRef var)
1750 Nothing -> Nothing
1751 gbl_env = IfGblEnv {
1752 if_doc = text "initIfaceCheck" <+> doc,
1753 if_rec_types = rec_types
1754 }
1755 initTcRnIf 'i' hsc_env gbl_env () do_this
1756
1757 initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a
1758 initIfaceLcl mod loc_doc hi_boot_file thing_inside
1759 = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside
1760
1761 -- | Initialize interface typechecking, but with a 'NameShape'
1762 -- to apply when typechecking top-level 'OccName's (see
1763 -- 'lookupIfaceTop')
1764 initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a
1765 initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside
1766 = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside
1767
1768 getIfModule :: IfL Module
1769 getIfModule = do { env <- getLclEnv; return (if_mod env) }
1770
1771 --------------------
1772 failIfM :: MsgDoc -> IfL a
1773 -- The Iface monad doesn't have a place to accumulate errors, so we
1774 -- just fall over fast if one happens; it "shouldn't happen".
1775 -- We use IfL here so that we can get context info out of the local env
1776 failIfM msg
1777 = do { env <- getLclEnv
1778 ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1779 ; dflags <- getDynFlags
1780 ; liftIO (putLogMsg dflags NoReason SevFatal
1781 noSrcSpan (defaultErrStyle dflags) full_msg)
1782 ; failM }
1783
1784 --------------------
1785 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1786 -- Run thing_inside in an interleaved thread.
1787 -- It shares everything with the parent thread, so this is DANGEROUS.
1788 --
1789 -- It returns Nothing if the computation fails
1790 --
1791 -- It's used for lazily type-checking interface
1792 -- signatures, which is pretty benign
1793
1794 forkM_maybe doc thing_inside
1795 -- NB: Don't share the mutable env_us with the interleaved thread since env_us
1796 -- does not get updated atomically (e.g. in newUnique and newUniqueSupply).
1797 = do { child_us <- newUniqueSupply
1798 ; child_env_us <- newMutVar child_us
1799 -- see Note [Masking exceptions in forkM_maybe]
1800 ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $
1801 do { traceIf (text "Starting fork {" <+> doc)
1802 ; mb_res <- tryM $
1803 updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1804 thing_inside
1805 ; case mb_res of
1806 Right r -> do { traceIf (text "} ending fork" <+> doc)
1807 ; return (Just r) }
1808 Left exn -> do {
1809
1810 -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1811 -- Otherwise we silently discard errors. Errors can legitimately
1812 -- happen when compiling interface signatures (see tcInterfaceSigs)
1813 whenDOptM Opt_D_dump_if_trace $ do
1814 dflags <- getDynFlags
1815 let msg = hang (text "forkM failed:" <+> doc)
1816 2 (text (show exn))
1817 liftIO $ putLogMsg dflags
1818 NoReason
1819 SevFatal
1820 noSrcSpan
1821 (defaultErrStyle dflags)
1822 msg
1823
1824 ; traceIf (text "} ending fork (badly)" <+> doc)
1825 ; return Nothing }
1826 }}
1827
1828 forkM :: SDoc -> IfL a -> IfL a
1829 forkM doc thing_inside
1830 = do { mb_res <- forkM_maybe doc thing_inside
1831 ; return (case mb_res of
1832 Nothing -> pgmError "Cannot continue after interface file error"
1833 -- pprPanic "forkM" doc
1834 Just r -> r) }
1835
1836 setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
1837 setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl { if_implicits_env = Just tenv }) m
1838
1839 {-
1840 Note [Masking exceptions in forkM_maybe]
1841 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1842
1843 When using GHC-as-API it must be possible to interrupt snippets of code
1844 executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
1845 by throwing an asynchronous interrupt to the GHC thread. However, there is a
1846 subtle problem: runStmt first typechecks the code before running it, and the
1847 exception might interrupt the type checker rather than the code. Moreover, the
1848 typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
1849 more importantly might be inside an exception handler inside that
1850 unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
1851 asynchronous exception as a synchronous exception, and the exception will end
1852 up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
1853 discussion). We don't currently know a general solution to this problem, but
1854 we can use uninterruptibleMask_ to avoid the situation.
1855 -}