Typos in comments only [ci skip]
[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, emitStaticConstraints, emitSimple, emitSimples,
97 emitImplication, emitImplications, emitInsoluble,
98 discardConstraints, captureConstraints, tryCaptureConstraints,
99 pushLevelAndCaptureConstraints,
100 pushTcLevelM_, pushTcLevelM,
101 getTcLevel, setTcLevel, isTouchableTcM,
102 getLclTypeEnv, setLclTypeEnv,
103 traceTcConstraints, emitWildCardHoleConstraints,
104
105 -- * Template Haskell context
106 recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc,
107 getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage,
108 addModFinalizersWithLclEnv,
109
110 -- * Safe Haskell context
111 recordUnsafeInfer, finalSafeMode, fixSafeInstances,
112
113 -- * Stuff for the renamer's local env
114 getLocalRdrEnv, setLocalRdrEnv,
115
116 -- * Stuff for interface decls
117 mkIfLclEnv,
118 initIfaceTcRn,
119 initIfaceCheck,
120 initIfaceLcl,
121 initIfaceLclWithSubst,
122 initIfaceLoad,
123 getIfModule,
124 failIfM,
125 forkM_maybe,
126 forkM,
127 setImplicitEnvM,
128
129 withException,
130
131 -- * Types etc.
132 module TcRnTypes,
133 module IOEnv
134 ) where
135
136 #include "HsVersions.h"
137
138 import 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, lie) <- tryCaptureConstraints thing
934 ; emitConstraints lie
935
936 -- Debug trace
937 ; case mb_r of
938 Left exn -> traceTc "tryTc/recoverM recovering from" $
939 text (showException exn)
940 Right {} -> return ()
941
942 ; return mb_r }
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
1093 {- *********************************************************************
1094 * *
1095 Context management for the type checker
1096 * *
1097 ************************************************************************
1098 -}
1099
1100 getErrCtxt :: TcM [ErrCtxt]
1101 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
1102
1103 setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
1104 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
1105
1106 -- | Add a fixed message to the error context. This message should not
1107 -- do any tidying.
1108 addErrCtxt :: MsgDoc -> TcM a -> TcM a
1109 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
1110
1111 -- | Add a message to the error context. This message may do tidying.
1112 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
1113 addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
1114
1115 -- | Add a fixed landmark message to the error context. A landmark
1116 -- message is always sure to be reported, even if there is a lot of
1117 -- context. It also doesn't count toward the maximum number of contexts
1118 -- reported.
1119 addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
1120 addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
1121
1122 -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
1123 -- and tidying.
1124 addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
1125 addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts)
1126
1127 -- Helper function for the above
1128 updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
1129 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
1130 env { tcl_ctxt = upd ctxt })
1131
1132 popErrCtxt :: TcM a -> TcM a
1133 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
1134
1135 getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
1136 getCtLocM origin t_or_k
1137 = do { env <- getLclEnv
1138 ; return (CtLoc { ctl_origin = origin
1139 , ctl_env = env
1140 , ctl_t_or_k = t_or_k
1141 , ctl_depth = initialSubGoalDepth }) }
1142
1143 setCtLocM :: CtLoc -> TcM a -> TcM a
1144 -- Set the SrcSpan and error context from the CtLoc
1145 setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
1146 = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
1147 , tcl_bndrs = tcl_bndrs lcl
1148 , tcl_ctxt = tcl_ctxt lcl })
1149 thing_inside
1150
1151 {-
1152 ************************************************************************
1153 * *
1154 Error message generation (type checker)
1155 * *
1156 ************************************************************************
1157
1158 The addErrTc functions add an error message, but do not cause failure.
1159 The 'M' variants pass a TidyEnv that has already been used to
1160 tidy up the message; we then use it to tidy the context messages
1161 -}
1162
1163 addErrTc :: MsgDoc -> TcM ()
1164 addErrTc err_msg = do { env0 <- tcInitTidyEnv
1165 ; addErrTcM (env0, err_msg) }
1166
1167 addErrsTc :: [MsgDoc] -> TcM ()
1168 addErrsTc err_msgs = mapM_ addErrTc err_msgs
1169
1170 addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()
1171 addErrTcM (tidy_env, err_msg)
1172 = do { ctxt <- getErrCtxt ;
1173 loc <- getSrcSpanM ;
1174 add_err_tcm tidy_env err_msg loc ctxt }
1175
1176 -- Return the error message, instead of reporting it straight away
1177 mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg
1178 mkErrTcM (tidy_env, err_msg)
1179 = do { ctxt <- getErrCtxt ;
1180 loc <- getSrcSpanM ;
1181 err_info <- mkErrInfo tidy_env ctxt ;
1182 mkLongErrAt loc err_msg err_info }
1183
1184 -- The failWith functions add an error message and cause failure
1185
1186 failWithTc :: MsgDoc -> TcM a -- Add an error message and fail
1187 failWithTc err_msg
1188 = addErrTc err_msg >> failM
1189
1190 failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail
1191 failWithTcM local_and_msg
1192 = addErrTcM local_and_msg >> failM
1193
1194 checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true
1195 checkTc True _ = return ()
1196 checkTc False err = failWithTc err
1197
1198 checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
1199 checkTcM True _ = return ()
1200 checkTcM False err = failWithTcM err
1201
1202 failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false
1203 failIfTc False _ = return ()
1204 failIfTc True err = failWithTc err
1205
1206 failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
1207 -- Check that the boolean is false
1208 failIfTcM False _ = return ()
1209 failIfTcM True err = failWithTcM err
1210
1211
1212 -- Warnings have no 'M' variant, nor failure
1213
1214 -- | Display a warning if a condition is met.
1215 -- and the warning is enabled
1216 warnIf :: WarnReason -> Bool -> MsgDoc -> TcRn ()
1217 warnIf reason is_bad msg
1218 = do { warn_on <- case reason of
1219 NoReason -> return True
1220 Reason warn_flag -> woptM warn_flag
1221 ; when (warn_on && is_bad) $
1222 addWarn reason msg }
1223
1224 -- | Display a warning if a condition is met.
1225 warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()
1226 warnTc reason warn_if_true warn_msg
1227 | warn_if_true = addWarnTc reason warn_msg
1228 | otherwise = return ()
1229
1230 -- | Display a warning if a condition is met.
1231 warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()
1232 warnTcM reason warn_if_true warn_msg
1233 | warn_if_true = addWarnTcM reason warn_msg
1234 | otherwise = return ()
1235
1236 -- | Display a warning in the current context.
1237 addWarnTc :: WarnReason -> MsgDoc -> TcM ()
1238 addWarnTc reason msg
1239 = do { env0 <- tcInitTidyEnv ;
1240 addWarnTcM reason (env0, msg) }
1241
1242 -- | Display a warning in a given context.
1243 addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()
1244 addWarnTcM reason (env0, msg)
1245 = do { ctxt <- getErrCtxt ;
1246 err_info <- mkErrInfo env0 ctxt ;
1247 add_warn reason msg err_info }
1248
1249 -- | Display a warning for the current source location.
1250 addWarn :: WarnReason -> MsgDoc -> TcRn ()
1251 addWarn reason msg = add_warn reason msg Outputable.empty
1252
1253 -- | Display a warning for a given source location.
1254 addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
1255 addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty
1256
1257 -- | Display a warning, with an optional flag, for the current source
1258 -- location.
1259 add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()
1260 add_warn reason msg extra_info
1261 = do { loc <- getSrcSpanM
1262 ; add_warn_at reason loc msg extra_info }
1263
1264 -- | Display a warning, with an optional flag, for a given location.
1265 add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
1266 add_warn_at reason loc msg extra_info
1267 = do { dflags <- getDynFlags ;
1268 printer <- getPrintUnqualified dflags ;
1269 let { warn = mkLongWarnMsg dflags loc printer
1270 msg extra_info } ;
1271 reportWarning reason warn }
1272
1273 tcInitTidyEnv :: TcM TidyEnv
1274 tcInitTidyEnv
1275 = do { lcl_env <- getLclEnv
1276 ; return (tcl_tidy lcl_env) }
1277
1278 -- | Get a 'TidyEnv' that includes mappings for all vars free in the given
1279 -- type. Useful when tidying open types.
1280 tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
1281 tcInitOpenTidyEnv tvs
1282 = do { env1 <- tcInitTidyEnv
1283 ; let env2 = tidyFreeTyCoVars env1 tvs
1284 ; return env2 }
1285
1286
1287 {-
1288 -----------------------------------
1289 Other helper functions
1290 -}
1291
1292 add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan
1293 -> [ErrCtxt]
1294 -> TcM ()
1295 add_err_tcm tidy_env err_msg loc ctxt
1296 = do { err_info <- mkErrInfo tidy_env ctxt ;
1297 addLongErrAt loc err_msg err_info }
1298
1299 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
1300 -- Tidy the error info, trimming excessive contexts
1301 mkErrInfo env ctxts
1302 -- | opt_PprStyle_Debug -- In -dppr-debug style the output
1303 -- = return empty -- just becomes too voluminous
1304 | otherwise
1305 = go 0 env ctxts
1306 where
1307 go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
1308 go _ _ [] = return empty
1309 go n env ((is_landmark, ctxt) : ctxts)
1310 | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug
1311 = do { (env', msg) <- ctxt env
1312 ; let n' = if is_landmark then n else n+1
1313 ; rest <- go n' env' ctxts
1314 ; return (msg $$ rest) }
1315 | otherwise
1316 = go n env ctxts
1317
1318 mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts
1319 mAX_CONTEXTS = 3
1320
1321 -- debugTc is useful for monadic debugging code
1322
1323 debugTc :: TcM () -> TcM ()
1324 debugTc thing
1325 | debugIsOn = thing
1326 | otherwise = return ()
1327
1328 {-
1329 ************************************************************************
1330 * *
1331 Type constraints
1332 * *
1333 ************************************************************************
1334 -}
1335
1336 newTcEvBinds :: TcM EvBindsVar
1337 newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
1338 ; tcvs_ref <- newTcRef emptyVarSet
1339 ; uniq <- newUnique
1340 ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
1341 ; return (EvBindsVar { ebv_binds = binds_ref
1342 , ebv_tcvs = tcvs_ref
1343 , ebv_uniq = uniq }) }
1344
1345 getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
1346 getTcEvTyCoVars (EvBindsVar { ebv_tcvs = ev_ref })
1347 = readTcRef ev_ref
1348
1349 getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
1350 getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref })
1351 = readTcRef ev_ref
1352
1353 addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
1354 -- Add a binding to the TcEvBinds by side effect
1355 addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind
1356 = do { traceTc "addTcEvBind" $ ppr u $$
1357 ppr ev_bind
1358 ; bnds <- readTcRef ev_ref
1359 ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
1360
1361 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
1362 chooseUniqueOccTc fn =
1363 do { env <- getGblEnv
1364 ; let dfun_n_var = tcg_dfun_n env
1365 ; set <- readTcRef dfun_n_var
1366 ; let occ = fn set
1367 ; writeTcRef dfun_n_var (extendOccSet set occ)
1368 ; return occ }
1369
1370 getConstraintVar :: TcM (TcRef WantedConstraints)
1371 getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
1372
1373 setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
1374 setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
1375
1376 emitStaticConstraints :: WantedConstraints -> TcM ()
1377 emitStaticConstraints static_lie
1378 = do { gbl_env <- getGblEnv
1379 ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) }
1380
1381 emitConstraints :: WantedConstraints -> TcM ()
1382 emitConstraints ct
1383 = do { lie_var <- getConstraintVar ;
1384 updTcRef lie_var (`andWC` ct) }
1385
1386 emitSimple :: Ct -> TcM ()
1387 emitSimple ct
1388 = do { lie_var <- getConstraintVar ;
1389 updTcRef lie_var (`addSimples` unitBag ct) }
1390
1391 emitSimples :: Cts -> TcM ()
1392 emitSimples cts
1393 = do { lie_var <- getConstraintVar ;
1394 updTcRef lie_var (`addSimples` cts) }
1395
1396 emitImplication :: Implication -> TcM ()
1397 emitImplication ct
1398 = do { lie_var <- getConstraintVar ;
1399 updTcRef lie_var (`addImplics` unitBag ct) }
1400
1401 emitImplications :: Bag Implication -> TcM ()
1402 emitImplications ct
1403 = unless (isEmptyBag ct) $
1404 do { lie_var <- getConstraintVar ;
1405 updTcRef lie_var (`addImplics` ct) }
1406
1407 emitInsoluble :: Ct -> TcM ()
1408 emitInsoluble ct
1409 = do { traceTc "emitInsoluble" (ppr ct)
1410 ; lie_var <- getConstraintVar
1411 ; updTcRef lie_var (`addInsols` unitBag ct) }
1412
1413 emitInsolubles :: Cts -> TcM ()
1414 emitInsolubles cts
1415 | isEmptyBag cts = return ()
1416 | otherwise = do { traceTc "emitInsolubles" (ppr cts)
1417 ; lie_var <- getConstraintVar
1418 ; updTcRef lie_var (`addInsols` cts) }
1419
1420 -- | Throw out any constraints emitted by the thing_inside
1421 discardConstraints :: TcM a -> TcM a
1422 discardConstraints thing_inside = fst <$> captureConstraints thing_inside
1423
1424 tryCaptureConstraints :: TcM a -> TcM (Either IOEnvFailure a, WantedConstraints)
1425 -- (captureConstraints_maybe m) runs m,
1426 -- and returns the type constraints it generates
1427 -- It never throws an exception; instead if thing_inside fails,
1428 -- it returns Left exn and the insoluble constraints
1429 tryCaptureConstraints thing_inside
1430 = do { lie_var <- newTcRef emptyWC
1431 ; mb_res <- tryM $
1432 updLclEnv (\ env -> env { tcl_lie = lie_var }) $
1433 thing_inside
1434 ; lie <- readTcRef lie_var
1435
1436 -- See Note [Constraints and errors]
1437 ; let lie_to_keep = case mb_res of
1438 Left {} -> insolublesOnly lie
1439 Right {} -> lie
1440
1441 ; return (mb_res, lie_to_keep) }
1442
1443 captureConstraints :: TcM a -> TcM (a, WantedConstraints)
1444 -- (captureConstraints m) runs m, and returns the type constraints it generates
1445 captureConstraints thing_inside
1446 = do { (mb_res, lie) <- tryCaptureConstraints thing_inside
1447
1448 -- See Note [Constraints and errors]
1449 -- If the thing_inside threw an exception, emit the insoluble
1450 -- constraints only (returned by tryCaptureConstraints)
1451 -- so that they are not lost
1452 ; case mb_res of
1453 Left _ -> do { emitConstraints lie; failM }
1454 Right res -> return (res, lie) }
1455
1456 pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
1457 pushLevelAndCaptureConstraints thing_inside
1458 = do { env <- getLclEnv
1459 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1460 ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $
1461 captureConstraints thing_inside
1462 ; return (tclvl', lie, res) }
1463
1464 pushTcLevelM_ :: TcM a -> TcM a
1465 pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
1466
1467 pushTcLevelM :: TcM a -> TcM (a, TcLevel)
1468 -- See Note [TcLevel assignment] in TcType
1469 pushTcLevelM thing_inside
1470 = do { env <- getLclEnv
1471 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1472 ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
1473 thing_inside
1474 ; return (res, tclvl') }
1475
1476 getTcLevel :: TcM TcLevel
1477 getTcLevel = do { env <- getLclEnv
1478 ; return (tcl_tclvl env) }
1479
1480 setTcLevel :: TcLevel -> TcM a -> TcM a
1481 setTcLevel tclvl thing_inside
1482 = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
1483
1484 isTouchableTcM :: TcTyVar -> TcM Bool
1485 isTouchableTcM tv
1486 = do { env <- getLclEnv
1487 ; return (isTouchableMetaTyVar (tcl_tclvl env) tv) }
1488
1489 getLclTypeEnv :: TcM TcTypeEnv
1490 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
1491
1492 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
1493 -- Set the local type envt, but do *not* disturb other fields,
1494 -- notably the lie_var
1495 setLclTypeEnv lcl_env thing_inside
1496 = updLclEnv upd thing_inside
1497 where
1498 upd env = env { tcl_env = tcl_env lcl_env,
1499 tcl_tyvars = tcl_tyvars lcl_env }
1500
1501 traceTcConstraints :: String -> TcM ()
1502 traceTcConstraints msg
1503 = do { lie_var <- getConstraintVar
1504 ; lie <- readTcRef lie_var
1505 ; traceOptTcRn Opt_D_dump_tc_trace $
1506 hang (text (msg ++ ": LIE:")) 2 (ppr lie)
1507 }
1508
1509 emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
1510 emitWildCardHoleConstraints wcs
1511 = do { ct_loc <- getCtLocM HoleOrigin Nothing
1512 ; emitInsolubles $ listToBag $
1513 map (do_one ct_loc) wcs }
1514 where
1515 do_one :: CtLoc -> (Name, TcTyVar) -> Ct
1516 do_one ct_loc (name, tv)
1517 = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv
1518 , ctev_loc = ct_loc' }
1519 , cc_hole = TypeHole (occName name) }
1520 where
1521 real_span = case nameSrcSpan name of
1522 RealSrcSpan span -> span
1523 UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints"
1524 (ppr name <+> quotes (ftext str))
1525 -- Wildcards are defined locally, and so have RealSrcSpans
1526 ct_loc' = setCtLocSpan ct_loc real_span
1527
1528 {- Note [Constraints and errors]
1529 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1530 Consider this (Trac #12124):
1531
1532 foo :: Maybe Int
1533 foo = return (case Left 3 of
1534 Left -> 1 -- Hard error here!
1535 _ -> 0)
1536
1537 The call to 'return' will generate a (Monad m) wanted constraint; but
1538 then there'll be "hard error" (i.e. an exception in the TcM monad), from
1539 the unsaturated Left constructor pattern.
1540
1541 We'll recover in tcPolyBinds, using recoverM. But then the final
1542 tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly
1543 un-filled-in, and will emit a misleading error message.
1544
1545 The underlying problem is that an exception interrupts the constraint
1546 gathering process. Bottom line: if we have an exception, it's best
1547 simply to discard any gathered constraints. Hence in 'try_m' we
1548 capture the constraints in a fresh variable, and only emit them into
1549 the surrounding context if we exit normally. If an exception is
1550 raised, simply discard the collected constraints... we have a hard
1551 error to report. So this capture-the-emit dance isn't as stupid as it
1552 looks :-).
1553
1554 However suppose we throw an exception inside an invocation of
1555 captureConstraints, and discard all the constraints. Some of those
1556 contraints might be "variable out of scope" Hole constraints, and that
1557 might have been the actual original cause of the exception! For
1558 example (Trac #12529):
1559 f = p @ Int
1560 Here 'p' is out of scope, so we get an insolube Hole constraint. But
1561 the visible type application fails in the monad (thows an exception).
1562 We must not discard the out-of-scope error.
1563
1564 So we /retain the insoluble constraints/ if there is an exception.
1565 Hence:
1566 - insolublesOnly in tryCaptureConstraints
1567 - emitConstraints in the Left case of captureConstraints
1568
1569
1570 ************************************************************************
1571 * *
1572 Template Haskell context
1573 * *
1574 ************************************************************************
1575 -}
1576
1577 recordThUse :: TcM ()
1578 recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
1579
1580 recordThSpliceUse :: TcM ()
1581 recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
1582
1583 -- | When generating an out-of-scope error message for a variable matching a
1584 -- binding in a later inter-splice group, the typechecker uses the splice
1585 -- locations to provide details in the message about the scope of that binding.
1586 recordTopLevelSpliceLoc :: SrcSpan -> TcM ()
1587 recordTopLevelSpliceLoc (RealSrcSpan real_loc)
1588 = do { env <- getGblEnv
1589 ; let locs_var = tcg_th_top_level_locs env
1590 ; locs0 <- readTcRef locs_var
1591 ; writeTcRef locs_var (Set.insert real_loc locs0) }
1592 recordTopLevelSpliceLoc (UnhelpfulSpan _) = return ()
1593
1594 getTopLevelSpliceLocs :: TcM (Set RealSrcSpan)
1595 getTopLevelSpliceLocs
1596 = do { env <- getGblEnv
1597 ; readTcRef (tcg_th_top_level_locs env) }
1598
1599 keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set
1600 keepAlive name
1601 = do { env <- getGblEnv
1602 ; traceRn "keep alive" (ppr name)
1603 ; updTcRef (tcg_keep env) (`extendNameSet` name) }
1604
1605 getStage :: TcM ThStage
1606 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
1607
1608 getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
1609 getStageAndBindLevel name
1610 = do { env <- getLclEnv;
1611 ; case lookupNameEnv (tcl_th_bndrs env) name of
1612 Nothing -> return Nothing
1613 Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
1614
1615 setStage :: ThStage -> TcM a -> TcRn a
1616 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
1617
1618 -- | Adds the given modFinalizers to the global environment and set them to use
1619 -- the current local environment.
1620 addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
1621 addModFinalizersWithLclEnv mod_finalizers
1622 = do lcl_env <- getLclEnv
1623 th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
1624 updTcRef th_modfinalizers_var $ \fins ->
1625 setLclEnv lcl_env (runRemoteModFinalizers mod_finalizers)
1626 : fins
1627
1628 {-
1629 ************************************************************************
1630 * *
1631 Safe Haskell context
1632 * *
1633 ************************************************************************
1634 -}
1635
1636 -- | Mark that safe inference has failed
1637 -- See Note [Safe Haskell Overlapping Instances Implementation]
1638 -- although this is used for more than just that failure case.
1639 recordUnsafeInfer :: WarningMessages -> TcM ()
1640 recordUnsafeInfer warns =
1641 getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)
1642
1643 -- | Figure out the final correct safe haskell mode
1644 finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
1645 finalSafeMode dflags tcg_env = do
1646 safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)
1647 return $ case safeHaskell dflags of
1648 Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
1649 | otherwise -> Sf_None
1650 s -> s
1651
1652 -- | Switch instances to safe instances if we're in Safe mode.
1653 fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
1654 fixSafeInstances sfMode | sfMode /= Sf_Safe = id
1655 fixSafeInstances _ = map fixSafe
1656 where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
1657 in inst { is_flag = new_flag }
1658
1659 {-
1660 ************************************************************************
1661 * *
1662 Stuff for the renamer's local env
1663 * *
1664 ************************************************************************
1665 -}
1666
1667 getLocalRdrEnv :: RnM LocalRdrEnv
1668 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
1669
1670 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
1671 setLocalRdrEnv rdr_env thing_inside
1672 = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
1673
1674 {-
1675 ************************************************************************
1676 * *
1677 Stuff for interface decls
1678 * *
1679 ************************************************************************
1680 -}
1681
1682 mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv
1683 mkIfLclEnv mod loc boot
1684 = IfLclEnv { if_mod = mod,
1685 if_loc = loc,
1686 if_boot = boot,
1687 if_nsubst = Nothing,
1688 if_implicits_env = Nothing,
1689 if_tv_env = emptyFsEnv,
1690 if_id_env = emptyFsEnv }
1691
1692 -- | Run an 'IfG' (top-level interface monad) computation inside an existing
1693 -- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
1694 -- based on 'TcGblEnv'.
1695 initIfaceTcRn :: IfG a -> TcRn a
1696 initIfaceTcRn thing_inside
1697 = do { tcg_env <- getGblEnv
1698 ; dflags <- getDynFlags
1699 ; let mod = tcg_semantic_mod tcg_env
1700 -- When we are instantiating a signature, we DEFINITELY
1701 -- do not want to knot tie.
1702 is_instantiate = unitIdIsDefinite (thisPackage dflags) &&
1703 not (null (thisUnitIdInsts dflags))
1704 ; let { if_env = IfGblEnv {
1705 if_doc = text "initIfaceTcRn",
1706 if_rec_types =
1707 if is_instantiate
1708 then Nothing
1709 else Just (mod, get_type_env)
1710 }
1711 ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
1712 ; setEnvs (if_env, ()) thing_inside }
1713
1714 -- Used when sucking in a ModIface into a ModDetails to put in
1715 -- the HPT. Notably, unlike initIfaceCheck, this does NOT use
1716 -- hsc_type_env_var (since we're not actually going to typecheck,
1717 -- so this variable will never get updated!)
1718 initIfaceLoad :: HscEnv -> IfG a -> IO a
1719 initIfaceLoad hsc_env do_this
1720 = do let gbl_env = IfGblEnv {
1721 if_doc = text "initIfaceLoad",
1722 if_rec_types = Nothing
1723 }
1724 initTcRnIf 'i' hsc_env gbl_env () do_this
1725
1726 initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a
1727 -- Used when checking the up-to-date-ness of the old Iface
1728 -- Initialise the environment with no useful info at all
1729 initIfaceCheck doc hsc_env do_this
1730 = do let rec_types = case hsc_type_env_var hsc_env of
1731 Just (mod,var) -> Just (mod, readTcRef var)
1732 Nothing -> Nothing
1733 gbl_env = IfGblEnv {
1734 if_doc = text "initIfaceCheck" <+> doc,
1735 if_rec_types = rec_types
1736 }
1737 initTcRnIf 'i' hsc_env gbl_env () do_this
1738
1739 initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a
1740 initIfaceLcl mod loc_doc hi_boot_file thing_inside
1741 = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside
1742
1743 -- | Initialize interface typechecking, but with a 'NameShape'
1744 -- to apply when typechecking top-level 'OccName's (see
1745 -- 'lookupIfaceTop')
1746 initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a
1747 initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside
1748 = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside
1749
1750 getIfModule :: IfL Module
1751 getIfModule = do { env <- getLclEnv; return (if_mod env) }
1752
1753 --------------------
1754 failIfM :: MsgDoc -> IfL a
1755 -- The Iface monad doesn't have a place to accumulate errors, so we
1756 -- just fall over fast if one happens; it "shouldnt happen".
1757 -- We use IfL here so that we can get context info out of the local env
1758 failIfM msg
1759 = do { env <- getLclEnv
1760 ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1761 ; dflags <- getDynFlags
1762 ; liftIO (log_action dflags dflags NoReason SevFatal
1763 noSrcSpan (defaultErrStyle dflags) full_msg)
1764 ; failM }
1765
1766 --------------------
1767 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1768 -- Run thing_inside in an interleaved thread.
1769 -- It shares everything with the parent thread, so this is DANGEROUS.
1770 --
1771 -- It returns Nothing if the computation fails
1772 --
1773 -- It's used for lazily type-checking interface
1774 -- signatures, which is pretty benign
1775
1776 forkM_maybe doc thing_inside
1777 -- NB: Don't share the mutable env_us with the interleaved thread since env_us
1778 -- does not get updated atomically (e.g. in newUnique and newUniqueSupply).
1779 = do { child_us <- newUniqueSupply
1780 ; child_env_us <- newMutVar child_us
1781 -- see Note [Masking exceptions in forkM_maybe]
1782 ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $
1783 do { traceIf (text "Starting fork {" <+> doc)
1784 ; mb_res <- tryM $
1785 updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1786 thing_inside
1787 ; case mb_res of
1788 Right r -> do { traceIf (text "} ending fork" <+> doc)
1789 ; return (Just r) }
1790 Left exn -> do {
1791
1792 -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1793 -- Otherwise we silently discard errors. Errors can legitimately
1794 -- happen when compiling interface signatures (see tcInterfaceSigs)
1795 whenDOptM Opt_D_dump_if_trace $ do
1796 dflags <- getDynFlags
1797 let msg = hang (text "forkM failed:" <+> doc)
1798 2 (text (show exn))
1799 liftIO $ log_action dflags
1800 dflags
1801 NoReason
1802 SevFatal
1803 noSrcSpan
1804 (defaultErrStyle dflags)
1805 msg
1806
1807 ; traceIf (text "} ending fork (badly)" <+> doc)
1808 ; return Nothing }
1809 }}
1810
1811 forkM :: SDoc -> IfL a -> IfL a
1812 forkM doc thing_inside
1813 = do { mb_res <- forkM_maybe doc thing_inside
1814 ; return (case mb_res of
1815 Nothing -> pgmError "Cannot continue after interface file error"
1816 -- pprPanic "forkM" doc
1817 Just r -> r) }
1818
1819 setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
1820 setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl { if_implicits_env = Just tenv }) m
1821
1822 {-
1823 Note [Masking exceptions in forkM_maybe]
1824 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1825
1826 When using GHC-as-API it must be possible to interrupt snippets of code
1827 executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
1828 by throwing an asynchronous interrupt to the GHC thread. However, there is a
1829 subtle problem: runStmt first typechecks the code before running it, and the
1830 exception might interrupt the type checker rather than the code. Moreover, the
1831 typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
1832 more importantly might be inside an exception handler inside that
1833 unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
1834 asynchronous exception as a synchronous exception, and the exception will end
1835 up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
1836 discussion). We don't currently know a general solution to this problem, but
1837 we can use uninterruptibleMask_ to avoid the situation.
1838 -}