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