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