Make TcRnMonad.reportWarning call makeIntoWarning
[ghc.git] / compiler / typecheck / TcRnMonad.hs
1 {-
2 (c) The University of Glasgow 2006
3
4
5 Functions for working with the typechecker environment (setters, getters...).
6 -}
7
8 {-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances #-}
9 {-# OPTIONS_GHC -fno-warn-orphans #-}
10
11 module TcRnMonad(
12 module TcRnMonad,
13 module TcRnTypes,
14 module IOEnv
15 ) where
16
17 #include "HsVersions.h"
18
19 import TcRnTypes -- Re-export all
20 import IOEnv -- Re-export all
21 import TcEvidence
22
23 import HsSyn hiding (LIE)
24 import HscTypes
25 import Module
26 import RdrName
27 import Name
28 import Type
29
30 import TcType
31 import InstEnv
32 import FamInstEnv
33 import PrelNames
34
35 import Id
36 import VarSet
37 import VarEnv
38 import ErrUtils
39 import SrcLoc
40 import NameEnv
41 import NameSet
42 import Bag
43 import Outputable
44 import UniqSupply
45 import UniqFM
46 import DynFlags
47 import StaticFlags
48 import FastString
49 import Panic
50 import Util
51 import Annotations
52 import BasicTypes( TopLevelFlag )
53
54 import Control.Exception
55 import Data.IORef
56 import qualified Data.Set as Set
57 import Control.Monad
58
59 #ifdef GHCI
60 import qualified Data.Map as Map
61 #endif
62
63 {-
64 ************************************************************************
65 * *
66 initTc
67 * *
68 ************************************************************************
69 -}
70
71 -- | Setup the initial typechecking environment
72 initTc :: HscEnv
73 -> HscSource
74 -> Bool -- True <=> retain renamed syntax trees
75 -> Module
76 -> RealSrcSpan
77 -> TcM r
78 -> IO (Messages, Maybe r)
79 -- Nothing => error thrown by the thing inside
80 -- (error messages should have been printed already)
81
82 initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
83 = do { errs_var <- newIORef (emptyBag, emptyBag) ;
84 tvs_var <- newIORef emptyVarSet ;
85 keep_var <- newIORef emptyNameSet ;
86 used_rdr_var <- newIORef Set.empty ;
87 th_var <- newIORef False ;
88 th_splice_var<- newIORef False ;
89 infer_var <- newIORef True ;
90 lie_var <- newIORef emptyWC ;
91 dfun_n_var <- newIORef emptyOccSet ;
92 type_env_var <- case hsc_type_env_var hsc_env of {
93 Just (_mod, te_var) -> return te_var ;
94 Nothing -> newIORef emptyNameEnv } ;
95
96 dependent_files_var <- newIORef [] ;
97 static_wc_var <- newIORef emptyWC ;
98 #ifdef GHCI
99 th_topdecls_var <- newIORef [] ;
100 th_topnames_var <- newIORef emptyNameSet ;
101 th_modfinalizers_var <- newIORef [] ;
102 th_state_var <- newIORef Map.empty ;
103 #endif /* GHCI */
104 let {
105 dflags = hsc_dflags hsc_env ;
106
107 maybe_rn_syntax :: forall a. a -> Maybe a ;
108 maybe_rn_syntax empty_val
109 | keep_rn_syntax = Just empty_val
110 | otherwise = Nothing ;
111
112 gbl_env = TcGblEnv {
113 #ifdef GHCI
114 tcg_th_topdecls = th_topdecls_var,
115 tcg_th_topnames = th_topnames_var,
116 tcg_th_modfinalizers = th_modfinalizers_var,
117 tcg_th_state = th_state_var,
118 #endif /* GHCI */
119
120 tcg_mod = mod,
121 tcg_src = hsc_src,
122 tcg_sig_of = getSigOf dflags (moduleName mod),
123 tcg_impl_rdr_env = Nothing,
124 tcg_rdr_env = emptyGlobalRdrEnv,
125 tcg_fix_env = emptyNameEnv,
126 tcg_field_env = RecFields emptyNameEnv emptyNameSet,
127 tcg_default = Nothing,
128 tcg_type_env = emptyNameEnv,
129 tcg_type_env_var = type_env_var,
130 tcg_inst_env = emptyInstEnv,
131 tcg_fam_inst_env = emptyFamInstEnv,
132 tcg_ann_env = emptyAnnEnv,
133 tcg_visible_orphan_mods = mkModuleSet [mod],
134 tcg_th_used = th_var,
135 tcg_th_splice_used = th_splice_var,
136 tcg_exports = [],
137 tcg_imports = emptyImportAvails,
138 tcg_used_rdrnames = used_rdr_var,
139 tcg_dus = emptyDUs,
140
141 tcg_rn_imports = [],
142 tcg_rn_exports = maybe_rn_syntax [],
143 tcg_rn_decls = maybe_rn_syntax emptyRnGroup,
144
145 tcg_binds = emptyLHsBinds,
146 tcg_imp_specs = [],
147 tcg_sigs = emptyNameSet,
148 tcg_ev_binds = emptyBag,
149 tcg_warns = NoWarnings,
150 tcg_anns = [],
151 tcg_tcs = [],
152 tcg_insts = [],
153 tcg_fam_insts = [],
154 tcg_rules = [],
155 tcg_fords = [],
156 tcg_vects = [],
157 tcg_patsyns = [],
158 tcg_dfun_n = dfun_n_var,
159 tcg_keep = keep_var,
160 tcg_doc_hdr = Nothing,
161 tcg_hpc = False,
162 tcg_main = Nothing,
163 tcg_safeInfer = infer_var,
164 tcg_dependent_files = dependent_files_var,
165 tcg_tc_plugins = [],
166 tcg_static_wc = static_wc_var
167 } ;
168 lcl_env = TcLclEnv {
169 tcl_errs = errs_var,
170 tcl_loc = loc, -- Should be over-ridden very soon!
171 tcl_ctxt = [],
172 tcl_rdr = emptyLocalRdrEnv,
173 tcl_th_ctxt = topStage,
174 tcl_th_bndrs = emptyNameEnv,
175 tcl_arrow_ctxt = NoArrowCtxt,
176 tcl_env = emptyNameEnv,
177 tcl_bndrs = [],
178 tcl_tidy = emptyTidyEnv,
179 tcl_tyvars = tvs_var,
180 tcl_lie = lie_var,
181 tcl_tclvl = topTcLevel
182 } ;
183 } ;
184
185 -- OK, here's the business end!
186 maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
187 do { r <- tryM do_this
188 ; case r of
189 Right res -> return (Just res)
190 Left _ -> return Nothing } ;
191
192 -- Check for unsolved constraints
193 lie <- readIORef lie_var ;
194 if isEmptyWC lie
195 then return ()
196 else pprPanic "initTc: unsolved constraints" (ppr lie) ;
197
198 -- Collect any error messages
199 msgs <- readIORef errs_var ;
200
201 let { final_res | errorsFound dflags msgs = Nothing
202 | otherwise = maybe_res } ;
203
204 return (msgs, final_res)
205 }
206
207
208 initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
209 -- Initialise the type checker monad for use in GHCi
210 initTcInteractive hsc_env thing_inside
211 = initTc hsc_env HsSrcFile False
212 (icInteractiveModule (hsc_IC hsc_env))
213 (realSrcLocSpan interactive_src_loc)
214 thing_inside
215 where
216 interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
217
218 initTcForLookup :: HscEnv -> TcM a -> IO a
219 -- The thing_inside is just going to look up something
220 -- in the environment, so we don't need much setup
221 initTcForLookup hsc_env thing_inside
222 = do { (msgs, m) <- initTcInteractive hsc_env thing_inside
223 ; case m of
224 Nothing -> throwIO $ mkSrcErr $ snd msgs
225 Just x -> return x }
226
227 {-
228 ************************************************************************
229 * *
230 Initialisation
231 * *
232 ************************************************************************
233 -}
234
235 initTcRnIf :: Char -- Tag for unique supply
236 -> HscEnv
237 -> gbl -> lcl
238 -> TcRnIf gbl lcl a
239 -> IO a
240 initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
241 = do { us <- mkSplitUniqSupply uniq_tag ;
242 ; us_var <- newIORef us ;
243
244 ; let { env = Env { env_top = hsc_env,
245 env_us = us_var,
246 env_gbl = gbl_env,
247 env_lcl = lcl_env} }
248
249 ; runIOEnv env thing_inside
250 }
251
252 {-
253 ************************************************************************
254 * *
255 Simple accessors
256 * *
257 ************************************************************************
258 -}
259
260 discardResult :: TcM a -> TcM ()
261 discardResult a = a >> return ()
262
263 getTopEnv :: TcRnIf gbl lcl HscEnv
264 getTopEnv = do { env <- getEnv; return (env_top env) }
265
266 getGblEnv :: TcRnIf gbl lcl gbl
267 getGblEnv = do { env <- getEnv; return (env_gbl env) }
268
269 updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
270 updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
271 env { env_gbl = upd gbl })
272
273 setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
274 setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
275
276 getLclEnv :: TcRnIf gbl lcl lcl
277 getLclEnv = do { env <- getEnv; return (env_lcl env) }
278
279 updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
280 updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
281 env { env_lcl = upd lcl })
282
283 setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
284 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
285
286 getEnvs :: TcRnIf gbl lcl (gbl, lcl)
287 getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
288
289 setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
290 setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
291
292 -- Command-line flags
293
294 xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool
295 xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }
296
297 doptM :: DumpFlag -> TcRnIf gbl lcl Bool
298 doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }
299
300 goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
301 goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) }
302
303 woptM :: WarningFlag -> TcRnIf gbl lcl Bool
304 woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }
305
306 setXOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
307 setXOptM flag = updEnv (\ env@(Env { env_top = top }) ->
308 env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} )
309
310 unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
311 unsetGOptM flag = updEnv (\ env@(Env { env_top = top }) ->
312 env { env_top = top { hsc_dflags = gopt_unset (hsc_dflags top) flag}} )
313
314 unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
315 unsetWOptM flag = updEnv (\ env@(Env { env_top = top }) ->
316 env { env_top = top { hsc_dflags = wopt_unset (hsc_dflags top) flag}} )
317
318 -- | Do it flag is true
319 whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
320 whenDOptM flag thing_inside = do b <- doptM flag
321 when b thing_inside
322
323 whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
324 whenGOptM flag thing_inside = do b <- goptM flag
325 when b thing_inside
326
327 whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
328 whenWOptM flag thing_inside = do b <- woptM flag
329 when b thing_inside
330
331 whenXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
332 whenXOptM flag thing_inside = do b <- xoptM flag
333 when b thing_inside
334
335 getGhcMode :: TcRnIf gbl lcl GhcMode
336 getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
337
338 withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
339 withDoDynamicToo m = do env <- getEnv
340 let dflags = extractDynFlags env
341 dflags' = dynamicTooMkDynamicDynFlags dflags
342 env' = replaceDynFlags env dflags'
343 setEnv env' m
344
345 getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
346 getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
347
348 getEps :: TcRnIf gbl lcl ExternalPackageState
349 getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
350
351 -- | Update the external package state. Returns the second result of the
352 -- modifier function.
353 --
354 -- This is an atomic operation and forces evaluation of the modified EPS in
355 -- order to avoid space leaks.
356 updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
357 -> TcRnIf gbl lcl a
358 updateEps upd_fn = do
359 traceIf (text "updating EPS")
360 eps_var <- getEpsVar
361 atomicUpdMutVar' eps_var upd_fn
362
363 -- | Update the external package state.
364 --
365 -- This is an atomic operation and forces evaluation of the modified EPS in
366 -- order to avoid space leaks.
367 updateEps_ :: (ExternalPackageState -> ExternalPackageState)
368 -> TcRnIf gbl lcl ()
369 updateEps_ upd_fn = do
370 traceIf (text "updating EPS_")
371 eps_var <- getEpsVar
372 atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
373
374 getHpt :: TcRnIf gbl lcl HomePackageTable
375 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
376
377 getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
378 getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
379 ; return (eps, hsc_HPT env) }
380
381 {-
382 ************************************************************************
383 * *
384 Arrow scopes
385 * *
386 ************************************************************************
387 -}
388
389 newArrowScope :: TcM a -> TcM a
390 newArrowScope
391 = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }
392
393 -- Return to the stored environment (from the enclosing proc)
394 escapeArrowScope :: TcM a -> TcM a
395 escapeArrowScope
396 = updLclEnv $ \ env ->
397 case tcl_arrow_ctxt env of
398 NoArrowCtxt -> env
399 ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
400 , tcl_lie = lie
401 , tcl_rdr = rdr_env }
402
403 {-
404 ************************************************************************
405 * *
406 Unique supply
407 * *
408 ************************************************************************
409 -}
410
411 newUnique :: TcRnIf gbl lcl Unique
412 newUnique
413 = do { env <- getEnv ;
414 let { u_var = env_us env } ;
415 us <- readMutVar u_var ;
416 case takeUniqFromSupply us of { (uniq, us') -> do {
417 writeMutVar u_var us' ;
418 return $! uniq }}}
419 -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
420 -- a chain of unevaluated supplies behind.
421 -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
422 -- throw away one half of the new split supply. This is safe because this
423 -- is the only place we use that unique. Using the other half of the split
424 -- supply is safer, but slower.
425
426 newUniqueSupply :: TcRnIf gbl lcl UniqSupply
427 newUniqueSupply
428 = do { env <- getEnv ;
429 let { u_var = env_us env } ;
430 us <- readMutVar u_var ;
431 case splitUniqSupply us of { (us1,us2) -> do {
432 writeMutVar u_var us1 ;
433 return us2 }}}
434
435 newLocalName :: Name -> TcM Name
436 newLocalName name = newName (nameOccName name)
437
438 newName :: OccName -> TcM Name
439 newName occ
440 = do { uniq <- newUnique
441 ; loc <- getSrcSpanM
442 ; return (mkInternalName uniq occ loc) }
443
444 newSysName :: OccName -> TcM Name
445 newSysName occ
446 = do { uniq <- newUnique
447 ; return (mkSystemName uniq occ) }
448
449 newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
450 newSysLocalId fs ty
451 = do { u <- newUnique
452 ; return (mkSysLocal fs u ty) }
453
454 newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
455 newSysLocalIds fs tys
456 = do { us <- newUniqueSupply
457 ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
458
459 instance MonadUnique (IOEnv (Env gbl lcl)) where
460 getUniqueM = newUnique
461 getUniqueSupplyM = newUniqueSupply
462
463 {-
464 ************************************************************************
465 * *
466 Debugging
467 * *
468 ************************************************************************
469 -}
470
471 newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
472 newTcRef = newMutVar
473
474 readTcRef :: TcRef a -> TcRnIf gbl lcl a
475 readTcRef = readMutVar
476
477 writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
478 writeTcRef = writeMutVar
479
480 updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
481 -- Returns ()
482 updTcRef ref fn = liftIO $ do { old <- readIORef ref
483 ; writeIORef ref (fn old) }
484
485 updTcRefX :: TcRef a -> (a -> a) -> TcRnIf gbl lcl a
486 -- Returns previous value
487 updTcRefX ref fn = liftIO $ do { old <- readIORef ref
488 ; writeIORef ref (fn old)
489 ; return old }
490
491 {-
492 ************************************************************************
493 * *
494 Debugging
495 * *
496 ************************************************************************
497 -}
498
499 traceTc :: String -> SDoc -> TcRn ()
500 traceTc herald doc = traceTcN 1 (hang (text herald) 2 doc)
501
502 -- | Typechecker trace
503 traceTcN :: Int -> SDoc -> TcRn ()
504 traceTcN level doc
505 = do { dflags <- getDynFlags
506 ; when (level <= traceLevel dflags) $
507 traceOptTcRn Opt_D_dump_tc_trace doc }
508
509 traceRn :: SDoc -> TcRn ()
510 traceRn doc = traceOptTcRn Opt_D_dump_rn_trace doc
511
512 traceSplice :: SDoc -> TcRn ()
513 traceSplice doc = traceOptTcRn Opt_D_dump_splices doc
514
515 -- | Output a doc if the given 'DumpFlag' is set.
516 --
517 -- By default this logs to stdout
518 -- However, if the `-ddump-to-file` flag is set,
519 -- then this will dump output to a file
520 --
521 -- Just a wrapper for 'dumpSDoc'
522 traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
523 traceOptTcRn flag doc
524 = do { dflags <- getDynFlags
525 ; when (dopt flag dflags) (traceTcRn flag doc)
526 }
527
528 traceTcRn :: DumpFlag -> SDoc -> TcRn ()
529 -- ^ Unconditionally dump some trace output
530 --
531 -- The DumpFlag is used only to set the output filename
532 -- for --dump-to-file, not to decide whether or not to output
533 -- That part is done by the caller
534 traceTcRn flag doc
535 = do { real_doc <- prettyDoc doc
536 ; dflags <- getDynFlags
537 ; printer <- getPrintUnqualified dflags
538 ; liftIO $ dumpSDoc dflags printer flag "" real_doc }
539 where
540 -- Add current location if opt_PprStyle_Debug
541 prettyDoc :: SDoc -> TcRn SDoc
542 prettyDoc doc = if opt_PprStyle_Debug
543 then do { loc <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }
544 else return doc -- The full location is usually way too much
545
546
547 getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
548 getPrintUnqualified dflags
549 = do { rdr_env <- getGlobalRdrEnv
550 ; return $ mkPrintUnqualified dflags rdr_env }
551
552 -- | Like logInfoTcRn, but for user consumption
553 printForUserTcRn :: SDoc -> TcRn ()
554 printForUserTcRn doc
555 = do { dflags <- getDynFlags
556 ; printer <- getPrintUnqualified dflags
557 ; liftIO (printInfoForUser dflags printer doc) }
558
559 -- | Typechecker debug
560 debugDumpTcRn :: SDoc -> TcRn ()
561 debugDumpTcRn doc = unless opt_NoDebugOutput $
562 traceOptTcRn Opt_D_dump_tc doc
563
564 {-
565 traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
566 available. Alas, they behave inconsistently with the other stuff;
567 e.g. are unaffected by -dump-to-file.
568 -}
569
570 traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
571 traceIf = traceOptIf Opt_D_dump_if_trace
572 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
573
574
575 traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
576 traceOptIf flag doc
577 = whenDOptM flag $ -- No RdrEnv available, so qualify everything
578 do { dflags <- getDynFlags
579 ; liftIO (putMsg dflags doc) }
580
581 {-
582 ************************************************************************
583 * *
584 Typechecker global environment
585 * *
586 ************************************************************************
587 -}
588
589 setModule :: Module -> TcRn a -> TcRn a
590 setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
591
592 getIsGHCi :: TcRn Bool
593 getIsGHCi = do { mod <- getModule
594 ; return (isInteractiveModule mod) }
595
596 getGHCiMonad :: TcRn Name
597 getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
598
599 getInteractivePrintName :: TcRn Name
600 getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }
601
602 tcIsHsBootOrSig :: TcRn Bool
603 tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
604
605 getGlobalRdrEnv :: TcRn GlobalRdrEnv
606 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
607
608 getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
609 getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
610
611 getImports :: TcRn ImportAvails
612 getImports = do { env <- getGblEnv; return (tcg_imports env) }
613
614 getFixityEnv :: TcRn FixityEnv
615 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
616
617 extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
618 extendFixityEnv new_bit
619 = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
620 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
621
622 getRecFieldEnv :: TcRn RecFieldEnv
623 getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
624
625 getDeclaredDefaultTys :: TcRn (Maybe [Type])
626 getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
627
628 addDependentFiles :: [FilePath] -> TcRn ()
629 addDependentFiles fs = do
630 ref <- fmap tcg_dependent_files getGblEnv
631 dep_files <- readTcRef ref
632 writeTcRef ref (fs ++ dep_files)
633
634 {-
635 ************************************************************************
636 * *
637 Error management
638 * *
639 ************************************************************************
640 -}
641
642 getSrcSpanM :: TcRn SrcSpan
643 -- Avoid clash with Name.getSrcLoc
644 getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) }
645
646 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
647 setSrcSpan (RealSrcSpan real_loc) thing_inside
648 = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside
649 -- Don't overwrite useful info with useless:
650 setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
651
652 addLocM :: (a -> TcM b) -> Located a -> TcM b
653 addLocM fn (L loc a) = setSrcSpan loc $ fn a
654
655 wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
656 wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
657
658 wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
659 wrapLocFstM fn (L loc a) =
660 setSrcSpan loc $ do
661 (b,c) <- fn a
662 return (L loc b, c)
663
664 wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
665 wrapLocSndM fn (L loc a) =
666 setSrcSpan loc $ do
667 (b,c) <- fn a
668 return (b, L loc c)
669
670 -- Reporting errors
671
672 getErrsVar :: TcRn (TcRef Messages)
673 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
674
675 setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
676 setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v })
677
678 addErr :: MsgDoc -> TcRn () -- Ignores the context stack
679 addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
680
681 failWith :: MsgDoc -> TcRn a
682 failWith msg = addErr msg >> failM
683
684 addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
685 -- addErrAt is mainly (exclusively?) used by the renamer, where
686 -- tidying is not an issue, but it's all lazy so the extra
687 -- work doesn't matter
688 addErrAt loc msg = do { ctxt <- getErrCtxt
689 ; tidy_env <- tcInitTidyEnv
690 ; err_info <- mkErrInfo tidy_env ctxt
691 ; addLongErrAt loc msg err_info }
692
693 addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()
694 addErrs msgs = mapM_ add msgs
695 where
696 add (loc,msg) = addErrAt loc msg
697
698 checkErr :: Bool -> MsgDoc -> TcRn ()
699 -- Add the error if the bool is False
700 checkErr ok msg = unless ok (addErr msg)
701
702 warnIf :: Bool -> MsgDoc -> TcRn ()
703 warnIf True msg = addWarn msg
704 warnIf False _ = return ()
705
706 addMessages :: Messages -> TcRn ()
707 addMessages (m_warns, m_errs)
708 = do { errs_var <- getErrsVar ;
709 (warns, errs) <- readTcRef errs_var ;
710 writeTcRef errs_var (warns `unionBags` m_warns,
711 errs `unionBags` m_errs) }
712
713 discardWarnings :: TcRn a -> TcRn a
714 -- Ignore warnings inside the thing inside;
715 -- used to ignore-unused-variable warnings inside derived code
716 discardWarnings thing_inside
717 = do { errs_var <- getErrsVar
718 ; (old_warns, _) <- readTcRef errs_var ;
719
720 ; result <- thing_inside
721
722 -- Revert warnings to old_warns
723 ; (_new_warns, new_errs) <- readTcRef errs_var
724 ; writeTcRef errs_var (old_warns, new_errs)
725
726 ; return result }
727
728 {-
729 ************************************************************************
730 * *
731 Shared error message stuff: renamer and typechecker
732 * *
733 ************************************************************************
734 -}
735
736 mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
737 mkLongErrAt loc msg extra
738 = do { dflags <- getDynFlags ;
739 printer <- getPrintUnqualified dflags ;
740 return $ mkLongErrMsg dflags loc printer msg extra }
741
742 addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
743 addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
744
745 reportErrors :: [ErrMsg] -> TcM ()
746 reportErrors = mapM_ reportError
747
748 reportError :: ErrMsg -> TcRn ()
749 reportError err
750 = do { traceTc "Adding error:" (pprLocErrMsg err) ;
751 errs_var <- getErrsVar ;
752 (warns, errs) <- readTcRef errs_var ;
753 writeTcRef errs_var (warns, errs `snocBag` err) }
754
755 reportWarning :: ErrMsg -> TcRn ()
756 reportWarning err
757 = do { let warn = makeIntoWarning err
758 -- 'err' was build by mkLongErrMsg or something like that,
759 -- so it's of error severity. For a warning we downgrade
760 -- its severity to SevWarning
761
762 ; traceTc "Adding warning:" (pprLocErrMsg warn)
763 ; errs_var <- getErrsVar
764 ; (warns, errs) <- readTcRef errs_var
765 ; writeTcRef errs_var (warns `snocBag` warn, errs) }
766
767 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
768 -- Does try_m, with a debug-trace on failure
769 try_m thing
770 = do { mb_r <- tryM thing ;
771 case mb_r of
772 Left exn -> do { traceTc "tryTc/recoverM recovering from" $
773 text (showException exn)
774 ; return mb_r }
775 Right _ -> return mb_r }
776
777 -----------------------
778 recoverM :: TcRn r -- Recovery action; do this if the main one fails
779 -> TcRn r -- Main action: do this first
780 -> TcRn r
781 -- Errors in 'thing' are retained
782 recoverM recover thing
783 = do { mb_res <- try_m thing ;
784 case mb_res of
785 Left _ -> recover
786 Right res -> return res }
787
788
789 -----------------------
790 mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
791 -- Drop elements of the input that fail, so the result
792 -- list can be shorter than the argument list
793 mapAndRecoverM _ [] = return []
794 mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
795 ; rs <- mapAndRecoverM f xs
796 ; return (case mb_r of
797 Left _ -> rs
798 Right r -> r:rs) }
799
800 -- | Succeeds if applying the argument to all members of the lists succeeds,
801 -- but nevertheless runs it on all arguments, to collect all errors.
802 mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
803 mapAndReportM f xs = checkNoErrs (mapAndRecoverM f xs)
804
805 -----------------------
806 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
807 -- (tryTc m) executes m, and returns
808 -- Just r, if m succeeds (returning r)
809 -- Nothing, if m fails
810 -- It also returns all the errors and warnings accumulated by m
811 -- It always succeeds (never raises an exception)
812 tryTc m
813 = do { errs_var <- newTcRef emptyMessages ;
814 res <- try_m (setErrsVar errs_var m) ;
815 msgs <- readTcRef errs_var ;
816 return (msgs, case res of
817 Left _ -> Nothing
818 Right val -> Just val)
819 -- The exception is always the IOEnv built-in
820 -- in exception; see IOEnv.failM
821 }
822
823 -----------------------
824 tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
825 -- Run the thing, returning
826 -- Just r, if m succceeds with no error messages
827 -- Nothing, if m fails, or if it succeeds but has error messages
828 -- Either way, the messages are returned; even in the Just case
829 -- there might be warnings
830 tryTcErrs thing
831 = do { (msgs, res) <- tryTc thing
832 ; dflags <- getDynFlags
833 ; let errs_found = errorsFound dflags msgs
834 ; return (msgs, case res of
835 Nothing -> Nothing
836 Just val | errs_found -> Nothing
837 | otherwise -> Just val)
838 }
839
840 -----------------------
841 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
842 -- Just like tryTcErrs, except that it ensures that the LIE
843 -- for the thing is propagated only if there are no errors
844 -- Hence it's restricted to the type-check monad
845 tryTcLIE thing_inside
846 = do { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
847 ; case mb_res of
848 Nothing -> return (msgs, Nothing)
849 Just val -> do { emitConstraints lie; return (msgs, Just val) }
850 }
851
852 -----------------------
853 tryTcLIE_ :: TcM r -> TcM r -> TcM r
854 -- (tryTcLIE_ r m) tries m;
855 -- if m succeeds with no error messages, it's the answer
856 -- otherwise tryTcLIE_ drops everything from m and tries r instead.
857 tryTcLIE_ recover main
858 = do { (msgs, mb_res) <- tryTcLIE main
859 ; case mb_res of
860 Just val -> do { addMessages msgs -- There might be warnings
861 ; return val }
862 Nothing -> recover -- Discard all msgs
863 }
864
865 -----------------------
866 checkNoErrs :: TcM r -> TcM r
867 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
868 -- If m fails then (checkNoErrsTc m) fails.
869 -- If m succeeds, it checks whether m generated any errors messages
870 -- (it might have recovered internally)
871 -- If so, it fails too.
872 -- Regardless, any errors generated by m are propagated to the enclosing context.
873 checkNoErrs main
874 = do { (msgs, mb_res) <- tryTcLIE main
875 ; addMessages msgs
876 ; case mb_res of
877 Nothing -> failM
878 Just val -> return val
879 }
880
881 whenNoErrs :: TcM () -> TcM ()
882 whenNoErrs thing = ifErrsM (return ()) thing
883
884 ifErrsM :: TcRn r -> TcRn r -> TcRn r
885 -- ifErrsM bale_out normal
886 -- does 'bale_out' if there are errors in errors collection
887 -- otherwise does 'normal'
888 ifErrsM bale_out normal
889 = do { errs_var <- getErrsVar ;
890 msgs <- readTcRef errs_var ;
891 dflags <- getDynFlags ;
892 if errorsFound dflags msgs then
893 bale_out
894 else
895 normal }
896
897 failIfErrsM :: TcRn ()
898 -- Useful to avoid error cascades
899 failIfErrsM = ifErrsM failM (return ())
900
901 #ifdef GHCI
902 checkTH :: a -> String -> TcRn ()
903 checkTH _ _ = return () -- OK
904 #else
905 checkTH :: Outputable a => a -> String -> TcRn ()
906 checkTH e what = failTH e what -- Raise an error in a stage-1 compiler
907 #endif
908
909 failTH :: Outputable a => a -> String -> TcRn x
910 failTH e what -- Raise an error in a stage-1 compiler
911 = failWithTc (vcat [ hang (char 'A' <+> text what
912 <+> ptext (sLit "requires GHC with interpreter support:"))
913 2 (ppr e)
914 , ptext (sLit "Perhaps you are using a stage-1 compiler?") ])
915
916 {-
917 ************************************************************************
918 * *
919 Context management for the type checker
920 * *
921 ************************************************************************
922 -}
923
924 getErrCtxt :: TcM [ErrCtxt]
925 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
926
927 setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
928 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
929
930 addErrCtxt :: MsgDoc -> TcM a -> TcM a
931 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
932
933 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
934 addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
935
936 addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
937 addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
938
939 -- Helper function for the above
940 updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
941 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
942 env { tcl_ctxt = upd ctxt })
943
944 popErrCtxt :: TcM a -> TcM a
945 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
946
947 getCtLoc :: CtOrigin -> TcM CtLoc
948 getCtLoc origin
949 = do { env <- getLclEnv
950 ; return (CtLoc { ctl_origin = origin
951 , ctl_env = env
952 , ctl_depth = initialSubGoalDepth }) }
953
954 setCtLoc :: CtLoc -> TcM a -> TcM a
955 -- Set the SrcSpan and error context from the CtLoc
956 setCtLoc (CtLoc { ctl_env = lcl }) thing_inside
957 = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
958 , tcl_bndrs = tcl_bndrs lcl
959 , tcl_ctxt = tcl_ctxt lcl })
960 thing_inside
961
962 {-
963 ************************************************************************
964 * *
965 Error message generation (type checker)
966 * *
967 ************************************************************************
968
969 The addErrTc functions add an error message, but do not cause failure.
970 The 'M' variants pass a TidyEnv that has already been used to
971 tidy up the message; we then use it to tidy the context messages
972 -}
973
974 addErrTc :: MsgDoc -> TcM ()
975 addErrTc err_msg = do { env0 <- tcInitTidyEnv
976 ; addErrTcM (env0, err_msg) }
977
978 addErrsTc :: [MsgDoc] -> TcM ()
979 addErrsTc err_msgs = mapM_ addErrTc err_msgs
980
981 addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()
982 addErrTcM (tidy_env, err_msg)
983 = do { ctxt <- getErrCtxt ;
984 loc <- getSrcSpanM ;
985 add_err_tcm tidy_env err_msg loc ctxt }
986
987 -- Return the error message, instead of reporting it straight away
988 mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg
989 mkErrTcM (tidy_env, err_msg)
990 = do { ctxt <- getErrCtxt ;
991 loc <- getSrcSpanM ;
992 err_info <- mkErrInfo tidy_env ctxt ;
993 mkLongErrAt loc err_msg err_info }
994
995 -- The failWith functions add an error message and cause failure
996
997 failWithTc :: MsgDoc -> TcM a -- Add an error message and fail
998 failWithTc err_msg
999 = addErrTc err_msg >> failM
1000
1001 failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail
1002 failWithTcM local_and_msg
1003 = addErrTcM local_and_msg >> failM
1004
1005 checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true
1006 checkTc True _ = return ()
1007 checkTc False err = failWithTc err
1008
1009 -- Warnings have no 'M' variant, nor failure
1010
1011 warnTc :: Bool -> MsgDoc -> TcM ()
1012 warnTc warn_if_true warn_msg
1013 | warn_if_true = addWarnTc warn_msg
1014 | otherwise = return ()
1015
1016 addWarnTc :: MsgDoc -> TcM ()
1017 addWarnTc msg = do { env0 <- tcInitTidyEnv
1018 ; addWarnTcM (env0, msg) }
1019
1020 addWarnTcM :: (TidyEnv, MsgDoc) -> TcM ()
1021 addWarnTcM (env0, msg)
1022 = do { ctxt <- getErrCtxt ;
1023 err_info <- mkErrInfo env0 ctxt ;
1024 add_warn msg err_info }
1025
1026 addWarn :: MsgDoc -> TcRn ()
1027 addWarn msg = add_warn msg Outputable.empty
1028
1029 addWarnAt :: SrcSpan -> MsgDoc -> TcRn ()
1030 addWarnAt loc msg = add_warn_at loc msg Outputable.empty
1031
1032 add_warn :: MsgDoc -> MsgDoc -> TcRn ()
1033 add_warn msg extra_info
1034 = do { loc <- getSrcSpanM
1035 ; add_warn_at loc msg extra_info }
1036
1037 add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
1038 add_warn_at loc msg extra_info
1039 = do { dflags <- getDynFlags ;
1040 printer <- getPrintUnqualified dflags ;
1041 let { warn = mkLongWarnMsg dflags loc printer
1042 msg extra_info } ;
1043 reportWarning warn }
1044
1045 tcInitTidyEnv :: TcM TidyEnv
1046 tcInitTidyEnv
1047 = do { lcl_env <- getLclEnv
1048 ; return (tcl_tidy lcl_env) }
1049
1050 {-
1051 -----------------------------------
1052 Other helper functions
1053 -}
1054
1055 add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan
1056 -> [ErrCtxt]
1057 -> TcM ()
1058 add_err_tcm tidy_env err_msg loc ctxt
1059 = do { err_info <- mkErrInfo tidy_env ctxt ;
1060 addLongErrAt loc err_msg err_info }
1061
1062 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
1063 -- Tidy the error info, trimming excessive contexts
1064 mkErrInfo env ctxts
1065 -- | opt_PprStyle_Debug -- In -dppr-debug style the output
1066 -- = return empty -- just becomes too voluminous
1067 | otherwise
1068 = go 0 env ctxts
1069 where
1070 go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
1071 go _ _ [] = return Outputable.empty
1072 go n env ((is_landmark, ctxt) : ctxts)
1073 | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug
1074 = do { (env', msg) <- ctxt env
1075 ; let n' = if is_landmark then n else n+1
1076 ; rest <- go n' env' ctxts
1077 ; return (msg $$ rest) }
1078 | otherwise
1079 = go n env ctxts
1080
1081 mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts
1082 mAX_CONTEXTS = 3
1083
1084 -- debugTc is useful for monadic debugging code
1085
1086 debugTc :: TcM () -> TcM ()
1087 debugTc thing
1088 | debugIsOn = thing
1089 | otherwise = return ()
1090
1091 {-
1092 ************************************************************************
1093 * *
1094 Type constraints
1095 * *
1096 ************************************************************************
1097 -}
1098
1099 newTcEvBinds :: TcM EvBindsVar
1100 newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
1101 ; uniq <- newUnique
1102 ; return (EvBindsVar ref uniq) }
1103
1104 addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
1105 -- Add a binding to the TcEvBinds by side effect
1106 addTcEvBind (EvBindsVar ev_ref _) ev_bind
1107 = do { traceTc "addTcEvBind" $ ppr ev_bind
1108 ; bnds <- readTcRef ev_ref
1109 ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
1110
1111 getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind)
1112 getTcEvBinds (EvBindsVar ev_ref _)
1113 = do { bnds <- readTcRef ev_ref
1114 ; return (evBindMapBinds bnds) }
1115
1116 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
1117 chooseUniqueOccTc fn =
1118 do { env <- getGblEnv
1119 ; let dfun_n_var = tcg_dfun_n env
1120 ; set <- readTcRef dfun_n_var
1121 ; let occ = fn set
1122 ; writeTcRef dfun_n_var (extendOccSet set occ)
1123 ; return occ }
1124
1125 getConstraintVar :: TcM (TcRef WantedConstraints)
1126 getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
1127
1128 setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
1129 setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
1130
1131 emitConstraints :: WantedConstraints -> TcM ()
1132 emitConstraints ct
1133 = do { lie_var <- getConstraintVar ;
1134 updTcRef lie_var (`andWC` ct) }
1135
1136 emitSimple :: Ct -> TcM ()
1137 emitSimple ct
1138 = do { lie_var <- getConstraintVar ;
1139 updTcRef lie_var (`addSimples` unitBag ct) }
1140
1141 emitSimples :: Cts -> TcM ()
1142 emitSimples cts
1143 = do { lie_var <- getConstraintVar ;
1144 updTcRef lie_var (`addSimples` cts) }
1145
1146 emitImplication :: Implication -> TcM ()
1147 emitImplication ct
1148 = do { lie_var <- getConstraintVar ;
1149 updTcRef lie_var (`addImplics` unitBag ct) }
1150
1151 emitImplications :: Bag Implication -> TcM ()
1152 emitImplications ct
1153 = do { lie_var <- getConstraintVar ;
1154 updTcRef lie_var (`addImplics` ct) }
1155
1156 emitInsoluble :: Ct -> TcM ()
1157 emitInsoluble ct
1158 = do { lie_var <- getConstraintVar ;
1159 updTcRef lie_var (`addInsols` unitBag ct) ;
1160 v <- readTcRef lie_var ;
1161 traceTc "emitInsoluble" (ppr v) }
1162
1163 captureConstraints :: TcM a -> TcM (a, WantedConstraints)
1164 -- (captureConstraints m) runs m, and returns the type constraints it generates
1165 captureConstraints thing_inside
1166 = do { lie_var <- newTcRef emptyWC ;
1167 res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
1168 thing_inside ;
1169 lie <- readTcRef lie_var ;
1170 return (res, lie) }
1171
1172 pushLevelAndCaptureConstraints :: TcM a -> TcM (a, TcLevel, WantedConstraints)
1173 pushLevelAndCaptureConstraints thing_inside
1174 = do { env <- getLclEnv
1175 ; lie_var <- newTcRef emptyWC ;
1176 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1177 ; res <- setLclEnv (env { tcl_tclvl = tclvl'
1178 , tcl_lie = lie_var })
1179 thing_inside
1180 ; lie <- readTcRef lie_var
1181 ; return (res, tclvl', lie) }
1182
1183 pushTcLevelM_ :: TcM a -> TcM a
1184 pushTcLevelM_ = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) })
1185
1186 pushTcLevelM :: TcM a -> TcM (a, TcLevel)
1187 pushTcLevelM thing_inside
1188 = do { env <- getLclEnv
1189 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1190 ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
1191 thing_inside
1192 ; return (res, tclvl') }
1193
1194 getTcLevel :: TcM TcLevel
1195 getTcLevel = do { env <- getLclEnv
1196 ; return (tcl_tclvl env) }
1197
1198 setTcLevel :: TcLevel -> TcM a -> TcM a
1199 setTcLevel tclvl thing_inside
1200 = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
1201
1202 isTouchableTcM :: TcTyVar -> TcM Bool
1203 isTouchableTcM tv
1204 = do { env <- getLclEnv
1205 ; return (isTouchableMetaTyVar (tcl_tclvl env) tv) }
1206
1207 getLclTypeEnv :: TcM TcTypeEnv
1208 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
1209
1210 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
1211 -- Set the local type envt, but do *not* disturb other fields,
1212 -- notably the lie_var
1213 setLclTypeEnv lcl_env thing_inside
1214 = updLclEnv upd thing_inside
1215 where
1216 upd env = env { tcl_env = tcl_env lcl_env,
1217 tcl_tyvars = tcl_tyvars lcl_env }
1218
1219 traceTcConstraints :: String -> TcM ()
1220 traceTcConstraints msg
1221 = do { lie_var <- getConstraintVar
1222 ; lie <- readTcRef lie_var
1223 ; traceTc (msg ++ ": LIE:") (ppr lie)
1224 }
1225
1226 emitWildcardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
1227 emitWildcardHoleConstraints wcs
1228 = do { ctLoc <- getCtLoc HoleOrigin
1229 ; forM_ wcs $ \(name, tv) -> do {
1230 ; let real_span = case nameSrcSpan name of
1231 RealSrcSpan span -> span
1232 UnhelpfulSpan str -> pprPanic "emitWildcardHoleConstraints"
1233 (ppr name <+> quotes (ftext str))
1234 -- Wildcards are defined locally, and so have RealSrcSpans
1235 ctLoc' = setCtLocSpan ctLoc real_span
1236 ty = mkTyVarTy tv
1237 ev = mkLocalId name ty
1238 can = CHoleCan { cc_ev = CtWanted ty ev ctLoc'
1239 , cc_occ = occName name
1240 , cc_hole = TypeHole }
1241 ; emitInsoluble can } }
1242
1243 {-
1244 ************************************************************************
1245 * *
1246 Template Haskell context
1247 * *
1248 ************************************************************************
1249 -}
1250
1251 recordThUse :: TcM ()
1252 recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
1253
1254 recordThSpliceUse :: TcM ()
1255 recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
1256
1257 keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set
1258 keepAlive name
1259 = do { env <- getGblEnv
1260 ; traceRn (ptext (sLit "keep alive") <+> ppr name)
1261 ; updTcRef (tcg_keep env) (`extendNameSet` name) }
1262
1263 getStage :: TcM ThStage
1264 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
1265
1266 getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
1267 getStageAndBindLevel name
1268 = do { env <- getLclEnv;
1269 ; case lookupNameEnv (tcl_th_bndrs env) name of
1270 Nothing -> return Nothing
1271 Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
1272
1273 setStage :: ThStage -> TcM a -> TcRn a
1274 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
1275
1276 {-
1277 ************************************************************************
1278 * *
1279 Safe Haskell context
1280 * *
1281 ************************************************************************
1282 -}
1283
1284 -- | Mark that safe inference has failed
1285 recordUnsafeInfer :: TcM ()
1286 recordUnsafeInfer = getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) False
1287
1288 -- | Figure out the final correct safe haskell mode
1289 finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
1290 finalSafeMode dflags tcg_env = do
1291 safeInf <- readIORef (tcg_safeInfer tcg_env)
1292 return $ case safeHaskell dflags of
1293 Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
1294 | otherwise -> Sf_None
1295 s -> s
1296
1297 {-
1298 ************************************************************************
1299 * *
1300 Stuff for the renamer's local env
1301 * *
1302 ************************************************************************
1303 -}
1304
1305 getLocalRdrEnv :: RnM LocalRdrEnv
1306 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
1307
1308 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
1309 setLocalRdrEnv rdr_env thing_inside
1310 = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
1311
1312 {-
1313 ************************************************************************
1314 * *
1315 Stuff for interface decls
1316 * *
1317 ************************************************************************
1318 -}
1319
1320 mkIfLclEnv :: Module -> SDoc -> IfLclEnv
1321 mkIfLclEnv mod loc = IfLclEnv { if_mod = mod,
1322 if_loc = loc,
1323 if_tv_env = emptyUFM,
1324 if_id_env = emptyUFM }
1325
1326 -- | Run an 'IfG' (top-level interface monad) computation inside an existing
1327 -- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
1328 -- based on 'TcGblEnv'.
1329 initIfaceTcRn :: IfG a -> TcRn a
1330 initIfaceTcRn thing_inside
1331 = do { tcg_env <- getGblEnv
1332 ; let { if_env = IfGblEnv {
1333 if_rec_types = Just (tcg_mod tcg_env, get_type_env)
1334 }
1335 ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
1336 ; setEnvs (if_env, ()) thing_inside }
1337
1338 initIfaceCheck :: HscEnv -> IfG a -> IO a
1339 -- Used when checking the up-to-date-ness of the old Iface
1340 -- Initialise the environment with no useful info at all
1341 initIfaceCheck hsc_env do_this
1342 = do let rec_types = case hsc_type_env_var hsc_env of
1343 Just (mod,var) -> Just (mod, readTcRef var)
1344 Nothing -> Nothing
1345 gbl_env = IfGblEnv { if_rec_types = rec_types }
1346 initTcRnIf 'i' hsc_env gbl_env () do_this
1347
1348 initIfaceTc :: ModIface
1349 -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
1350 -- Used when type-checking checking an up-to-date interface file
1351 -- No type envt from the current module, but we do know the module dependencies
1352 initIfaceTc iface do_this
1353 = do { tc_env_var <- newTcRef emptyTypeEnv
1354 ; let { gbl_env = IfGblEnv {
1355 if_rec_types = Just (mod, readTcRef tc_env_var)
1356 } ;
1357 ; if_lenv = mkIfLclEnv mod doc
1358 }
1359 ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
1360 }
1361 where
1362 mod = mi_module iface
1363 doc = ptext (sLit "The interface for") <+> quotes (ppr mod)
1364
1365 initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
1366 initIfaceLcl mod loc_doc thing_inside
1367 = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
1368
1369 getIfModule :: IfL Module
1370 getIfModule = do { env <- getLclEnv; return (if_mod env) }
1371
1372 --------------------
1373 failIfM :: MsgDoc -> IfL a
1374 -- The Iface monad doesn't have a place to accumulate errors, so we
1375 -- just fall over fast if one happens; it "shouldnt happen".
1376 -- We use IfL here so that we can get context info out of the local env
1377 failIfM msg
1378 = do { env <- getLclEnv
1379 ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1380 ; dflags <- getDynFlags
1381 ; liftIO (log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) full_msg)
1382 ; failM }
1383
1384 --------------------
1385 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1386 -- Run thing_inside in an interleaved thread.
1387 -- It shares everything with the parent thread, so this is DANGEROUS.
1388 --
1389 -- It returns Nothing if the computation fails
1390 --
1391 -- It's used for lazily type-checking interface
1392 -- signatures, which is pretty benign
1393
1394 forkM_maybe doc thing_inside
1395 -- NB: Don't share the mutable env_us with the interleaved thread since env_us
1396 -- does not get updated atomically (e.g. in newUnique and newUniqueSupply).
1397 = do { child_us <- newUniqueSupply
1398 ; child_env_us <- newMutVar child_us
1399 -- see Note [Masking exceptions in forkM_maybe]
1400 ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $
1401 do { traceIf (text "Starting fork {" <+> doc)
1402 ; mb_res <- tryM $
1403 updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1404 thing_inside
1405 ; case mb_res of
1406 Right r -> do { traceIf (text "} ending fork" <+> doc)
1407 ; return (Just r) }
1408 Left exn -> do {
1409
1410 -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1411 -- Otherwise we silently discard errors. Errors can legitimately
1412 -- happen when compiling interface signatures (see tcInterfaceSigs)
1413 whenDOptM Opt_D_dump_if_trace $ do
1414 dflags <- getDynFlags
1415 let msg = hang (text "forkM failed:" <+> doc)
1416 2 (text (show exn))
1417 liftIO $ log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg
1418
1419 ; traceIf (text "} ending fork (badly)" <+> doc)
1420 ; return Nothing }
1421 }}
1422
1423 forkM :: SDoc -> IfL a -> IfL a
1424 forkM doc thing_inside
1425 = do { mb_res <- forkM_maybe doc thing_inside
1426 ; return (case mb_res of
1427 Nothing -> pgmError "Cannot continue after interface file error"
1428 -- pprPanic "forkM" doc
1429 Just r -> r) }
1430
1431 {-
1432 Note [Masking exceptions in forkM_maybe]
1433 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1434
1435 When using GHC-as-API it must be possible to interrupt snippets of code
1436 executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
1437 by throwing an asynchronous interrupt to the GHC thread. However, there is a
1438 subtle problem: runStmt first typechecks the code before running it, and the
1439 exception might interrupt the type checker rather than the code. Moreover, the
1440 typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
1441 more importantly might be inside an exception handler inside that
1442 unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
1443 asynchronous exception as a synchronous exception, and the exception will end
1444 up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
1445 discussion). We don't currently know a general solution to this problem, but
1446 we can use uninterruptibleMask_ to avoid the situation.
1447 -}