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