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