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