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