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