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