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