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