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