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