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