Major patch to add -fwarn-redundant-constraints
[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 warn
757 = do { traceTc "Adding warning:" (pprLocErrMsg warn) ;
758 errs_var <- getErrsVar ;
759 (warns, errs) <- readTcRef errs_var ;
760 writeTcRef errs_var (warns `snocBag` warn, errs) }
761
762 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
763 -- Does try_m, with a debug-trace on failure
764 try_m thing
765 = do { mb_r <- tryM thing ;
766 case mb_r of
767 Left exn -> do { traceTc "tryTc/recoverM recovering from" $
768 text (showException exn)
769 ; return mb_r }
770 Right _ -> return mb_r }
771
772 -----------------------
773 recoverM :: TcRn r -- Recovery action; do this if the main one fails
774 -> TcRn r -- Main action: do this first
775 -> TcRn r
776 -- Errors in 'thing' are retained
777 recoverM recover thing
778 = do { mb_res <- try_m thing ;
779 case mb_res of
780 Left _ -> recover
781 Right res -> return res }
782
783
784 -----------------------
785 mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
786 -- Drop elements of the input that fail, so the result
787 -- list can be shorter than the argument list
788 mapAndRecoverM _ [] = return []
789 mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
790 ; rs <- mapAndRecoverM f xs
791 ; return (case mb_r of
792 Left _ -> rs
793 Right r -> r:rs) }
794
795 -- | Succeeds if applying the argument to all members of the lists succeeds,
796 -- but nevertheless runs it on all arguments, to collect all errors.
797 mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
798 mapAndReportM f xs = checkNoErrs (mapAndRecoverM f xs)
799
800 -----------------------
801 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
802 -- (tryTc m) executes m, and returns
803 -- Just r, if m succeeds (returning r)
804 -- Nothing, if m fails
805 -- It also returns all the errors and warnings accumulated by m
806 -- It always succeeds (never raises an exception)
807 tryTc m
808 = do { errs_var <- newTcRef emptyMessages ;
809 res <- try_m (setErrsVar errs_var m) ;
810 msgs <- readTcRef errs_var ;
811 return (msgs, case res of
812 Left _ -> Nothing
813 Right val -> Just val)
814 -- The exception is always the IOEnv built-in
815 -- in exception; see IOEnv.failM
816 }
817
818 -----------------------
819 tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
820 -- Run the thing, returning
821 -- Just r, if m succceeds with no error messages
822 -- Nothing, if m fails, or if it succeeds but has error messages
823 -- Either way, the messages are returned; even in the Just case
824 -- there might be warnings
825 tryTcErrs thing
826 = do { (msgs, res) <- tryTc thing
827 ; dflags <- getDynFlags
828 ; let errs_found = errorsFound dflags msgs
829 ; return (msgs, case res of
830 Nothing -> Nothing
831 Just val | errs_found -> Nothing
832 | otherwise -> Just val)
833 }
834
835 -----------------------
836 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
837 -- Just like tryTcErrs, except that it ensures that the LIE
838 -- for the thing is propagated only if there are no errors
839 -- Hence it's restricted to the type-check monad
840 tryTcLIE thing_inside
841 = do { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
842 ; case mb_res of
843 Nothing -> return (msgs, Nothing)
844 Just val -> do { emitConstraints lie; return (msgs, Just val) }
845 }
846
847 -----------------------
848 tryTcLIE_ :: TcM r -> TcM r -> TcM r
849 -- (tryTcLIE_ r m) tries m;
850 -- if m succeeds with no error messages, it's the answer
851 -- otherwise tryTcLIE_ drops everything from m and tries r instead.
852 tryTcLIE_ recover main
853 = do { (msgs, mb_res) <- tryTcLIE main
854 ; case mb_res of
855 Just val -> do { addMessages msgs -- There might be warnings
856 ; return val }
857 Nothing -> recover -- Discard all msgs
858 }
859
860 -----------------------
861 checkNoErrs :: TcM r -> TcM r
862 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
863 -- If m fails then (checkNoErrsTc m) fails.
864 -- If m succeeds, it checks whether m generated any errors messages
865 -- (it might have recovered internally)
866 -- If so, it fails too.
867 -- Regardless, any errors generated by m are propagated to the enclosing context.
868 checkNoErrs main
869 = do { (msgs, mb_res) <- tryTcLIE main
870 ; addMessages msgs
871 ; case mb_res of
872 Nothing -> failM
873 Just val -> return val
874 }
875
876 whenNoErrs :: TcM () -> TcM ()
877 whenNoErrs thing = ifErrsM (return ()) thing
878
879 ifErrsM :: TcRn r -> TcRn r -> TcRn r
880 -- ifErrsM bale_out normal
881 -- does 'bale_out' if there are errors in errors collection
882 -- otherwise does 'normal'
883 ifErrsM bale_out normal
884 = do { errs_var <- getErrsVar ;
885 msgs <- readTcRef errs_var ;
886 dflags <- getDynFlags ;
887 if errorsFound dflags msgs then
888 bale_out
889 else
890 normal }
891
892 failIfErrsM :: TcRn ()
893 -- Useful to avoid error cascades
894 failIfErrsM = ifErrsM failM (return ())
895
896 checkTH :: Outputable a => a -> String -> TcRn ()
897 #ifdef GHCI
898 checkTH _ _ = return () -- OK
899 #else
900 checkTH e what = failTH e what -- Raise an error in a stage-1 compiler
901 #endif
902
903 failTH :: Outputable a => a -> String -> TcRn x
904 failTH e what -- Raise an error in a stage-1 compiler
905 = failWithTc (vcat [ hang (char 'A' <+> text what
906 <+> ptext (sLit "requires GHC with interpreter support:"))
907 2 (ppr e)
908 , ptext (sLit "Perhaps you are using a stage-1 compiler?") ])
909
910 {-
911 ************************************************************************
912 * *
913 Context management for the type checker
914 * *
915 ************************************************************************
916 -}
917
918 getErrCtxt :: TcM [ErrCtxt]
919 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
920
921 setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
922 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
923
924 addErrCtxt :: MsgDoc -> TcM a -> TcM a
925 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
926
927 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
928 addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
929
930 addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
931 addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
932
933 -- Helper function for the above
934 updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
935 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
936 env { tcl_ctxt = upd ctxt })
937
938 popErrCtxt :: TcM a -> TcM a
939 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
940
941 getCtLoc :: CtOrigin -> TcM CtLoc
942 getCtLoc origin
943 = do { env <- getLclEnv
944 ; return (CtLoc { ctl_origin = origin
945 , ctl_env = env
946 , ctl_depth = initialSubGoalDepth }) }
947
948 setCtLoc :: CtLoc -> TcM a -> TcM a
949 -- Set the SrcSpan and error context from the CtLoc
950 setCtLoc (CtLoc { ctl_env = lcl }) thing_inside
951 = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
952 , tcl_bndrs = tcl_bndrs lcl
953 , tcl_ctxt = tcl_ctxt lcl })
954 thing_inside
955
956 {-
957 ************************************************************************
958 * *
959 Error message generation (type checker)
960 * *
961 ************************************************************************
962
963 The addErrTc functions add an error message, but do not cause failure.
964 The 'M' variants pass a TidyEnv that has already been used to
965 tidy up the message; we then use it to tidy the context messages
966 -}
967
968 addErrTc :: MsgDoc -> TcM ()
969 addErrTc err_msg = do { env0 <- tcInitTidyEnv
970 ; addErrTcM (env0, err_msg) }
971
972 addErrsTc :: [MsgDoc] -> TcM ()
973 addErrsTc err_msgs = mapM_ addErrTc err_msgs
974
975 addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()
976 addErrTcM (tidy_env, err_msg)
977 = do { ctxt <- getErrCtxt ;
978 loc <- getSrcSpanM ;
979 add_err_tcm tidy_env err_msg loc ctxt }
980
981 -- Return the error message, instead of reporting it straight away
982 mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg
983 mkErrTcM (tidy_env, err_msg)
984 = do { ctxt <- getErrCtxt ;
985 loc <- getSrcSpanM ;
986 err_info <- mkErrInfo tidy_env ctxt ;
987 mkLongErrAt loc err_msg err_info }
988
989 -- The failWith functions add an error message and cause failure
990
991 failWithTc :: MsgDoc -> TcM a -- Add an error message and fail
992 failWithTc err_msg
993 = addErrTc err_msg >> failM
994
995 failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail
996 failWithTcM local_and_msg
997 = addErrTcM local_and_msg >> failM
998
999 checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true
1000 checkTc True _ = return ()
1001 checkTc False err = failWithTc err
1002
1003 -- Warnings have no 'M' variant, nor failure
1004
1005 warnTc :: Bool -> MsgDoc -> TcM ()
1006 warnTc warn_if_true warn_msg
1007 | warn_if_true = addWarnTc warn_msg
1008 | otherwise = return ()
1009
1010 addWarnTc :: MsgDoc -> TcM ()
1011 addWarnTc msg = do { env0 <- tcInitTidyEnv
1012 ; addWarnTcM (env0, msg) }
1013
1014 addWarnTcM :: (TidyEnv, MsgDoc) -> TcM ()
1015 addWarnTcM (env0, msg)
1016 = do { ctxt <- getErrCtxt ;
1017 err_info <- mkErrInfo env0 ctxt ;
1018 add_warn msg err_info }
1019
1020 addWarn :: MsgDoc -> TcRn ()
1021 addWarn msg = add_warn msg Outputable.empty
1022
1023 addWarnAt :: SrcSpan -> MsgDoc -> TcRn ()
1024 addWarnAt loc msg = add_warn_at loc msg Outputable.empty
1025
1026 add_warn :: MsgDoc -> MsgDoc -> TcRn ()
1027 add_warn msg extra_info
1028 = do { loc <- getSrcSpanM
1029 ; add_warn_at loc msg extra_info }
1030
1031 add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
1032 add_warn_at loc msg extra_info
1033 = do { dflags <- getDynFlags ;
1034 printer <- getPrintUnqualified dflags ;
1035 let { warn = mkLongWarnMsg dflags loc printer
1036 msg extra_info } ;
1037 reportWarning warn }
1038
1039 tcInitTidyEnv :: TcM TidyEnv
1040 tcInitTidyEnv
1041 = do { lcl_env <- getLclEnv
1042 ; return (tcl_tidy lcl_env) }
1043
1044 {-
1045 -----------------------------------
1046 Other helper functions
1047 -}
1048
1049 add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan
1050 -> [ErrCtxt]
1051 -> TcM ()
1052 add_err_tcm tidy_env err_msg loc ctxt
1053 = do { err_info <- mkErrInfo tidy_env ctxt ;
1054 addLongErrAt loc err_msg err_info }
1055
1056 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
1057 -- Tidy the error info, trimming excessive contexts
1058 mkErrInfo env ctxts
1059 -- | opt_PprStyle_Debug -- In -dppr-debug style the output
1060 -- = return empty -- just becomes too voluminous
1061 | otherwise
1062 = go 0 env ctxts
1063 where
1064 go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
1065 go _ _ [] = return Outputable.empty
1066 go n env ((is_landmark, ctxt) : ctxts)
1067 | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug
1068 = do { (env', msg) <- ctxt env
1069 ; let n' = if is_landmark then n else n+1
1070 ; rest <- go n' env' ctxts
1071 ; return (msg $$ rest) }
1072 | otherwise
1073 = go n env ctxts
1074
1075 mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts
1076 mAX_CONTEXTS = 3
1077
1078 -- debugTc is useful for monadic debugging code
1079
1080 debugTc :: TcM () -> TcM ()
1081 debugTc thing
1082 | debugIsOn = thing
1083 | otherwise = return ()
1084
1085 {-
1086 ************************************************************************
1087 * *
1088 Type constraints
1089 * *
1090 ************************************************************************
1091 -}
1092
1093 newTcEvBinds :: TcM EvBindsVar
1094 newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
1095 ; uniq <- newUnique
1096 ; return (EvBindsVar ref uniq) }
1097
1098 addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
1099 -- Add a binding to the TcEvBinds by side effect
1100 addTcEvBind (EvBindsVar ev_ref _) ev_bind
1101 = do { traceTc "addTcEvBind" $ ppr ev_bind
1102 ; bnds <- readTcRef ev_ref
1103 ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
1104
1105 getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind)
1106 getTcEvBinds (EvBindsVar ev_ref _)
1107 = do { bnds <- readTcRef ev_ref
1108 ; return (evBindMapBinds bnds) }
1109
1110 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
1111 chooseUniqueOccTc fn =
1112 do { env <- getGblEnv
1113 ; let dfun_n_var = tcg_dfun_n env
1114 ; set <- readTcRef dfun_n_var
1115 ; let occ = fn set
1116 ; writeTcRef dfun_n_var (extendOccSet set occ)
1117 ; return occ }
1118
1119 getConstraintVar :: TcM (TcRef WantedConstraints)
1120 getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
1121
1122 setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
1123 setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
1124
1125 emitConstraints :: WantedConstraints -> TcM ()
1126 emitConstraints ct
1127 = do { lie_var <- getConstraintVar ;
1128 updTcRef lie_var (`andWC` ct) }
1129
1130 emitSimple :: Ct -> TcM ()
1131 emitSimple ct
1132 = do { lie_var <- getConstraintVar ;
1133 updTcRef lie_var (`addSimples` unitBag ct) }
1134
1135 emitSimples :: Cts -> TcM ()
1136 emitSimples cts
1137 = do { lie_var <- getConstraintVar ;
1138 updTcRef lie_var (`addSimples` cts) }
1139
1140 emitImplication :: Implication -> TcM ()
1141 emitImplication ct
1142 = do { lie_var <- getConstraintVar ;
1143 updTcRef lie_var (`addImplics` unitBag ct) }
1144
1145 emitImplications :: Bag Implication -> TcM ()
1146 emitImplications ct
1147 = do { lie_var <- getConstraintVar ;
1148 updTcRef lie_var (`addImplics` ct) }
1149
1150 emitInsoluble :: Ct -> TcM ()
1151 emitInsoluble ct
1152 = do { lie_var <- getConstraintVar ;
1153 updTcRef lie_var (`addInsols` unitBag ct) ;
1154 v <- readTcRef lie_var ;
1155 traceTc "emitInsoluble" (ppr v) }
1156
1157 captureConstraints :: TcM a -> TcM (a, WantedConstraints)
1158 -- (captureConstraints m) runs m, and returns the type constraints it generates
1159 captureConstraints thing_inside
1160 = do { lie_var <- newTcRef emptyWC ;
1161 res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
1162 thing_inside ;
1163 lie <- readTcRef lie_var ;
1164 return (res, lie) }
1165
1166 pushLevelAndCaptureConstraints :: TcM a -> TcM (a, TcLevel, WantedConstraints)
1167 pushLevelAndCaptureConstraints thing_inside
1168 = do { env <- getLclEnv
1169 ; lie_var <- newTcRef emptyWC ;
1170 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1171 ; res <- setLclEnv (env { tcl_tclvl = tclvl'
1172 , tcl_lie = lie_var })
1173 thing_inside
1174 ; lie <- readTcRef lie_var
1175 ; return (res, tclvl', lie) }
1176
1177 pushTcLevelM_ :: TcM a -> TcM a
1178 pushTcLevelM_ = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) })
1179
1180 pushTcLevelM :: TcM a -> TcM (a, TcLevel)
1181 pushTcLevelM thing_inside
1182 = do { env <- getLclEnv
1183 ; let tclvl' = pushTcLevel (tcl_tclvl env)
1184 ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
1185 thing_inside
1186 ; return (res, tclvl') }
1187
1188 getTcLevel :: TcM TcLevel
1189 getTcLevel = do { env <- getLclEnv
1190 ; return (tcl_tclvl env) }
1191
1192 setTcLevel :: TcLevel -> TcM a -> TcM a
1193 setTcLevel tclvl thing_inside
1194 = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
1195
1196 isTouchableTcM :: TcTyVar -> TcM Bool
1197 isTouchableTcM tv
1198 = do { env <- getLclEnv
1199 ; return (isTouchableMetaTyVar (tcl_tclvl env) tv) }
1200
1201 getLclTypeEnv :: TcM TcTypeEnv
1202 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
1203
1204 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
1205 -- Set the local type envt, but do *not* disturb other fields,
1206 -- notably the lie_var
1207 setLclTypeEnv lcl_env thing_inside
1208 = updLclEnv upd thing_inside
1209 where
1210 upd env = env { tcl_env = tcl_env lcl_env,
1211 tcl_tyvars = tcl_tyvars lcl_env }
1212
1213 traceTcConstraints :: String -> TcM ()
1214 traceTcConstraints msg
1215 = do { lie_var <- getConstraintVar
1216 ; lie <- readTcRef lie_var
1217 ; traceTc (msg ++ ": LIE:") (ppr lie)
1218 }
1219
1220 emitWildcardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
1221 emitWildcardHoleConstraints wcs
1222 = do { ctLoc <- getCtLoc HoleOrigin
1223 ; forM_ wcs $ \(name, tv) -> do {
1224 ; let real_span = case nameSrcSpan name of
1225 RealSrcSpan span -> span
1226 UnhelpfulSpan str -> pprPanic "emitWildcardHoleConstraints"
1227 (ppr name <+> quotes (ftext str))
1228 -- Wildcards are defined locally, and so have RealSrcSpans
1229 ctLoc' = setCtLocSpan ctLoc real_span
1230 ty = mkTyVarTy tv
1231 ev = mkLocalId name ty
1232 can = CHoleCan { cc_ev = CtWanted ty ev ctLoc'
1233 , cc_occ = occName name
1234 , cc_hole = TypeHole }
1235 ; emitInsoluble can } }
1236
1237 {-
1238 ************************************************************************
1239 * *
1240 Template Haskell context
1241 * *
1242 ************************************************************************
1243 -}
1244
1245 recordThUse :: TcM ()
1246 recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
1247
1248 recordThSpliceUse :: TcM ()
1249 recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
1250
1251 keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set
1252 keepAlive name
1253 = do { env <- getGblEnv
1254 ; traceRn (ptext (sLit "keep alive") <+> ppr name)
1255 ; updTcRef (tcg_keep env) (`extendNameSet` name) }
1256
1257 getStage :: TcM ThStage
1258 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
1259
1260 getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
1261 getStageAndBindLevel name
1262 = do { env <- getLclEnv;
1263 ; case lookupNameEnv (tcl_th_bndrs env) name of
1264 Nothing -> return Nothing
1265 Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
1266
1267 setStage :: ThStage -> TcM a -> TcRn a
1268 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
1269
1270 {-
1271 ************************************************************************
1272 * *
1273 Safe Haskell context
1274 * *
1275 ************************************************************************
1276 -}
1277
1278 -- | Mark that safe inference has failed
1279 recordUnsafeInfer :: TcM ()
1280 recordUnsafeInfer = getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) False
1281
1282 -- | Figure out the final correct safe haskell mode
1283 finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
1284 finalSafeMode dflags tcg_env = do
1285 safeInf <- readIORef (tcg_safeInfer tcg_env)
1286 return $ case safeHaskell dflags of
1287 Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
1288 | otherwise -> Sf_None
1289 s -> s
1290
1291 {-
1292 ************************************************************************
1293 * *
1294 Stuff for the renamer's local env
1295 * *
1296 ************************************************************************
1297 -}
1298
1299 getLocalRdrEnv :: RnM LocalRdrEnv
1300 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
1301
1302 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
1303 setLocalRdrEnv rdr_env thing_inside
1304 = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
1305
1306 {-
1307 ************************************************************************
1308 * *
1309 Stuff for interface decls
1310 * *
1311 ************************************************************************
1312 -}
1313
1314 mkIfLclEnv :: Module -> SDoc -> IfLclEnv
1315 mkIfLclEnv mod loc = IfLclEnv { if_mod = mod,
1316 if_loc = loc,
1317 if_tv_env = emptyUFM,
1318 if_id_env = emptyUFM }
1319
1320 -- | Run an 'IfG' (top-level interface monad) computation inside an existing
1321 -- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
1322 -- based on 'TcGblEnv'.
1323 initIfaceTcRn :: IfG a -> TcRn a
1324 initIfaceTcRn thing_inside
1325 = do { tcg_env <- getGblEnv
1326 ; let { if_env = IfGblEnv {
1327 if_rec_types = Just (tcg_mod tcg_env, get_type_env)
1328 }
1329 ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
1330 ; setEnvs (if_env, ()) thing_inside }
1331
1332 initIfaceCheck :: HscEnv -> IfG a -> IO a
1333 -- Used when checking the up-to-date-ness of the old Iface
1334 -- Initialise the environment with no useful info at all
1335 initIfaceCheck hsc_env do_this
1336 = do let rec_types = case hsc_type_env_var hsc_env of
1337 Just (mod,var) -> Just (mod, readTcRef var)
1338 Nothing -> Nothing
1339 gbl_env = IfGblEnv { if_rec_types = rec_types }
1340 initTcRnIf 'i' hsc_env gbl_env () do_this
1341
1342 initIfaceTc :: ModIface
1343 -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
1344 -- Used when type-checking checking an up-to-date interface file
1345 -- No type envt from the current module, but we do know the module dependencies
1346 initIfaceTc iface do_this
1347 = do { tc_env_var <- newTcRef emptyTypeEnv
1348 ; let { gbl_env = IfGblEnv {
1349 if_rec_types = Just (mod, readTcRef tc_env_var)
1350 } ;
1351 ; if_lenv = mkIfLclEnv mod doc
1352 }
1353 ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
1354 }
1355 where
1356 mod = mi_module iface
1357 doc = ptext (sLit "The interface for") <+> quotes (ppr mod)
1358
1359 initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
1360 initIfaceLcl mod loc_doc thing_inside
1361 = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
1362
1363 getIfModule :: IfL Module
1364 getIfModule = do { env <- getLclEnv; return (if_mod env) }
1365
1366 --------------------
1367 failIfM :: MsgDoc -> IfL a
1368 -- The Iface monad doesn't have a place to accumulate errors, so we
1369 -- just fall over fast if one happens; it "shouldnt happen".
1370 -- We use IfL here so that we can get context info out of the local env
1371 failIfM msg
1372 = do { env <- getLclEnv
1373 ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1374 ; dflags <- getDynFlags
1375 ; liftIO (log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) full_msg)
1376 ; failM }
1377
1378 --------------------
1379 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1380 -- Run thing_inside in an interleaved thread.
1381 -- It shares everything with the parent thread, so this is DANGEROUS.
1382 --
1383 -- It returns Nothing if the computation fails
1384 --
1385 -- It's used for lazily type-checking interface
1386 -- signatures, which is pretty benign
1387
1388 forkM_maybe doc thing_inside
1389 -- NB: Don't share the mutable env_us with the interleaved thread since env_us
1390 -- does not get updated atomically (e.g. in newUnique and newUniqueSupply).
1391 = do { child_us <- newUniqueSupply
1392 ; child_env_us <- newMutVar child_us
1393 -- see Note [Masking exceptions in forkM_maybe]
1394 ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $
1395 do { traceIf (text "Starting fork {" <+> doc)
1396 ; mb_res <- tryM $
1397 updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1398 thing_inside
1399 ; case mb_res of
1400 Right r -> do { traceIf (text "} ending fork" <+> doc)
1401 ; return (Just r) }
1402 Left exn -> do {
1403
1404 -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1405 -- Otherwise we silently discard errors. Errors can legitimately
1406 -- happen when compiling interface signatures (see tcInterfaceSigs)
1407 whenDOptM Opt_D_dump_if_trace $ do
1408 dflags <- getDynFlags
1409 let msg = hang (text "forkM failed:" <+> doc)
1410 2 (text (show exn))
1411 liftIO $ log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg
1412
1413 ; traceIf (text "} ending fork (badly)" <+> doc)
1414 ; return Nothing }
1415 }}
1416
1417 forkM :: SDoc -> IfL a -> IfL a
1418 forkM doc thing_inside
1419 = do { mb_res <- forkM_maybe doc thing_inside
1420 ; return (case mb_res of
1421 Nothing -> pgmError "Cannot continue after interface file error"
1422 -- pprPanic "forkM" doc
1423 Just r -> r) }
1424
1425 {-
1426 Note [Masking exceptions in forkM_maybe]
1427 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1428
1429 When using GHC-as-API it must be possible to interrupt snippets of code
1430 executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
1431 by throwing an asynchronous interrupt to the GHC thread. However, there is a
1432 subtle problem: runStmt first typechecks the code before running it, and the
1433 exception might interrupt the type checker rather than the code. Moreover, the
1434 typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
1435 more importantly might be inside an exception handler inside that
1436 unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
1437 asynchronous exception as a synchronous exception, and the exception will end
1438 up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
1439 discussion). We don't currently know a general solution to this problem, but
1440 we can use uninterruptibleMask_ to avoid the situation.
1441 -}