Deal with exceptions in dsWhenNoErrs
[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,
82 failWithTc, failWithTcM,
83 checkTc, checkTcM,
84 failIfTc, failIfTcM,
85 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 -- 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 -}