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