Improve error recovery in the typechecker
[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 attemptM, 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
990 -----------------------
991 checkNoErrs :: TcM r -> TcM r
992 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
993 -- If m fails then (checkNoErrsTc m) fails.
994 -- If m succeeds, it checks whether m generated any errors messages
995 -- (it might have recovered internally)
996 -- If so, it fails too.
997 -- Regardless, any errors generated by m are propagated to the enclosing context.
998 checkNoErrs main
999 = do { (res, no_errs) <- askNoErrs main
1000 ; unless no_errs failM
1001 ; return res }
1002
1003 -----------------------
1004 whenNoErrs :: TcM () -> TcM ()
1005 whenNoErrs thing = ifErrsM (return ()) thing
1006
1007 ifErrsM :: TcRn r -> TcRn r -> TcRn r
1008 -- ifErrsM bale_out normal
1009 -- does 'bale_out' if there are errors in errors collection
1010 -- otherwise does 'normal'
1011 ifErrsM bale_out normal
1012 = do { errs_var <- getErrsVar ;
1013 msgs <- readTcRef errs_var ;
1014 dflags <- getDynFlags ;
1015 if errorsFound dflags msgs then
1016 bale_out
1017 else
1018 normal }
1019
1020 failIfErrsM :: TcRn ()
1021 -- Useful to avoid error cascades
1022 failIfErrsM = ifErrsM failM (return ())
1023
1024 checkTH :: a -> String -> TcRn ()
1025 checkTH _ _ = return () -- OK
1026
1027 failTH :: Outputable a => a -> String -> TcRn x
1028 failTH e what -- Raise an error in a stage-1 compiler
1029 = failWithTc (vcat [ hang (char 'A' <+> text what
1030 <+> text "requires GHC with interpreter support:")
1031 2 (ppr e)
1032 , text "Perhaps you are using a stage-1 compiler?" ])
1033
1034
1035 {- *********************************************************************
1036 * *
1037 Context management for the type checker
1038 * *
1039 ************************************************************************
1040 -}
1041
1042 getErrCtxt :: TcM [ErrCtxt]
1043 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
1044
1045 setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
1046 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
1047
1048 -- | Add a fixed message to the error context. This message should not
1049 -- do any tidying.
1050 addErrCtxt :: MsgDoc -> TcM a -> TcM a
1051 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
1052
1053 -- | Add a message to the error context. This message may do tidying.
1054 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
1055 addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
1056
1057 -- | Add a fixed landmark message to the error context. A landmark
1058 -- message is always sure to be reported, even if there is a lot of
1059 -- context. It also doesn't count toward the maximum number of contexts
1060 -- reported.
1061 addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
1062 addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
1063
1064 -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
1065 -- and tidying.
1066 addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
1067 addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts)
1068
1069 -- Helper function for the above
1070 updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
1071 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
1072 env { tcl_ctxt = upd ctxt })
1073
1074 popErrCtxt :: TcM a -> TcM a
1075 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
1076
1077 getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
1078 getCtLocM origin t_or_k
1079 = do { env <- getLclEnv
1080 ; return (CtLoc { ctl_origin = origin
1081 , ctl_env = env
1082 , ctl_t_or_k = t_or_k
1083 , ctl_depth = initialSubGoalDepth }) }
1084
1085 setCtLocM :: CtLoc -> TcM a -> TcM a
1086 -- Set the SrcSpan and error context from the CtLoc
1087 setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
1088 = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
1089 , tcl_bndrs = tcl_bndrs lcl
1090 , tcl_ctxt = tcl_ctxt lcl })
1091 thing_inside
1092
1093
1094 {- *********************************************************************
1095 * *
1096 Error recovery and exceptions
1097 * *
1098 ********************************************************************* -}
1099
1100 tcTryM :: TcRn r -> TcRn (Maybe r)
1101 -- The most basic function: catch the exception
1102 -- Nothing => an exception happened
1103 -- Just r => no exception, result R
1104 -- Errors and constraints are propagated in both cases
1105 -- Never throws an exception
1106 tcTryM thing_inside
1107 = do { either_res <- tryM thing_inside
1108 ; return (case either_res of
1109 Left _ -> Nothing
1110 Right r -> Just r) }
1111 -- In the Left case the exception is always the IOEnv
1112 -- built-in in exception; see IOEnv.failM
1113
1114 -----------------------
1115 capture_constraints :: TcM r -> TcM (r, WantedConstraints)
1116 -- capture_constraints simply captures and returns the
1117 -- constraints generated by thing_inside
1118 -- Precondition: thing_inside must not throw an exception!
1119 -- Reason for precondition: an exception would blow past the place
1120 -- where we read the lie_var, and we'd lose the constraints altogether
1121 capture_constraints thing_inside
1122 = do { lie_var <- newTcRef emptyWC
1123 ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) $
1124 thing_inside
1125 ; lie <- readTcRef lie_var
1126 ; return (res, lie) }
1127
1128 capture_messages :: TcM r -> TcM (r, Messages)
1129 -- capture_messages simply captures and returns the
1130 -- errors arnd warnings generated by thing_inside
1131 -- Precondition: thing_inside must not throw an exception!
1132 -- Reason for precondition: an exception would blow past the place
1133 -- where we read the msg_var, and we'd lose the constraints altogether
1134 capture_messages thing_inside
1135 = do { msg_var <- newTcRef emptyMessages
1136 ; res <- setErrsVar msg_var thing_inside
1137 ; msgs <- readTcRef msg_var
1138 ; return (res, msgs) }
1139
1140 -----------------------
1141 -- (askNoErrs m) runs m
1142 -- If m fails,
1143 -- then (askNoErrs m) fails, propagating only
1144 -- insoluble constraints
1145 --
1146 -- If m succeeds with result r,
1147 -- then (askNoErrs m) succeeds with result (r, b),
1148 -- where b is True iff m generated no errors
1149 --
1150 -- Regardless of success or failure,
1151 -- propagate any errors/warnings generated by m
1152 askNoErrs :: TcRn a -> TcRn (a, Bool)
1153 askNoErrs thing_inside
1154 = do { ((mb_res, lie), msgs) <- capture_messages $
1155 capture_constraints $
1156 tcTryM thing_inside
1157 ; addMessages msgs
1158
1159 ; case mb_res of
1160 Nothing -> do { emitConstraints (insolublesOnly lie)
1161 ; failM }
1162
1163 Just res -> do { emitConstraints lie
1164 ; dflags <- getDynFlags
1165 ; let errs_found = errorsFound dflags msgs
1166 || insolubleWC lie
1167 ; return (res, not errs_found) } }
1168
1169 -----------------------
1170 tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints)
1171 -- (tryCaptureConstraints_maybe m) runs m,
1172 -- and returns the type constraints it generates
1173 -- It never throws an exception; instead if thing_inside fails,
1174 -- it returns Nothing and the /insoluble/ constraints
1175 -- Error messages are propagated
1176 tryCaptureConstraints thing_inside
1177 = do { (mb_res, lie) <- capture_constraints $
1178 tcTryM thing_inside
1179
1180 -- See Note [Constraints and errors]
1181 ; let lie_to_keep = case mb_res of
1182 Nothing -> insolublesOnly lie
1183 Just {} -> lie
1184
1185 ; return (mb_res, lie_to_keep) }
1186
1187 captureConstraints :: TcM a -> TcM (a, WantedConstraints)
1188 -- (captureConstraints m) runs m, and returns the type constraints it generates
1189 -- If thing_inside fails (throwing an exception),
1190 -- then (captureConstraints thing_inside) fails too
1191 -- propagating the insoluble constraints only
1192 -- Error messages are propagated in either case
1193 captureConstraints thing_inside
1194 = do { (mb_res, lie) <- tryCaptureConstraints thing_inside
1195
1196 -- See Note [Constraints and errors]
1197 -- If the thing_inside threw an exception, emit the insoluble
1198 -- constraints only (returned by tryCaptureConstraints)
1199 -- so that they are not lost
1200 ; case mb_res of
1201 Nothing -> do { emitConstraints lie; failM }
1202 Just res -> return (res, lie) }
1203
1204 -----------------------
1205 attemptM :: TcRn r -> TcRn (Maybe r)
1206 -- (attemptM thing_inside) runs thing_inside
1207 -- If thing_inside succeeds, returning r,
1208 -- we return (Just r), and propagate all constraints and errors
1209 -- If thing_inside fail, throwing an exception,
1210 -- we return Nothing, propagating insoluble constraints,
1211 -- and all errors
1212 -- attemptM never throws an exception
1213 attemptM thing_inside
1214 = do { (mb_r, lie) <- tryCaptureConstraints thing_inside
1215 ; emitConstraints lie
1216
1217 -- Debug trace
1218 ; when (isNothing mb_r) $
1219 traceTc "attemptM recovering with insoluble constraints" $
1220 (ppr lie)
1221
1222 ; return mb_r }
1223
1224 -----------------------
1225 recoverM :: TcRn r -- Recovery action; do this if the main one fails
1226 -> TcRn r -- Main action: do this first;
1227 -- if it generates errors, propagate them all
1228 -> TcRn r
1229 -- (recoverM recover thing_inside) runs thing_inside
1230 -- If thing_inside fails, propagate its errors and insoluble constraints
1231 -- and run 'recover'
1232 -- If thing_inside succeeds, propagate all its errors and constraints
1233 --
1234 -- Can fail, if 'recover' fails
1235 recoverM recover thing
1236 = do { mb_res <- attemptM thing ;
1237 case mb_res of
1238 Nothing -> recover
1239 Just res -> return res }
1240
1241 -----------------------
1242
1243 -- | Drop elements of the input that fail, so the result
1244 -- list can be shorter than the argument list
1245 mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
1246 mapAndRecoverM f xs
1247 = do { mb_rs <- mapM (attemptM . f) xs
1248 ; return [r | Just r <- mb_rs] }
1249
1250 -- | Apply the function to all elements on the input list
1251 -- If all succeed, return the list of results
1252 -- Othewise fail, propagating all errors
1253 mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
1254 mapAndReportM f xs
1255 = do { mb_rs <- mapM (attemptM . f) xs
1256 ; when (any isNothing mb_rs) failM
1257 ; return [r | Just r <- mb_rs] }
1258
1259 -- | The accumulator is not updated if the action fails
1260 foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
1261 foldAndRecoverM _ acc [] = return acc
1262 foldAndRecoverM f acc (x:xs) =
1263 do { mb_r <- attemptM (f acc x)
1264 ; case mb_r of
1265 Nothing -> foldAndRecoverM f acc xs
1266 Just acc' -> foldAndRecoverM f acc' xs }
1267
1268 -----------------------
1269 tryTc :: TcRn a -> TcRn (Maybe a, Messages)
1270 -- (tryTc m) executes m, and returns
1271 -- Just r, if m succeeds (returning r)
1272 -- Nothing, if m fails
1273 -- It also returns all the errors and warnings accumulated by m
1274 -- It always succeeds (never raises an exception)
1275 tryTc thing_inside
1276 = capture_messages (attemptM thing_inside)
1277
1278 -----------------------
1279 discardErrs :: TcRn a -> TcRn a
1280 -- (discardErrs m) runs m,
1281 -- discarding all error messages and warnings generated by m
1282 -- If m fails, discardErrs fails, and vice versa
1283 discardErrs m
1284 = do { errs_var <- newTcRef emptyMessages
1285 ; setErrsVar errs_var m }
1286
1287 -----------------------
1288 tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r
1289 -- (tryTcDiscardingErrs recover thing_inside) tries 'thing_inside';
1290 -- if 'main' succeeds with no error messages, it's the answer
1291 -- otherwise discard everything from 'main', including errors,
1292 -- and try 'recover' instead.
1293 tryTcDiscardingErrs recover thing_inside
1294 = do { ((mb_res, lie), msgs) <- capture_messages $
1295 capture_constraints $
1296 tcTryM thing_inside
1297 ; dflags <- getDynFlags
1298 ; case mb_res of
1299 Just res | not (errorsFound dflags msgs)
1300 , not (insolubleWC lie)
1301 -> -- 'main' succeeed with no errors
1302 do { addMessages msgs -- msgs might still have warnings
1303 ; emitConstraints lie
1304 ; return res }
1305
1306 _ -> -- 'main' failed, or produced an error message
1307 recover -- Discard all errors and warnings
1308 -- and unsolved constraints entirely
1309 }
1310
1311 {-
1312 ************************************************************************
1313 * *
1314 Error message generation (type checker)
1315 * *
1316 ************************************************************************
1317
1318 The addErrTc functions add an error message, but do not cause failure.
1319 The 'M' variants pass a TidyEnv that has already been used to
1320 tidy up the message; we then use it to tidy the context messages
1321 -}
1322
1323 addErrTc :: MsgDoc -> TcM ()
1324 addErrTc err_msg = do { env0 <- tcInitTidyEnv
1325 ; addErrTcM (env0, err_msg) }
1326
1327 addErrsTc :: [MsgDoc] -> TcM ()
1328 addErrsTc err_msgs = mapM_ addErrTc err_msgs
1329
1330 addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()
1331 addErrTcM (tidy_env, err_msg)
1332 = do { ctxt <- getErrCtxt ;
1333 loc <- getSrcSpanM ;
1334 add_err_tcm tidy_env err_msg loc ctxt }
1335
1336 -- Return the error message, instead of reporting it straight away
1337 mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg
1338 mkErrTcM (tidy_env, err_msg)
1339 = do { ctxt <- getErrCtxt ;
1340 loc <- getSrcSpanM ;
1341 err_info <- mkErrInfo tidy_env ctxt ;
1342 mkLongErrAt loc err_msg err_info }
1343
1344 mkErrTc :: MsgDoc -> TcM ErrMsg
1345 mkErrTc msg = do { env0 <- tcInitTidyEnv
1346 ; mkErrTcM (env0, msg) }
1347
1348 -- The failWith functions add an error message and cause failure
1349
1350 failWithTc :: MsgDoc -> TcM a -- Add an error message and fail
1351 failWithTc err_msg
1352 = addErrTc err_msg >> failM
1353
1354 failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail
1355 failWithTcM local_and_msg
1356 = addErrTcM local_and_msg >> failM
1357
1358 checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true
1359 checkTc True _ = return ()
1360 checkTc False err = failWithTc err
1361
1362 checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
1363 checkTcM True _ = return ()
1364 checkTcM False err = failWithTcM err
1365
1366 failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false
1367 failIfTc False _ = return ()
1368 failIfTc True err = failWithTc err
1369
1370 failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
1371 -- Check that the boolean is false
1372 failIfTcM False _ = return ()
1373 failIfTcM True err = failWithTcM err
1374
1375
1376 -- Warnings have no 'M' variant, nor failure
1377
1378 -- | Display a warning if a condition is met,
1379 -- and the warning is enabled
1380 warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn ()
1381 warnIfFlag warn_flag is_bad msg
1382 = do { warn_on <- woptM warn_flag
1383 ; when (warn_on && is_bad) $
1384 addWarn (Reason warn_flag) msg }
1385
1386 -- | Display a warning if a condition is met.
1387 warnIf :: Bool -> MsgDoc -> TcRn ()
1388 warnIf is_bad msg
1389 = when is_bad (addWarn NoReason msg)
1390
1391 -- | Display a warning if a condition is met.
1392 warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()
1393 warnTc reason warn_if_true warn_msg
1394 | warn_if_true = addWarnTc reason warn_msg
1395 | otherwise = return ()
1396
1397 -- | Display a warning if a condition is met.
1398 warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()
1399 warnTcM reason warn_if_true warn_msg
1400 | warn_if_true = addWarnTcM reason warn_msg
1401 | otherwise = return ()
1402
1403 -- | Display a warning in the current context.
1404 addWarnTc :: WarnReason -> MsgDoc -> TcM ()
1405 addWarnTc reason msg
1406 = do { env0 <- tcInitTidyEnv ;
1407 addWarnTcM reason (env0, msg) }
1408
1409 -- | Display a warning in a given context.
1410 addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()
1411 addWarnTcM reason (env0, msg)
1412 = do { ctxt <- getErrCtxt ;
1413 err_info <- mkErrInfo env0 ctxt ;
1414 add_warn reason msg err_info }
1415
1416 -- | Display a warning for the current source location.
1417 addWarn :: WarnReason -> MsgDoc -> TcRn ()
1418 addWarn reason msg = add_warn reason msg Outputable.empty
1419
1420 -- | Display a warning for a given source location.
1421 addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
1422 addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty
1423
1424 -- | Display a warning, with an optional flag, for the current source
1425 -- location.
1426 add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()
1427 add_warn reason msg extra_info
1428 = do { loc <- getSrcSpanM
1429 ; add_warn_at reason loc msg extra_info }
1430
1431 -- | Display a warning, with an optional flag, for a given location.
1432 add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
1433 add_warn_at reason loc msg extra_info
1434 = do { dflags <- getDynFlags ;
1435 printer <- getPrintUnqualified dflags ;
1436 let { warn = mkLongWarnMsg dflags loc printer
1437 msg extra_info } ;
1438 reportWarning reason warn }
1439
1440
1441 {-
1442 -----------------------------------
1443 Other helper functions
1444 -}
1445
1446 add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan
1447 -> [ErrCtxt]
1448 -> TcM ()
1449 add_err_tcm tidy_env err_msg loc ctxt
1450 = do { err_info <- mkErrInfo tidy_env ctxt ;
1451 addLongErrAt loc err_msg err_info }
1452
1453 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
1454 -- Tidy the error info, trimming excessive contexts
1455 mkErrInfo env ctxts
1456 -- = do
1457 -- dbg <- hasPprDebug <$> getDynFlags
1458 -- if dbg -- In -dppr-debug style the output
1459 -- then return empty -- just becomes too voluminous
1460 -- else go dbg 0 env ctxts
1461 = go False 0 env ctxts
1462 where
1463 go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
1464 go _ _ _ [] = return empty
1465 go dbg n env ((is_landmark, ctxt) : ctxts)
1466 | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg
1467 = do { (env', msg) <- ctxt env
1468 ; let n' = if is_landmark then n else n+1
1469 ; rest <- go dbg n' env' ctxts
1470 ; return (msg $$ rest) }
1471 | otherwise
1472 = go dbg n env ctxts
1473
1474 mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts
1475 mAX_CONTEXTS = 3
1476
1477 -- debugTc is useful for monadic debugging code
1478
1479 debugTc :: TcM () -> TcM ()
1480 debugTc thing
1481 | debugIsOn = thing
1482 | otherwise = return ()
1483
1484 {-
1485 ************************************************************************
1486 * *
1487 Type constraints
1488 * *
1489 ************************************************************************
1490 -}
1491
1492 addTopEvBinds :: Bag EvBind -> TcM a -> TcM a
1493 addTopEvBinds new_ev_binds thing_inside
1494 =updGblEnv upd_env thing_inside
1495 where
1496 upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env
1497 `unionBags` new_ev_binds }
1498
1499 newTcEvBinds :: TcM EvBindsVar
1500 newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
1501 ; tcvs_ref <- newTcRef emptyVarSet
1502 ; uniq <- newUnique
1503 ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
1504 ; return (EvBindsVar { ebv_binds = binds_ref
1505 , ebv_tcvs = tcvs_ref
1506 , ebv_uniq = uniq }) }
1507
1508 -- | Creates an EvBindsVar incapable of holding any bindings. It still
1509 -- tracks covar usages (see comments on ebv_tcvs in TcEvidence), thus
1510 -- must be made monadically
1511 newNoTcEvBinds :: TcM EvBindsVar
1512 newNoTcEvBinds
1513 = do { tcvs_ref <- newTcRef emptyVarSet
1514 ; uniq <- newUnique
1515 ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq)
1516 ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref
1517 , ebv_uniq = uniq }) }
1518
1519 cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar
1520 -- Clone the refs, so that any binding created when
1521 -- solving don't pollute the original
1522 cloneEvBindsVar ebv@(EvBindsVar {})
1523 = do { binds_ref <- newTcRef emptyEvBindMap
1524 ; tcvs_ref <- newTcRef emptyVarSet
1525 ; return (ebv { ebv_binds = binds_ref
1526 , ebv_tcvs = tcvs_ref }) }
1527 cloneEvBindsVar ebv@(CoEvBindsVar {})
1528 = do { tcvs_ref <- newTcRef emptyVarSet
1529 ; return (ebv { ebv_tcvs = tcvs_ref }) }
1530
1531 getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
1532 getTcEvTyCoVars ev_binds_var
1533 = readTcRef (ebv_tcvs ev_binds_var)
1534
1535 getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
1536 getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref })
1537 = readTcRef ev_ref
1538 getTcEvBindsMap (CoEvBindsVar {})
1539 = return emptyEvBindMap
1540
1541 setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM ()
1542 setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds
1543 = writeTcRef ev_ref binds
1544 setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds
1545 | isEmptyEvBindMap ev_binds
1546 = return ()
1547 | otherwise
1548 = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds)
1549
1550 addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
1551 -- Add a binding to the TcEvBinds by side effect
1552 addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind
1553 = do { traceTc "addTcEvBind" $ ppr u $$
1554 ppr ev_bind
1555 ; bnds <- readTcRef ev_ref
1556 ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
1557 addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind
1558 = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u)
1559
1560 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
1561 chooseUniqueOccTc fn =
1562 do { env <- getGblEnv
1563 ; let dfun_n_var = tcg_dfun_n env
1564 ; set <- readTcRef dfun_n_var
1565 ; let occ = fn set
1566 ; writeTcRef dfun_n_var (extendOccSet set occ)
1567 ; return occ }
1568
1569 getConstraintVar :: TcM (TcRef WantedConstraints)
1570 getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
1571
1572 setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
1573 setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
1574
1575 emitStaticConstraints :: WantedConstraints -> TcM ()
1576 emitStaticConstraints static_lie
1577 = do { gbl_env <- getGblEnv
1578 ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) }
1579
1580 emitConstraints :: WantedConstraints -> TcM ()
1581 emitConstraints ct
1582 | isEmptyWC ct
1583 = return ()
1584 | otherwise
1585 = do { lie_var <- getConstraintVar ;
1586 updTcRef lie_var (`andWC` ct) }
1587
1588 emitSimple :: Ct -> TcM ()
1589 emitSimple ct
1590 = do { lie_var <- getConstraintVar ;
1591 updTcRef lie_var (`addSimples` unitBag ct) }
1592
1593 emitSimples :: Cts -> TcM ()
1594 emitSimples cts
1595 = do { lie_var <- getConstraintVar ;
1596 updTcRef lie_var (`addSimples` cts) }
1597
1598 emitImplication :: Implication -> TcM ()
1599 emitImplication ct
1600 = do { lie_var <- getConstraintVar ;
1601 updTcRef lie_var (`addImplics` unitBag ct) }
1602
1603 emitImplications :: Bag Implication -> TcM ()
1604 emitImplications ct
1605 = unless (isEmptyBag ct) $
1606 do { lie_var <- getConstraintVar ;
1607 updTcRef lie_var (`addImplics` ct) }
1608
1609 emitInsoluble :: Ct -> TcM ()
1610 emitInsoluble ct
1611 = do { traceTc "emitInsoluble" (ppr ct)
1612 ; lie_var <- getConstraintVar
1613 ; updTcRef lie_var (`addInsols` unitBag ct) }
1614
1615 emitInsolubles :: Cts -> TcM ()
1616 emitInsolubles cts
1617 | isEmptyBag cts = return ()
1618 | otherwise = do { traceTc "emitInsolubles" (ppr cts)
1619 ; lie_var <- getConstraintVar
1620 ; updTcRef lie_var (`addInsols` cts) }
1621
1622 -- | Throw out any constraints emitted by the thing_inside
1623 discardConstraints :: TcM a -> TcM a
1624 discardConstraints thing_inside = fst <$> captureConstraints thing_inside
1625
1626 -- | The name says it all. The returned TcLevel is the *inner* TcLevel.
1627 pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
1628 pushLevelAndCaptureConstraints thing_inside
1629 = do { env <- getLclEnv
1630 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1631 ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl')
1632 ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $
1633 captureConstraints thing_inside
1634 ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl')
1635 ; return (tclvl', lie, res) }
1636
1637 pushTcLevelM_ :: TcM a -> TcM a
1638 pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
1639
1640 pushTcLevelM :: TcM a -> TcM (TcLevel, a)
1641 -- See Note [TcLevel assignment] in TcType
1642 pushTcLevelM thing_inside
1643 = do { env <- getLclEnv
1644 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1645 ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
1646 thing_inside
1647 ; return (tclvl', res) }
1648
1649 -- Returns pushed TcLevel
1650 pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel)
1651 pushTcLevelsM num_levels thing_inside
1652 = do { env <- getLclEnv
1653 ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env)
1654 ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $
1655 thing_inside
1656 ; return (res, tclvl') }
1657
1658 getTcLevel :: TcM TcLevel
1659 getTcLevel = do { env <- getLclEnv
1660 ; return (tcl_tclvl env) }
1661
1662 setTcLevel :: TcLevel -> TcM a -> TcM a
1663 setTcLevel tclvl thing_inside
1664 = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
1665
1666 isTouchableTcM :: TcTyVar -> TcM Bool
1667 isTouchableTcM tv
1668 = do { lvl <- getTcLevel
1669 ; return (isTouchableMetaTyVar lvl tv) }
1670
1671 getLclTypeEnv :: TcM TcTypeEnv
1672 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
1673
1674 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
1675 -- Set the local type envt, but do *not* disturb other fields,
1676 -- notably the lie_var
1677 setLclTypeEnv lcl_env thing_inside
1678 = updLclEnv upd thing_inside
1679 where
1680 upd env = env { tcl_env = tcl_env lcl_env,
1681 tcl_tyvars = tcl_tyvars lcl_env }
1682
1683 traceTcConstraints :: String -> TcM ()
1684 traceTcConstraints msg
1685 = do { lie_var <- getConstraintVar
1686 ; lie <- readTcRef lie_var
1687 ; traceOptTcRn Opt_D_dump_tc_trace $
1688 hang (text (msg ++ ": LIE:")) 2 (ppr lie)
1689 }
1690
1691 emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
1692 emitWildCardHoleConstraints wcs
1693 = do { ct_loc <- getCtLocM HoleOrigin Nothing
1694 ; emitInsolubles $ listToBag $
1695 map (do_one ct_loc) wcs }
1696 where
1697 do_one :: CtLoc -> (Name, TcTyVar) -> Ct
1698 do_one ct_loc (name, tv)
1699 = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv
1700 , ctev_loc = ct_loc' }
1701 , cc_hole = TypeHole (occName name) }
1702 where
1703 real_span = case nameSrcSpan name of
1704 RealSrcSpan span -> span
1705 UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints"
1706 (ppr name <+> quotes (ftext str))
1707 -- Wildcards are defined locally, and so have RealSrcSpans
1708 ct_loc' = setCtLocSpan ct_loc real_span
1709
1710 {- Note [Constraints and errors]
1711 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1712 Consider this (#12124):
1713
1714 foo :: Maybe Int
1715 foo = return (case Left 3 of
1716 Left -> 1 -- Hard error here!
1717 _ -> 0)
1718
1719 The call to 'return' will generate a (Monad m) wanted constraint; but
1720 then there'll be "hard error" (i.e. an exception in the TcM monad), from
1721 the unsaturated Left constructor pattern.
1722
1723 We'll recover in tcPolyBinds, using recoverM. But then the final
1724 tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly
1725 un-filled-in, and will emit a misleading error message.
1726
1727 The underlying problem is that an exception interrupts the constraint
1728 gathering process. Bottom line: if we have an exception, it's best
1729 simply to discard any gathered constraints. Hence in 'attemptM' we
1730 capture the constraints in a fresh variable, and only emit them into
1731 the surrounding context if we exit normally. If an exception is
1732 raised, simply discard the collected constraints... we have a hard
1733 error to report. So this capture-the-emit dance isn't as stupid as it
1734 looks :-).
1735
1736 However suppose we throw an exception inside an invocation of
1737 captureConstraints, and discard all the constraints. Some of those
1738 constraints might be "variable out of scope" Hole constraints, and that
1739 might have been the actual original cause of the exception! For
1740 example (#12529):
1741 f = p @ Int
1742 Here 'p' is out of scope, so we get an insolube Hole constraint. But
1743 the visible type application fails in the monad (thows an exception).
1744 We must not discard the out-of-scope error.
1745
1746 So we /retain the insoluble constraints/ if there is an exception.
1747 Hence:
1748 - insolublesOnly in tryCaptureConstraints
1749 - emitConstraints in the Left case of captureConstraints
1750
1751 However note that freshly-generated constraints like (Int ~ Bool), or
1752 ((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as
1753 insoluble. The constraint solver does that. So they'll be discarded.
1754 That's probably ok; but see th/5358 as a not-so-good example:
1755 t1 :: Int
1756 t1 x = x -- Manifestly wrong
1757
1758 foo = $(...raises exception...)
1759 We report the exception, but not the bug in t1. Oh well. Possible
1760 solution: make TcUnify.uType spot manifestly-insoluble constraints.
1761
1762
1763 ************************************************************************
1764 * *
1765 Template Haskell context
1766 * *
1767 ************************************************************************
1768 -}
1769
1770 recordThUse :: TcM ()
1771 recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
1772
1773 recordThSpliceUse :: TcM ()
1774 recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
1775
1776 -- | When generating an out-of-scope error message for a variable matching a
1777 -- binding in a later inter-splice group, the typechecker uses the splice
1778 -- locations to provide details in the message about the scope of that binding.
1779 recordTopLevelSpliceLoc :: SrcSpan -> TcM ()
1780 recordTopLevelSpliceLoc (RealSrcSpan real_loc)
1781 = do { env <- getGblEnv
1782 ; let locs_var = tcg_th_top_level_locs env
1783 ; locs0 <- readTcRef locs_var
1784 ; writeTcRef locs_var (Set.insert real_loc locs0) }
1785 recordTopLevelSpliceLoc (UnhelpfulSpan _) = return ()
1786
1787 getTopLevelSpliceLocs :: TcM (Set RealSrcSpan)
1788 getTopLevelSpliceLocs
1789 = do { env <- getGblEnv
1790 ; readTcRef (tcg_th_top_level_locs env) }
1791
1792 keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set
1793 keepAlive name
1794 = do { env <- getGblEnv
1795 ; traceRn "keep alive" (ppr name)
1796 ; updTcRef (tcg_keep env) (`extendNameSet` name) }
1797
1798 getStage :: TcM ThStage
1799 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
1800
1801 getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
1802 getStageAndBindLevel name
1803 = do { env <- getLclEnv;
1804 ; case lookupNameEnv (tcl_th_bndrs env) name of
1805 Nothing -> return Nothing
1806 Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
1807
1808 setStage :: ThStage -> TcM a -> TcRn a
1809 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
1810
1811 -- | Adds the given modFinalizers to the global environment and set them to use
1812 -- the current local environment.
1813 addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
1814 addModFinalizersWithLclEnv mod_finalizers
1815 = do lcl_env <- getLclEnv
1816 th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
1817 updTcRef th_modfinalizers_var $ \fins ->
1818 (lcl_env, mod_finalizers) : fins
1819
1820 {-
1821 ************************************************************************
1822 * *
1823 Safe Haskell context
1824 * *
1825 ************************************************************************
1826 -}
1827
1828 -- | Mark that safe inference has failed
1829 -- See Note [Safe Haskell Overlapping Instances Implementation]
1830 -- although this is used for more than just that failure case.
1831 recordUnsafeInfer :: WarningMessages -> TcM ()
1832 recordUnsafeInfer warns =
1833 getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)
1834
1835 -- | Figure out the final correct safe haskell mode
1836 finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
1837 finalSafeMode dflags tcg_env = do
1838 safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)
1839 return $ case safeHaskell dflags of
1840 Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
1841 | otherwise -> Sf_None
1842 s -> s
1843
1844 -- | Switch instances to safe instances if we're in Safe mode.
1845 fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
1846 fixSafeInstances sfMode | sfMode /= Sf_Safe = id
1847 fixSafeInstances _ = map fixSafe
1848 where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
1849 in inst { is_flag = new_flag }
1850
1851 {-
1852 ************************************************************************
1853 * *
1854 Stuff for the renamer's local env
1855 * *
1856 ************************************************************************
1857 -}
1858
1859 getLocalRdrEnv :: RnM LocalRdrEnv
1860 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
1861
1862 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
1863 setLocalRdrEnv rdr_env thing_inside
1864 = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
1865
1866 {-
1867 ************************************************************************
1868 * *
1869 Stuff for interface decls
1870 * *
1871 ************************************************************************
1872 -}
1873
1874 mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv
1875 mkIfLclEnv mod loc boot
1876 = IfLclEnv { if_mod = mod,
1877 if_loc = loc,
1878 if_boot = boot,
1879 if_nsubst = Nothing,
1880 if_implicits_env = Nothing,
1881 if_tv_env = emptyFsEnv,
1882 if_id_env = emptyFsEnv }
1883
1884 -- | Run an 'IfG' (top-level interface monad) computation inside an existing
1885 -- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
1886 -- based on 'TcGblEnv'.
1887 initIfaceTcRn :: IfG a -> TcRn a
1888 initIfaceTcRn thing_inside
1889 = do { tcg_env <- getGblEnv
1890 ; dflags <- getDynFlags
1891 ; let !mod = tcg_semantic_mod tcg_env
1892 -- When we are instantiating a signature, we DEFINITELY
1893 -- do not want to knot tie.
1894 is_instantiate = unitIdIsDefinite (thisPackage dflags) &&
1895 not (null (thisUnitIdInsts dflags))
1896 ; let { if_env = IfGblEnv {
1897 if_doc = text "initIfaceTcRn",
1898 if_rec_types =
1899 if is_instantiate
1900 then Nothing
1901 else Just (mod, get_type_env)
1902 }
1903 ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
1904 ; setEnvs (if_env, ()) thing_inside }
1905
1906 -- Used when sucking in a ModIface into a ModDetails to put in
1907 -- the HPT. Notably, unlike initIfaceCheck, this does NOT use
1908 -- hsc_type_env_var (since we're not actually going to typecheck,
1909 -- so this variable will never get updated!)
1910 initIfaceLoad :: HscEnv -> IfG a -> IO a
1911 initIfaceLoad hsc_env do_this
1912 = do let gbl_env = IfGblEnv {
1913 if_doc = text "initIfaceLoad",
1914 if_rec_types = Nothing
1915 }
1916 initTcRnIf 'i' hsc_env gbl_env () do_this
1917
1918 initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a
1919 -- Used when checking the up-to-date-ness of the old Iface
1920 -- Initialise the environment with no useful info at all
1921 initIfaceCheck doc hsc_env do_this
1922 = do let rec_types = case hsc_type_env_var hsc_env of
1923 Just (mod,var) -> Just (mod, readTcRef var)
1924 Nothing -> Nothing
1925 gbl_env = IfGblEnv {
1926 if_doc = text "initIfaceCheck" <+> doc,
1927 if_rec_types = rec_types
1928 }
1929 initTcRnIf 'i' hsc_env gbl_env () do_this
1930
1931 initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a
1932 initIfaceLcl mod loc_doc hi_boot_file thing_inside
1933 = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside
1934
1935 -- | Initialize interface typechecking, but with a 'NameShape'
1936 -- to apply when typechecking top-level 'OccName's (see
1937 -- 'lookupIfaceTop')
1938 initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a
1939 initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside
1940 = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside
1941
1942 getIfModule :: IfL Module
1943 getIfModule = do { env <- getLclEnv; return (if_mod env) }
1944
1945 --------------------
1946 failIfM :: MsgDoc -> IfL a
1947 -- The Iface monad doesn't have a place to accumulate errors, so we
1948 -- just fall over fast if one happens; it "shouldn't happen".
1949 -- We use IfL here so that we can get context info out of the local env
1950 failIfM msg
1951 = do { env <- getLclEnv
1952 ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1953 ; dflags <- getDynFlags
1954 ; liftIO (putLogMsg dflags NoReason SevFatal
1955 noSrcSpan (defaultErrStyle dflags) full_msg)
1956 ; failM }
1957
1958 --------------------
1959 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1960 -- Run thing_inside in an interleaved thread.
1961 -- It shares everything with the parent thread, so this is DANGEROUS.
1962 --
1963 -- It returns Nothing if the computation fails
1964 --
1965 -- It's used for lazily type-checking interface
1966 -- signatures, which is pretty benign
1967
1968 forkM_maybe doc thing_inside
1969 -- NB: Don't share the mutable env_us with the interleaved thread since env_us
1970 -- does not get updated atomically (e.g. in newUnique and newUniqueSupply).
1971 = do { child_us <- newUniqueSupply
1972 ; child_env_us <- newMutVar child_us
1973 -- see Note [Masking exceptions in forkM_maybe]
1974 ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $
1975 do { traceIf (text "Starting fork {" <+> doc)
1976 ; mb_res <- tryM $
1977 updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1978 thing_inside
1979 ; case mb_res of
1980 Right r -> do { traceIf (text "} ending fork" <+> doc)
1981 ; return (Just r) }
1982 Left exn -> do {
1983
1984 -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1985 -- Otherwise we silently discard errors. Errors can legitimately
1986 -- happen when compiling interface signatures (see tcInterfaceSigs)
1987 whenDOptM Opt_D_dump_if_trace $ do
1988 dflags <- getDynFlags
1989 let msg = hang (text "forkM failed:" <+> doc)
1990 2 (text (show exn))
1991 liftIO $ putLogMsg dflags
1992 NoReason
1993 SevFatal
1994 noSrcSpan
1995 (defaultErrStyle dflags)
1996 msg
1997
1998 ; traceIf (text "} ending fork (badly)" <+> doc)
1999 ; return Nothing }
2000 }}
2001
2002 forkM :: SDoc -> IfL a -> IfL a
2003 forkM doc thing_inside
2004 = do { mb_res <- forkM_maybe doc thing_inside
2005 ; return (case mb_res of
2006 Nothing -> pgmError "Cannot continue after interface file error"
2007 -- pprPanic "forkM" doc
2008 Just r -> r) }
2009
2010 setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
2011 setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl
2012 { if_implicits_env = Just tenv }) m
2013
2014 {-
2015 Note [Masking exceptions in forkM_maybe]
2016 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2017
2018 When using GHC-as-API it must be possible to interrupt snippets of code
2019 executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
2020 by throwing an asynchronous interrupt to the GHC thread. However, there is a
2021 subtle problem: runStmt first typechecks the code before running it, and the
2022 exception might interrupt the type checker rather than the code. Moreover, the
2023 typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
2024 more importantly might be inside an exception handler inside that
2025 unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
2026 asynchronous exception as a synchronous exception, and the exception will end
2027 up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
2028 discussion). We don't currently know a general solution to this problem, but
2029 we can use uninterruptibleMask_ to avoid the situation.
2030 -}
2031
2032 -- | Environments which track 'CostCentreState'
2033 class ContainsCostCentreState e where
2034 extractCostCentreState :: e -> TcRef CostCentreState
2035
2036 instance ContainsCostCentreState TcGblEnv where
2037 extractCostCentreState = tcg_cc_st
2038
2039 instance ContainsCostCentreState DsGblEnv where
2040 extractCostCentreState = ds_cc_st
2041
2042 -- | Get the next cost centre index associated with a given name.
2043 getCCIndexM :: (ContainsCostCentreState gbl)
2044 => FastString -> TcRnIf gbl lcl CostCentreIndex
2045 getCCIndexM nm = do
2046 env <- getGblEnv
2047 let cc_st_ref = extractCostCentreState env
2048 cc_st <- readTcRef cc_st_ref
2049 let (idx, cc_st') = getCCIndex nm cc_st
2050 writeTcRef cc_st_ref cc_st'
2051 return idx