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