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