remove some leftovers of the first ghci debugger prototype
[ghc.git] / compiler / typecheck / TcRnMonad.lhs
1 %
2 % (c) The University of Glasgow 2006
3 %
4
5 \begin{code}
6 module TcRnMonad(
7         module TcRnMonad,
8         module TcRnTypes,
9         module IOEnv
10   ) where
11
12 #include "HsVersions.h"
13
14 import TcRnTypes        -- Re-export all
15 import IOEnv            -- Re-export all
16
17 import HsSyn hiding (LIE)
18 import HscTypes
19 import Module
20 import RdrName
21 import Name
22 import TcType
23 import InstEnv
24 import FamInstEnv
25
26 import Var
27 import Id
28 import VarSet
29 import VarEnv
30 import ErrUtils
31 import SrcLoc
32 import NameEnv
33 import NameSet
34 import OccName
35 import Bag
36 import Outputable
37 import UniqSupply
38 import Unique
39 import DynFlags
40 import StaticFlags
41 import FastString
42 import Panic
43  
44 import System.IO
45 import Data.IORef
46 import Control.Exception
47 \end{code}
48
49
50
51 %************************************************************************
52 %*                                                                      *
53                         initTc
54 %*                                                                      *
55 %************************************************************************
56
57 \begin{code}
58 ioToTcRn :: IO r -> TcRn r
59 ioToTcRn = ioToIOEnv
60 \end{code}
61
62 \begin{code}
63
64 initTc :: HscEnv
65        -> HscSource
66        -> Bool          -- True <=> retain renamed syntax trees
67        -> Module 
68        -> TcM r
69        -> IO (Messages, Maybe r)
70                 -- Nothing => error thrown by the thing inside
71                 -- (error messages should have been printed already)
72
73 initTc hsc_env hsc_src keep_rn_syntax mod do_this
74  = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
75         tvs_var      <- newIORef emptyVarSet ;
76         type_env_var <- newIORef emptyNameEnv ;
77         dfuns_var    <- newIORef emptyNameSet ;
78         keep_var     <- newIORef emptyNameSet ;
79         th_var       <- newIORef False ;
80         dfun_n_var   <- newIORef 1 ;
81         let {
82              maybe_rn_syntax empty_val
83                 | keep_rn_syntax = Just empty_val
84                 | otherwise      = Nothing ;
85                         
86              gbl_env = TcGblEnv {
87                 tcg_mod       = mod,
88                 tcg_src       = hsc_src,
89                 tcg_rdr_env   = hsc_global_rdr_env hsc_env,
90                 tcg_fix_env   = emptyNameEnv,
91                 tcg_field_env = emptyNameEnv,
92                 tcg_default   = Nothing,
93                 tcg_type_env  = hsc_global_type_env hsc_env,
94                 tcg_type_env_var = type_env_var,
95                 tcg_inst_env  = emptyInstEnv,
96                 tcg_fam_inst_env  = emptyFamInstEnv,
97                 tcg_inst_uses = dfuns_var,
98                 tcg_th_used   = th_var,
99                 tcg_exports  = [],
100                 tcg_imports  = emptyImportAvails,
101                 tcg_dus      = emptyDUs,
102
103                 tcg_rn_imports = maybe_rn_syntax [],
104                 tcg_rn_exports = maybe_rn_syntax [],
105                 tcg_rn_decls   = maybe_rn_syntax emptyRnGroup,
106
107                 tcg_binds    = emptyLHsBinds,
108                 tcg_deprecs  = NoDeprecs,
109                 tcg_insts    = [],
110                 tcg_fam_insts= [],
111                 tcg_rules    = [],
112                 tcg_fords    = [],
113                 tcg_dfun_n   = dfun_n_var,
114                 tcg_keep     = keep_var,
115                 tcg_doc      = Nothing,
116                 tcg_hmi      = HaddockModInfo Nothing Nothing Nothing Nothing
117              } ;
118              lcl_env = TcLclEnv {
119                 tcl_errs       = errs_var,
120                 tcl_loc        = mkGeneralSrcSpan FSLIT("Top level"),
121                 tcl_ctxt       = [],
122                 tcl_rdr        = emptyLocalRdrEnv,
123                 tcl_th_ctxt    = topStage,
124                 tcl_arrow_ctxt = NoArrowCtxt,
125                 tcl_env        = emptyNameEnv,
126                 tcl_tyvars     = tvs_var,
127                 tcl_lie        = panic "initTc:LIE"     -- LIE only valid inside a getLIE
128              } ;
129         } ;
130    
131         -- OK, here's the business end!
132         maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
133                      do { r <- tryM do_this
134                         ; case r of
135                           Right res -> return (Just res)
136                           Left _    -> return Nothing } ;
137
138         -- Collect any error messages
139         msgs <- readIORef errs_var ;
140
141         let { dflags = hsc_dflags hsc_env
142             ; final_res | errorsFound dflags msgs = Nothing
143                         | otherwise               = maybe_res } ;
144
145         return (msgs, final_res)
146     }
147
148 initTcPrintErrors       -- Used from the interactive loop only
149        :: HscEnv
150        -> Module 
151        -> TcM r
152        -> IO (Maybe r)
153 initTcPrintErrors env mod todo = do
154   (msgs, res) <- initTc env HsSrcFile False mod todo
155   printErrorsAndWarnings (hsc_dflags env) msgs
156   return res
157 \end{code}
158
159 %************************************************************************
160 %*                                                                      *
161                 Initialisation
162 %*                                                                      *
163 %************************************************************************
164
165
166 \begin{code}
167 initTcRnIf :: Char              -- Tag for unique supply
168            -> HscEnv
169            -> gbl -> lcl 
170            -> TcRnIf gbl lcl a 
171            -> IO a
172 initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
173    = do { us     <- mkSplitUniqSupply uniq_tag ;
174         ; us_var <- newIORef us ;
175
176         ; let { env = Env { env_top = hsc_env,
177                             env_us  = us_var,
178                             env_gbl = gbl_env,
179                             env_lcl = lcl_env } }
180
181         ; runIOEnv env thing_inside
182         }
183 \end{code}
184
185 %************************************************************************
186 %*                                                                      *
187                 Simple accessors
188 %*                                                                      *
189 %************************************************************************
190
191 \begin{code}
192 getTopEnv :: TcRnIf gbl lcl HscEnv
193 getTopEnv = do { env <- getEnv; return (env_top env) }
194
195 getGblEnv :: TcRnIf gbl lcl gbl
196 getGblEnv = do { env <- getEnv; return (env_gbl env) }
197
198 updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
199 updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> 
200                           env { env_gbl = upd gbl })
201
202 setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
203 setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
204
205 getLclEnv :: TcRnIf gbl lcl lcl
206 getLclEnv = do { env <- getEnv; return (env_lcl env) }
207
208 updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
209 updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> 
210                           env { env_lcl = upd lcl })
211
212 setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
213 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
214
215 getEnvs :: TcRnIf gbl lcl (gbl, lcl)
216 getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
217
218 setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
219 setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
220 \end{code}
221
222
223 Command-line flags
224
225 \begin{code}
226 getDOpts :: TcRnIf gbl lcl DynFlags
227 getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
228
229 doptM :: DynFlag -> TcRnIf gbl lcl Bool
230 doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
231
232 setOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
233 setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
234                          env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} )
235
236 unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
237 unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
238                          env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )
239
240 ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()     -- Do it flag is true
241 ifOptM flag thing_inside = do { b <- doptM flag; 
242                                 if b then thing_inside else return () }
243
244 getGhcMode :: TcRnIf gbl lcl GhcMode
245 getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
246 \end{code}
247
248 \begin{code}
249 getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
250 getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
251
252 getEps :: TcRnIf gbl lcl ExternalPackageState
253 getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
254
255 -- Updating the EPS.  This should be an atomic operation.
256 -- Note the delicate 'seq' which forces the EPS before putting it in the
257 -- variable.  Otherwise what happens is that we get
258 --      write eps_var (....(unsafeRead eps_var)....)
259 -- and if the .... is strict, that's obviously bottom.  By forcing it beforehand
260 -- we make the unsafeRead happen before we update the variable.
261
262 updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
263           -> TcRnIf gbl lcl a
264 updateEps upd_fn = do   { traceIf (text "updating EPS")
265                         ; eps_var <- getEpsVar
266                         ; eps <- readMutVar eps_var
267                         ; let { (eps', val) = upd_fn eps }
268                         ; seq eps' (writeMutVar eps_var eps')
269                         ; return val }
270
271 updateEps_ :: (ExternalPackageState -> ExternalPackageState)
272            -> TcRnIf gbl lcl ()
273 updateEps_ upd_fn = do  { traceIf (text "updating EPS_")
274                         ; eps_var <- getEpsVar
275                         ; eps <- readMutVar eps_var
276                         ; let { eps' = upd_fn eps }
277                         ; seq eps' (writeMutVar eps_var eps') }
278
279 getHpt :: TcRnIf gbl lcl HomePackageTable
280 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
281
282 getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
283 getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
284                   ; return (eps, hsc_HPT env) }
285 \end{code}
286
287 %************************************************************************
288 %*                                                                      *
289                 Unique supply
290 %*                                                                      *
291 %************************************************************************
292
293 \begin{code}
294 newUnique :: TcRnIf gbl lcl Unique
295 newUnique
296  = do { env <- getEnv ;
297         let { u_var = env_us env } ;
298         us <- readMutVar u_var ;
299         case splitUniqSupply us of { (us1,_) -> do {
300         writeMutVar u_var us1 ;
301         return $! uniqFromSupply us }}}
302    -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
303    -- a chain of unevaluated supplies behind.
304    -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
305    -- throw away one half of the new split supply.  This is safe because this
306    -- is the only place we use that unique.  Using the other half of the split
307    -- supply is safer, but slower.
308
309 newUniqueSupply :: TcRnIf gbl lcl UniqSupply
310 newUniqueSupply
311  = do { env <- getEnv ;
312         let { u_var = env_us env } ;
313         us <- readMutVar u_var ;
314         case splitUniqSupply us of { (us1,us2) -> do {
315         writeMutVar u_var us1 ;
316         return us2 }}}
317
318 newLocalName :: Name -> TcRnIf gbl lcl Name
319 newLocalName name       -- Make a clone
320   = do  { uniq <- newUnique
321         ; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) }
322
323 newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
324 newSysLocalIds fs tys
325   = do  { us <- newUniqueSupply
326         ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
327 \end{code}
328
329
330 %************************************************************************
331 %*                                                                      *
332                 Debugging
333 %*                                                                      *
334 %************************************************************************
335
336 \begin{code}
337 traceTc, traceRn :: SDoc -> TcRn ()
338 traceRn      = traceOptTcRn Opt_D_dump_rn_trace
339 traceTc      = traceOptTcRn Opt_D_dump_tc_trace
340 traceSplice  = traceOptTcRn Opt_D_dump_splices
341
342
343 traceIf :: SDoc -> TcRnIf m n ()        
344 traceIf      = traceOptIf Opt_D_dump_if_trace
345 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
346
347
348 traceOptIf :: DynFlag -> SDoc -> TcRnIf m n ()  -- No RdrEnv available, so qualify everything
349 traceOptIf flag doc = ifOptM flag $
350                      ioToIOEnv (printForUser stderr alwaysQualify doc)
351
352 traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
353 traceOptTcRn flag doc = ifOptM flag $ do
354                         { ctxt <- getErrCtxt
355                         ; loc  <- getSrcSpanM
356                         ; env0 <- tcInitTidyEnv
357                         ; ctxt_msgs <- do_ctxt env0 ctxt 
358                         ; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
359                         ; dumpTcRn real_doc }
360
361 dumpTcRn :: SDoc -> TcRn ()
362 dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
363                     ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) }
364
365 dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
366 dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
367 \end{code}
368
369
370 %************************************************************************
371 %*                                                                      *
372                 Typechecker global environment
373 %*                                                                      *
374 %************************************************************************
375
376 \begin{code}
377 getModule :: TcRn Module
378 getModule = do { env <- getGblEnv; return (tcg_mod env) }
379
380 setModule :: Module -> TcRn a -> TcRn a
381 setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
382
383 tcIsHsBoot :: TcRn Bool
384 tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
385
386 getGlobalRdrEnv :: TcRn GlobalRdrEnv
387 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
388
389 getImports :: TcRn ImportAvails
390 getImports = do { env <- getGblEnv; return (tcg_imports env) }
391
392 getFixityEnv :: TcRn FixityEnv
393 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
394
395 extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
396 extendFixityEnv new_bit
397   = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> 
398                 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})           
399
400 getRecFieldEnv :: TcRn RecFieldEnv
401 getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
402
403 extendRecFieldEnv :: RecFieldEnv -> RnM a -> RnM a
404 extendRecFieldEnv new_bit
405   = updGblEnv (\env@(TcGblEnv { tcg_field_env = old_env }) -> 
406                 env {tcg_field_env = old_env `plusNameEnv` new_bit})         
407
408 getDeclaredDefaultTys :: TcRn (Maybe [Type])
409 getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
410 \end{code}
411
412 %************************************************************************
413 %*                                                                      *
414                 Error management
415 %*                                                                      *
416 %************************************************************************
417
418 \begin{code}
419 getSrcSpanM :: TcRn SrcSpan
420         -- Avoid clash with Name.getSrcLoc
421 getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
422
423 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
424 setSrcSpan loc thing_inside
425   | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
426   | otherwise         = thing_inside    -- Don't overwrite useful info with useless
427
428 addLocM :: (a -> TcM b) -> Located a -> TcM b
429 addLocM fn (L loc a) = setSrcSpan loc $ fn a
430
431 wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
432 wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
433
434 wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
435 wrapLocFstM fn (L loc a) =
436   setSrcSpan loc $ do
437     (b,c) <- fn a
438     return (L loc b, c)
439
440 wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
441 wrapLocSndM fn (L loc a) =
442   setSrcSpan loc $ do
443     (b,c) <- fn a
444     return (b, L loc c)
445 \end{code}
446
447
448 \begin{code}
449 getErrsVar :: TcRn (TcRef Messages)
450 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
451
452 setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
453 setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
454
455 addErr :: Message -> TcRn ()
456 addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
457
458 addLocErr :: Located e -> (e -> Message) -> TcRn ()
459 addLocErr (L loc e) fn = addErrAt loc (fn e)
460
461 addErrAt :: SrcSpan -> Message -> TcRn ()
462 addErrAt loc msg = addLongErrAt loc msg empty
463
464 addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
465 addLongErrAt loc msg extra
466   = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;  
467          errs_var <- getErrsVar ;
468          rdr_env <- getGlobalRdrEnv ;
469          let { err = mkLongErrMsg loc (mkPrintUnqualified rdr_env) msg extra } ;
470          (warns, errs) <- readMutVar errs_var ;
471          writeMutVar errs_var (warns, errs `snocBag` err) }
472
473 addErrs :: [(SrcSpan,Message)] -> TcRn ()
474 addErrs msgs = mappM_ add msgs
475              where
476                add (loc,msg) = addErrAt loc msg
477
478 addReport :: Message -> TcRn ()
479 addReport msg = do loc <- getSrcSpanM; addReportAt loc msg
480
481 addReportAt :: SrcSpan -> Message -> TcRn ()
482 addReportAt loc msg
483   = do { errs_var <- getErrsVar ;
484          rdr_env <- getGlobalRdrEnv ;
485          let { warn = mkWarnMsg loc (mkPrintUnqualified rdr_env) msg } ;
486          (warns, errs) <- readMutVar errs_var ;
487          writeMutVar errs_var (warns `snocBag` warn, errs) }
488
489 addWarn :: Message -> TcRn ()
490 addWarn msg = addReport (ptext SLIT("Warning:") <+> msg)
491
492 addWarnAt :: SrcSpan -> Message -> TcRn ()
493 addWarnAt loc msg = addReportAt loc (ptext SLIT("Warning:") <+> msg)
494
495 addLocWarn :: Located e -> (e -> Message) -> TcRn ()
496 addLocWarn (L loc e) fn = addReportAt loc (fn e)
497
498 checkErr :: Bool -> Message -> TcRn ()
499 -- Add the error if the bool is False
500 checkErr ok msg = checkM ok (addErr msg)
501
502 warnIf :: Bool -> Message -> TcRn ()
503 warnIf True  msg = addWarn msg
504 warnIf False msg = return ()
505
506 addMessages :: Messages -> TcRn ()
507 addMessages (m_warns, m_errs)
508   = do { errs_var <- getErrsVar ;
509          (warns, errs) <- readMutVar errs_var ;
510          writeMutVar errs_var (warns `unionBags` m_warns,
511                                errs  `unionBags` m_errs) }
512
513 discardWarnings :: TcRn a -> TcRn a
514 -- Ignore warnings inside the thing inside;
515 -- used to ignore-unused-variable warnings inside derived code
516 -- With -dppr-debug, the effects is switched off, so you can still see
517 -- what warnings derived code would give
518 discardWarnings thing_inside
519   | opt_PprStyle_Debug = thing_inside
520   | otherwise
521   = do  { errs_var <- newMutVar emptyMessages
522         ; result <- setErrsVar errs_var thing_inside
523         ; (_warns, errs) <- readMutVar errs_var
524         ; addMessages (emptyBag, errs)
525         ; return result }
526 \end{code}
527
528
529 \begin{code}
530 try_m :: TcRn r -> TcRn (Either Exception r)
531 -- Does try_m, with a debug-trace on failure
532 try_m thing 
533   = do { mb_r <- tryM thing ;
534          case mb_r of 
535              Left exn -> do { traceTc (exn_msg exn); return mb_r }
536              Right r  -> return mb_r }
537   where
538     exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn)
539
540 -----------------------
541 recoverM :: TcRn r      -- Recovery action; do this if the main one fails
542          -> TcRn r      -- Main action: do this first
543          -> TcRn r
544 -- Errors in 'thing' are retained
545 recoverM recover thing 
546   = do { mb_res <- try_m thing ;
547          case mb_res of
548            Left exn  -> recover
549            Right res -> returnM res }
550
551 -----------------------
552 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
553 -- (tryTc m) executes m, and returns
554 --      Just r,  if m succeeds (returning r)
555 --      Nothing, if m fails
556 -- It also returns all the errors and warnings accumulated by m
557 -- It always succeeds (never raises an exception)
558 tryTc m 
559  = do { errs_var <- newMutVar emptyMessages ;
560         res  <- try_m (setErrsVar errs_var m) ; 
561         msgs <- readMutVar errs_var ;
562         return (msgs, case res of
563                             Left exn  -> Nothing
564                             Right val -> Just val)
565         -- The exception is always the IOEnv built-in
566         -- in exception; see IOEnv.failM
567    }
568
569 -----------------------
570 tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
571 -- Run the thing, returning 
572 --      Just r,  if m succceeds with no error messages
573 --      Nothing, if m fails, or if it succeeds but has error messages
574 -- Either way, the messages are returned; even in the Just case
575 -- there might be warnings
576 tryTcErrs thing 
577   = do  { (msgs, res) <- tryTc thing
578         ; dflags <- getDOpts
579         ; let errs_found = errorsFound dflags msgs
580         ; return (msgs, case res of
581                           Nothing -> Nothing
582                           Just val | errs_found -> Nothing
583                                    | otherwise  -> Just val)
584         }
585
586 -----------------------
587 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
588 -- Just like tryTcErrs, except that it ensures that the LIE
589 -- for the thing is propagated only if there are no errors
590 -- Hence it's restricted to the type-check monad
591 tryTcLIE thing_inside
592   = do  { ((msgs, mb_res), lie) <- getLIE (tryTcErrs thing_inside) ;
593         ; case mb_res of
594             Nothing  -> return (msgs, Nothing)
595             Just val -> do { extendLIEs lie; return (msgs, Just val) }
596         }
597
598 -----------------------
599 tryTcLIE_ :: TcM r -> TcM r -> TcM r
600 -- (tryTcLIE_ r m) tries m; 
601 --      if m succeeds with no error messages, it's the answer
602 --      otherwise tryTcLIE_ drops everything from m and tries r instead.
603 tryTcLIE_ recover main
604   = do  { (msgs, mb_res) <- tryTcLIE main
605         ; case mb_res of
606              Just val -> do { addMessages msgs  -- There might be warnings
607                              ; return val }
608              Nothing  -> recover                -- Discard all msgs
609         }
610
611 -----------------------
612 checkNoErrs :: TcM r -> TcM r
613 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
614 -- If m fails then (checkNoErrsTc m) fails.
615 -- If m succeeds, it checks whether m generated any errors messages
616 --      (it might have recovered internally)
617 --      If so, it fails too.
618 -- Regardless, any errors generated by m are propagated to the enclosing context.
619 checkNoErrs main
620   = do  { (msgs, mb_res) <- tryTcLIE main
621         ; addMessages msgs
622         ; case mb_res of
623             Nothing   -> failM
624             Just val -> return val
625         } 
626
627 ifErrsM :: TcRn r -> TcRn r -> TcRn r
628 --      ifErrsM bale_out main
629 -- does 'bale_out' if there are errors in errors collection
630 -- otherwise does 'main'
631 ifErrsM bale_out normal
632  = do { errs_var <- getErrsVar ;
633         msgs <- readMutVar errs_var ;
634         dflags <- getDOpts ;
635         if errorsFound dflags msgs then
636            bale_out
637         else    
638            normal }
639
640 failIfErrsM :: TcRn ()
641 -- Useful to avoid error cascades
642 failIfErrsM = ifErrsM failM (return ())
643 \end{code}
644
645
646 %************************************************************************
647 %*                                                                      *
648         Context management and error message generation
649                     for the type checker
650 %*                                                                      *
651 %************************************************************************
652
653 \begin{code}
654 getErrCtxt :: TcM ErrCtxt
655 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
656
657 setErrCtxt :: ErrCtxt -> TcM a -> TcM a
658 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
659
660 addErrCtxt :: Message -> TcM a -> TcM a
661 addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg))
662
663 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
664 addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)
665
666 -- Helper function for the above
667 updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a
668 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> 
669                            env { tcl_ctxt = upd ctxt })
670
671 -- Conditionally add an error context
672 maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a
673 maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside
674 maybeAddErrCtxt Nothing    thing_inside = thing_inside
675
676 popErrCtxt :: TcM a -> TcM a
677 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (m:ms) -> ms })
678
679 getInstLoc :: InstOrigin -> TcM InstLoc
680 getInstLoc origin
681   = do { loc <- getSrcSpanM ; env <- getLclEnv ;
682          return (InstLoc origin loc (tcl_ctxt env)) }
683
684 addInstCtxt :: InstLoc -> TcM a -> TcM a
685 -- Add the SrcSpan and context from the first Inst in the list
686 --      (they all have similar locations)
687 addInstCtxt (InstLoc _ src_loc ctxt) thing_inside
688   = setSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside)
689 \end{code}
690
691     The addErrTc functions add an error message, but do not cause failure.
692     The 'M' variants pass a TidyEnv that has already been used to
693     tidy up the message; we then use it to tidy the context messages
694
695 \begin{code}
696 addErrTc :: Message -> TcM ()
697 addErrTc err_msg = do { env0 <- tcInitTidyEnv
698                       ; addErrTcM (env0, err_msg) }
699
700 addErrsTc :: [Message] -> TcM ()
701 addErrsTc err_msgs = mappM_ addErrTc err_msgs
702
703 addErrTcM :: (TidyEnv, Message) -> TcM ()
704 addErrTcM (tidy_env, err_msg)
705   = do { ctxt <- getErrCtxt ;
706          loc  <- getSrcSpanM ;
707          add_err_tcm tidy_env err_msg loc ctxt }
708 \end{code}
709
710 The failWith functions add an error message and cause failure
711
712 \begin{code}
713 failWithTc :: Message -> TcM a               -- Add an error message and fail
714 failWithTc err_msg 
715   = addErrTc err_msg >> failM
716
717 failWithTcM :: (TidyEnv, Message) -> TcM a   -- Add an error message and fail
718 failWithTcM local_and_msg
719   = addErrTcM local_and_msg >> failM
720
721 checkTc :: Bool -> Message -> TcM ()         -- Check that the boolean is true
722 checkTc True  err = returnM ()
723 checkTc False err = failWithTc err
724 \end{code}
725
726         Warnings have no 'M' variant, nor failure
727
728 \begin{code}
729 addWarnTc :: Message -> TcM ()
730 addWarnTc msg = do { env0 <- tcInitTidyEnv 
731                    ; addWarnTcM (env0, msg) }
732
733 addWarnTcM :: (TidyEnv, Message) -> TcM ()
734 addWarnTcM (env0, msg)
735  = do { ctxt <- getErrCtxt ;
736         ctxt_msgs <- do_ctxt env0 ctxt ;
737         addReport (vcat (ptext SLIT("Warning:") <+> msg : ctxt_to_use ctxt_msgs)) }
738
739 warnTc :: Bool -> Message -> TcM ()
740 warnTc warn_if_true warn_msg
741   | warn_if_true = addWarnTc warn_msg
742   | otherwise    = return ()
743 \end{code}
744
745 -----------------------------------
746          Tidying
747
748 We initialise the "tidy-env", used for tidying types before printing,
749 by building a reverse map from the in-scope type variables to the
750 OccName that the programmer originally used for them
751
752 \begin{code}
753 tcInitTidyEnv :: TcM TidyEnv
754 tcInitTidyEnv
755   = do  { lcl_env <- getLclEnv
756         ; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty)
757                           | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)
758                           , tcIsTyVarTy ty ]
759         ; return (foldl add emptyTidyEnv nm_tv_prs) }
760   where
761     add (env,subst) (name, tyvar)
762         = case tidyOccName env (nameOccName name) of
763             (env', occ') ->  (env', extendVarEnv subst tyvar tyvar')
764                 where
765                   tyvar' = setTyVarName tyvar name'
766                   name'  = tidyNameOcc name occ'
767 \end{code}
768
769 -----------------------------------
770         Other helper functions
771
772 \begin{code}
773 add_err_tcm tidy_env err_msg loc ctxt
774  = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
775         addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }
776
777 do_ctxt tidy_env []
778  = return []
779 do_ctxt tidy_env (c:cs)
780  = do { (tidy_env', m) <- c tidy_env  ;
781         ms             <- do_ctxt tidy_env' cs  ;
782         return (m:ms) }
783
784 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
785                  | otherwise          = take 3 ctxt
786 \end{code}
787
788 debugTc is useful for monadic debugging code
789
790 \begin{code}
791 debugTc :: TcM () -> TcM ()
792 #ifdef DEBUG
793 debugTc thing = thing
794 #else
795 debugTc thing = return ()
796 #endif
797 \end{code}
798
799  %************************************************************************
800 %*                                                                      *
801              Type constraints (the so-called LIE)
802 %*                                                                      *
803 %************************************************************************
804
805 \begin{code}
806 nextDFunIndex :: TcM Int        -- Get the next dfun index
807 nextDFunIndex = do { env <- getGblEnv
808                    ; let dfun_n_var = tcg_dfun_n env
809                    ; n <- readMutVar dfun_n_var
810                    ; writeMutVar dfun_n_var (n+1)
811                    ; return n }
812
813 getLIEVar :: TcM (TcRef LIE)
814 getLIEVar = do { env <- getLclEnv; return (tcl_lie env) }
815
816 setLIEVar :: TcRef LIE -> TcM a -> TcM a
817 setLIEVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
818
819 getLIE :: TcM a -> TcM (a, [Inst])
820 -- (getLIE m) runs m, and returns the type constraints it generates
821 getLIE thing_inside
822   = do { lie_var <- newMutVar emptyLIE ;
823          res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) 
824                           thing_inside ;
825          lie <- readMutVar lie_var ;
826          return (res, lieToList lie) }
827
828 extendLIE :: Inst -> TcM ()
829 extendLIE inst
830   = do { lie_var <- getLIEVar ;
831          lie <- readMutVar lie_var ;
832          writeMutVar lie_var (inst `consLIE` lie) }
833
834 extendLIEs :: [Inst] -> TcM ()
835 extendLIEs [] 
836   = returnM ()
837 extendLIEs insts
838   = do { lie_var <- getLIEVar ;
839          lie <- readMutVar lie_var ;
840          writeMutVar lie_var (mkLIE insts `plusLIE` lie) }
841 \end{code}
842
843 \begin{code}
844 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
845 -- Set the local type envt, but do *not* disturb other fields,
846 -- notably the lie_var
847 setLclTypeEnv lcl_env thing_inside
848   = updLclEnv upd thing_inside
849   where
850     upd env = env { tcl_env = tcl_env lcl_env,
851                     tcl_tyvars = tcl_tyvars lcl_env }
852 \end{code}
853
854
855 %************************************************************************
856 %*                                                                      *
857              Template Haskell context
858 %*                                                                      *
859 %************************************************************************
860
861 \begin{code}
862 recordThUse :: TcM ()
863 recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True }
864
865 keepAliveTc :: Name -> TcM ()   -- Record the name in the keep-alive set
866 keepAliveTc n = do { env <- getGblEnv; 
867                    ; updMutVar (tcg_keep env) (`addOneToNameSet` n) }
868
869 keepAliveSetTc :: NameSet -> TcM ()     -- Record the name in the keep-alive set
870 keepAliveSetTc ns = do { env <- getGblEnv; 
871                        ; updMutVar (tcg_keep env) (`unionNameSets` ns) }
872
873 getStage :: TcM ThStage
874 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
875
876 setStage :: ThStage -> TcM a -> TcM a 
877 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
878 \end{code}
879
880
881 %************************************************************************
882 %*                                                                      *
883              Stuff for the renamer's local env
884 %*                                                                      *
885 %************************************************************************
886
887 \begin{code}
888 getLocalRdrEnv :: RnM LocalRdrEnv
889 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
890
891 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
892 setLocalRdrEnv rdr_env thing_inside 
893   = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
894 \end{code}
895
896
897 %************************************************************************
898 %*                                                                      *
899              Stuff for interface decls
900 %*                                                                      *
901 %************************************************************************
902
903 \begin{code}
904 mkIfLclEnv :: Module -> SDoc -> IfLclEnv
905 mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
906                                 if_loc     = loc,
907                                 if_tv_env  = emptyOccEnv,
908                                 if_id_env  = emptyOccEnv }
909
910 initIfaceTcRn :: IfG a -> TcRn a
911 initIfaceTcRn thing_inside
912   = do  { tcg_env <- getGblEnv 
913         ; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
914               ; get_type_env = readMutVar (tcg_type_env_var tcg_env) }
915         ; setEnvs (if_env, ()) thing_inside }
916
917 initIfaceExtCore :: IfL a -> TcRn a
918 initIfaceExtCore thing_inside
919   = do  { tcg_env <- getGblEnv 
920         ; let { mod = tcg_mod tcg_env
921               ; doc = ptext SLIT("External Core file for") <+> quotes (ppr mod)
922               ; if_env = IfGblEnv { 
923                         if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
924               ; if_lenv = mkIfLclEnv mod doc
925           }
926         ; setEnvs (if_env, if_lenv) thing_inside }
927
928 initIfaceCheck :: HscEnv -> IfG a -> IO a
929 -- Used when checking the up-to-date-ness of the old Iface
930 -- Initialise the environment with no useful info at all
931 initIfaceCheck hsc_env do_this
932  = do   { let gbl_env = IfGblEnv { if_rec_types = Nothing }
933         ; initTcRnIf 'i' hsc_env gbl_env () do_this
934     }
935
936 initIfaceTc :: ModIface 
937             -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
938 -- Used when type-checking checking an up-to-date interface file
939 -- No type envt from the current module, but we do know the module dependencies
940 initIfaceTc iface do_this
941  = do   { tc_env_var <- newMutVar emptyTypeEnv
942         ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
943               ; if_lenv = mkIfLclEnv mod doc
944            }
945         ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
946     }
947   where
948     mod = mi_module iface
949     doc = ptext SLIT("The interface for") <+> quotes (ppr mod)
950
951 initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
952 -- Used when sucking in new Rules in SimplCore
953 -- We have available the type envt of the module being compiled, and we must use it
954 initIfaceRules hsc_env guts do_this
955  = do   { let {
956              type_info = (mg_module guts, return (mg_types guts))
957            ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ;
958            }
959
960         -- Run the thing; any exceptions just bubble out from here
961         ; initTcRnIf 'i' hsc_env gbl_env () do_this
962     }
963
964 initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
965 initIfaceLcl mod loc_doc thing_inside 
966   = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
967
968 getIfModule :: IfL Module
969 getIfModule = do { env <- getLclEnv; return (if_mod env) }
970
971 --------------------
972 failIfM :: Message -> IfL a
973 -- The Iface monad doesn't have a place to accumulate errors, so we
974 -- just fall over fast if one happens; it "shouldnt happen".
975 -- We use IfL here so that we can get context info out of the local env
976 failIfM msg
977   = do  { env <- getLclEnv
978         ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
979         ; ioToIOEnv (printErrs (full_msg defaultErrStyle))
980         ; failM }
981
982 --------------------
983 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
984 -- Run thing_inside in an interleaved thread.  
985 -- It shares everything with the parent thread, so this is DANGEROUS.  
986 --
987 -- It returns Nothing if the computation fails
988 -- 
989 -- It's used for lazily type-checking interface
990 -- signatures, which is pretty benign
991
992 forkM_maybe doc thing_inside
993  = do { unsafeInterleaveM $
994         do { traceIf (text "Starting fork {" <+> doc)
995            ; mb_res <- tryM $
996                        updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ 
997                        thing_inside
998            ; case mb_res of
999                 Right r  -> do  { traceIf (text "} ending fork" <+> doc)
1000                                 ; return (Just r) }
1001                 Left exn -> do {
1002
1003                     -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1004                     -- Otherwise we silently discard errors. Errors can legitimately
1005                     -- happen when compiling interface signatures (see tcInterfaceSigs)
1006                       ifOptM Opt_D_dump_if_trace 
1007                              (print_errs (hang (text "forkM failed:" <+> doc)
1008                                              4 (text (show exn))))
1009
1010                     ; traceIf (text "} ending fork (badly)" <+> doc)
1011                     ; return Nothing }
1012         }}
1013   where
1014     print_errs sdoc = ioToIOEnv (printErrs (sdoc defaultErrStyle))
1015
1016 forkM :: SDoc -> IfL a -> IfL a
1017 forkM doc thing_inside
1018  = do   { mb_res <- forkM_maybe doc thing_inside
1019         ; return (case mb_res of 
1020                         Nothing -> pgmError "Cannot continue after interface file error"
1021                                    -- pprPanic "forkM" doc
1022                         Just r  -> r) }
1023 \end{code}
1024
1025