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