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