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